Use MonadStorage for createIdentity

Changelog: API: `Identity.createIdentity` uses `MonadStorage`

4 files changed, 57 insertions, 47 deletions

diff --git a/main/Main.hs b/main/Main.hs
index a3b74b1..5bda7e7 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -287,7 +287,7 @@ main = do
         ["update-identity"] -> do
             withTerminal noCompletion $ \term -> do
                 either (fail . showErebosError) return <=< runExceptT $ do
-                    runReaderT (updateSharedIdentity term) =<< loadLocalStateHead term st
+                    runReaderT (updateSharedIdentity term) =<< runReaderT (loadLocalStateHead term) st
 
         ("update-identity" : srefs) -> do
             withTerminal noCompletion $ \term -> do
@@ -329,9 +329,10 @@ main = do
 
 interactiveLoop :: Storage -> Options -> IO ()
 interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
-    erebosHead <- case optCreateIdentity opts of
-        Nothing -> loadLocalStateHead term st
-        Just ( devName, names ) -> createLocalStateHead st (names ++ [ devName ])
+    erebosHead <- either (fail . showErebosError) return <=< runExceptT . flip runReaderT st $ do
+        case optCreateIdentity opts of
+            Nothing -> loadLocalStateHead term
+            Just ( devName, names ) -> createLocalStateHead (names ++ [ devName ])
     void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
 
     let tui = hasTerminalUI term
@@ -703,8 +704,7 @@ cmdJoin = joinChatroom =<< getSelectedChatroom
 cmdJoinAs :: Command
 cmdJoinAs = do
     name <- asks ciLine
-    st <- getStorage
-    identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing
+    identity <- createIdentity (Just $ T.pack name) Nothing
     joinChatroomAs identity =<< getSelectedChatroom
 
 cmdLeave :: Command
diff --git a/main/State.hs b/main/State.hs
index b8ae418..5d66ba9 100644
--- a/main/State.hs
+++ b/main/State.hs
@@ -24,30 +24,35 @@ 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, shared ) <- if
             | T.null name -> do
                 return ( Nothing, [] )
             | otherwise -> do
-                owner <- createIdentity st (Just name) Nothing
-                shared <- wrappedStore st $ SharedState
+                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
 
+        st <- getStorage
         storeHead st $ LocalState
             { lsPrev = Nothing
             , lsIdentity = idExtData identity
@@ -55,19 +60,22 @@ loadLocalStateHead term st = loadHeads st >>= \case
             , lsOther = []
             }
 
-createLocalStateHead :: (MonadIO m, MonadFail m) => Storage -> [ Maybe Text ] -> m (Head LocalState)
-createLocalStateHead _ [] = fail "createLocalStateHead: empty name list"
-createLocalStateHead st ( ownerName : names ) = liftIO $ do
-    owner <- createIdentity st ownerName Nothing
+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 (: []) $ wrappedStore st $ SharedState
+            fmap (: []) $ mstore SharedState
                 { ssPrev = []
                 , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
                 , ssValue = [ storedRef $ idExtData owner ]
                 }
+    st <- getStorage
     storeHead st $ LocalState
         { lsPrev = Nothing
         , lsIdentity = idExtData identity
@@ -75,7 +83,7 @@ createLocalStateHead st ( ownerName : names ) = liftIO $ do
         , lsOther = []
         }
   where
-    createSingleIdentity owner name = createIdentity st name (Just owner)
+    createSingleIdentity owner name = createIdentity name (Just owner)
 
 
 updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m ()
diff --git a/main/Test.hs b/main/Test.hs
index b59bd74..c3dca14 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -483,9 +483,9 @@ cmdCreateIdentity = do
     names <- asks tiParams
 
     h <- do
-        Just identity <- liftIO $ if null names
-            then Just <$> createIdentity st Nothing Nothing
-            else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names
+        Just identity <- if null names
+            then Just <$> createIdentity Nothing Nothing
+            else foldrM (\n o -> Just <$> createIdentity (Just n) o) Nothing names
 
         shared <- case names of
             _:_:_ -> (: []) <$> makeSharedStateUpdate (Just $ finalOwner identity) []
@@ -986,8 +986,7 @@ cmdChatroomJoin = do
 cmdChatroomJoinAs :: Command
 cmdChatroomJoinAs = do
     [ cid, name ] <- asks tiParams
-    st <- asks tiStorage
-    identity <- liftIO $ createIdentity st (Just name) Nothing
+    identity <- createIdentity (Just name) Nothing
     joinChatroomAsByStateData identity =<< getChatroomStateData cid
     cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ]
 
diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs
index a3f17b5..bd5acb3 100644
--- a/src/Erebos/Identity.hs
+++ b/src/Erebos/Identity.hs
@@ -214,29 +214,33 @@ isExtension x = case fromSigned x of BaseIdentityData {} -> False
                                      _ -> True
 
 
-createIdentity :: Storage -> Maybe Text -> Maybe UnifiedIdentity -> IO UnifiedIdentity
-createIdentity st name owner = do
-    (secret, public) <- generateKeys st
-    (_secretMsg, publicMsg) <- generateKeys st
-
-    let signOwner :: Signed a -> ReaderT Storage IO (Signed a)
+createIdentity
+    :: forall m e. (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)
+    => Maybe Text -> Maybe UnifiedIdentity -> m UnifiedIdentity
+createIdentity name owner = do
+    st <- getStorage
+    ( secret, public ) <- liftIO $ generateKeys st
+    ( _secretMsg, publicMsg ) <- liftIO $ generateKeys st
+
+    let signOwner :: Signed a -> m (Signed a)
         signOwner idd
             | Just o <- owner = do
-                Just ownerSecret <- loadKeyMb (iddKeyIdentity $ fromSigned $ idData o)
+                ownerSecret <- maybe (throwOtherError "failed to load private key") return =<<
+                    loadKeyMb (iddKeyIdentity $ fromSigned $ idData o)
                 signAdd ownerSecret idd
             | otherwise = return idd
 
-    Just identity <- flip runReaderT st $ do
-        baseData <- mstore =<< signOwner =<< sign secret =<<
-            mstore (emptyIdentityData public)
-                { iddOwner = idData <$> owner
-                , iddKeyMessage = Just publicMsg
-                }
-        let extOwner = do
-                odata <- idExtData <$> owner
-                guard $ isExtension odata
-                return odata
-
+    baseData <- mstore =<< signOwner =<< sign secret =<<
+        mstore (emptyIdentityData public)
+            { iddOwner = idData <$> owner
+            , iddKeyMessage = Just publicMsg
+            }
+    let extOwner = do
+            odata <- idExtData <$> owner
+            guard $ isExtension odata
+            return odata
+
+    maybe (throwOtherError "created invalid identity") return =<< do
         validateExtendedIdentityF . I.Identity <$>
             if isJust name || isJust extOwner
                then mstore =<< signOwner =<< sign secret =<<
@@ -245,7 +249,6 @@ createIdentity st name owner = do
                        , ideOwner = extOwner
                        }
                else return $ baseToExtended baseData
-    return identity
 
 validateIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity
 validateIdentity = validateIdentityF . I.Identity