From cbdbc0a176736b3be970f263f2319a0f6bd123bd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Tue, 5 Aug 2025 21:28:55 +0200
Subject: Use MonadStorage for createIdentity

Changelog: API: `Identity.createIdentity` uses `MonadStorage`
---
 main/State.hs | 42 +++++++++++++++++++++++++-----------------
 1 file changed, 25 insertions(+), 17 deletions(-)

(limited to 'main/State.hs')

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 ()
-- 
cgit v1.2.3