1 files changed, 62 insertions, 28 deletions

diff --git a/main/State.hs b/main/State.hs
index d357844..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
@@ -58,9 +93,8 @@ updateSharedIdentity term = updateLocalState_ $ updateSharedState_ $ \case
     Nothing -> throwOtherError "no existing shared identity"
 
 interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => Terminal -> Identity f -> m UnifiedIdentity
-interactiveIdentityUpdate term identity = do
-    let public = idKeyIdentity identity
-
+interactiveIdentityUpdate term fidentity = do
+    identity <- mergeIdentity fidentity
     name <- liftIO $ do
         setPrompt term $ T.unpack $ T.concat $ concat
             [ [ T.pack "Name" ]
@@ -71,11 +105,11 @@ interactiveIdentityUpdate term identity = do
             ]
         getInputLine term $ KeepPrompt . maybe T.empty T.pack
 
-    if  | T.null name -> mergeIdentity identity
+    if  | T.null name -> return identity
         | otherwise -> do
-            secret <- loadKey public
-            maybe (throwOtherError "created invalid identity") return . validateIdentity =<<
-                mstore =<< sign secret =<< mstore (emptyIdentityData public)
-                { iddPrev = toList $ idDataF identity
-                , iddName = Just name
+            secret <- loadKey $ idKeyIdentity identity
+            maybe (throwOtherError "created invalid identity") return . validateExtendedIdentity =<<
+                mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData identity)
+                { idePrev = toList $ idExtDataF identity
+                , ideName = Just name
                 }