diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Main.hs | 12 | ||||
| -rw-r--r-- | main/State.hs | 42 | ||||
| -rw-r--r-- | main/Test.hs | 9 |
3 files changed, 35 insertions, 28 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 ] |