1 files changed, 54 insertions, 19 deletions
diff --git a/main/State.hs b/main/State.hs
index 150178e..5d66ba9 100644
--- a/main/State.hs
+++ b/main/State.hs
@@ -1,15 +1,17 @@
 module State (
     loadLocalStateHead,
+    createLocalStateHead,
     updateSharedIdentity,
     interactiveIdentityUpdate,
 ) where
 
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 
 import Data.Foldable
-import Data.Maybe
 import Data.Proxy
+import Data.Text (Text)
 import Data.Text qualified as T
 
 import Erebos.Error
@@ -22,34 +24,67 @@ import Erebos.Storage
 import Terminal
 
 
-loadLocalStateHead :: MonadIO m => Terminal -> Storage -> m (Head LocalState)
-loadLocalStateHead term st = loadHeads st >>= \case
-    (h:_) -> return h
-    [] -> liftIO $ do
-        setPrompt term "Name: "
-        name <- getInputLine term $ KeepPrompt . maybe T.empty T.pack
+loadLocalStateHead
+    :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)
+    => Terminal -> m (Head LocalState)
+loadLocalStateHead term = getStorage >>= loadHeads >>= \case
+    (h : _) -> return h
+    [] -> do
+        name <- liftIO $ do
+            setPrompt term "Name: "
+            getInputLine term $ KeepPrompt . maybe T.empty T.pack
 
-        setPrompt term "Device: "
-        devName <- getInputLine term $ KeepPrompt . maybe T.empty T.pack
+        devName <- liftIO $ do
+            setPrompt term "Device: "
+            getInputLine term $ KeepPrompt . maybe T.empty T.pack
 
-        owner <- if
-            | T.null name -> return Nothing
-            | otherwise -> Just <$> createIdentity st (Just name) Nothing
+        ( owner, shared ) <- if
+            | T.null name -> do
+                return ( Nothing, [] )
+            | otherwise -> do
+                owner <- createIdentity (Just name) Nothing
+                shared <- mstore SharedState
+                    { ssPrev = []
+                    , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
+                    , ssValue = [ storedRef $ idExtData owner ]
+                    }
+                return ( Just owner, [ shared ] )
 
-        identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner
+        identity <- createIdentity (if T.null devName then Nothing else Just devName) owner
 
-        shared <- wrappedStore st $ SharedState
-            { ssPrev = []
-            , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
-            , ssValue = [ storedRef $ idExtData $ fromMaybe identity owner ]
-            }
+        st <- getStorage
         storeHead st $ LocalState
             { lsPrev = Nothing
             , lsIdentity = idExtData identity
-            , lsShared = [ shared ]
+            , lsShared = shared
             , lsOther = []
             }
 
+createLocalStateHead
+    :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)
+    => [ Maybe Text ] -> m (Head LocalState)
+createLocalStateHead [] = throwOtherError "createLocalStateHead: empty name list"
+createLocalStateHead ( ownerName : names ) = do
+    owner <- createIdentity ownerName Nothing
+    identity <- foldM createSingleIdentity owner names
+    shared <- case names of
+        [] -> return []
+        _ : _ -> do
+            fmap (: []) $ mstore SharedState
+                { ssPrev = []
+                , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
+                , ssValue = [ storedRef $ idExtData owner ]
+                }
+    st <- getStorage
+    storeHead st $ LocalState
+        { lsPrev = Nothing
+        , lsIdentity = idExtData identity
+        , lsShared = shared
+        , lsOther = []
+        }
+  where
+    createSingleIdentity owner name = createIdentity name (Just owner)
+
 
 updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m ()
 updateSharedIdentity term = updateLocalState_ $ updateSharedState_ $ \case