diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Main.hs | 29 | ||||
| -rw-r--r-- | main/State.hs | 80 | ||||
| -rw-r--r-- | main/Terminal.hs | 4 |
3 files changed, 102 insertions, 11 deletions
diff --git a/main/Main.hs b/main/Main.hs index 9ea09e5..93ecbb5 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -57,6 +57,7 @@ import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync +import State import Terminal import Test import Version @@ -235,17 +236,20 @@ main = do Nothing -> error "ref does not exist" Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object) - ["update-identity"] -> either (fail . showErebosError) return <=< runExceptT $ do - runReaderT updateSharedIdentity =<< loadLocalStateHead st + ["update-identity"] -> do + withTerminal noCompletion $ \term -> do + either (fail . showErebosError) return <=< runExceptT $ do + runReaderT (updateSharedIdentity term) =<< loadLocalStateHead term st ("update-identity" : srefs) -> do - sequence <$> mapM (readRef st . BC.pack) srefs >>= \case - Nothing -> error "ref does not exist" - Just refs - | Just idt <- validateIdentityF $ map wrappedLoad refs -> do - BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< - (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate idt) st) - | otherwise -> error "invalid identity" + withTerminal noCompletion $ \term -> do + sequence <$> mapM (readRef st . BC.pack) srefs >>= \case + Nothing -> error "ref does not exist" + Just refs + | Just idt <- validateIdentityF $ map wrappedLoad refs -> do + BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< + (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st) + | otherwise -> error "invalid identity" ["test"] -> runTestTool st @@ -277,7 +281,7 @@ main = do interactiveLoop :: Storage -> Options -> IO () interactiveLoop st opts = withTerminal commandCompletion $ \term -> do - erebosHead <- liftIO $ loadLocalStateHead st + erebosHead <- liftIO $ loadLocalStateHead term st void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead let tui = hasTerminalUI term @@ -392,6 +396,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do mzero res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput { ciServer = server + , ciTerminal = term , ciLine = line , ciPrint = extPrintLn , ciOptions = opts @@ -427,6 +432,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do data CommandInput = CommandInput { ciServer :: Server + , ciTerminal :: Terminal , ciLine :: String , ciPrint :: String -> IO () , ciOptions :: Options @@ -662,7 +668,8 @@ cmdHistory = void $ do cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do - runReaderT updateSharedIdentity =<< gets csHead + term <- asks ciTerminal + runReaderT (updateSharedIdentity term) =<< gets csHead cmdAttach :: Command cmdAttach = attachToOwner =<< getSelectedPeer diff --git a/main/State.hs b/main/State.hs new file mode 100644 index 0000000..76441df --- /dev/null +++ b/main/State.hs @@ -0,0 +1,80 @@ +module State ( + loadLocalStateHead, + updateSharedIdentity, + interactiveIdentityUpdate, +) where + +import Control.Monad.Except +import Control.Monad.IO.Class + +import Data.Foldable +import Data.Maybe +import Data.Proxy +import Data.Text qualified as T + +import Erebos.Error +import Erebos.Identity +import Erebos.PubKey +import Erebos.State +import Erebos.Storable +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 + + setPrompt term "Device: " + devName <- getInputLine term $ KeepPrompt . maybe T.empty T.pack + + owner <- if + | T.null name -> return Nothing + | otherwise -> Just <$> createIdentity st (Just name) Nothing + + identity <- createIdentity st (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 ] + } + storeHead st $ LocalState + { lsIdentity = idExtData identity + , lsShared = [ shared ] + , lsOther = [] + } + + +updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m () +updateSharedIdentity term = updateLocalHead_ $ updateSharedState_ $ \case + Just identity -> do + Just . toComposedIdentity <$> interactiveIdentityUpdate term identity + 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 + + name <- liftIO $ do + setPrompt term $ T.unpack $ T.concat $ concat + [ [ T.pack "Name" ] + , case idName identity of + Just name -> [T.pack " [", name, T.pack "]"] + Nothing -> [] + , [ T.pack ": " ] + ] + getInputLine term $ KeepPrompt . maybe T.empty T.pack + + if | T.null name -> mergeIdentity 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 + } diff --git a/main/Terminal.hs b/main/Terminal.hs index 21bbf4b..7767122 100644 --- a/main/Terminal.hs +++ b/main/Terminal.hs @@ -13,6 +13,7 @@ module Terminal ( clearBottomLines, CompletionFunc, Completion, + noCompletion, simpleCompletion, completeWordWithPrev, ) where @@ -288,6 +289,9 @@ type CompletionFunc m = ( String, String ) -> m ( String, [ Completion ] ) data Completion +noCompletion :: Monad m => CompletionFunc m +noCompletion ( l, _ ) = return ( l, [] ) + completeWordWithPrev :: Maybe Char -> [ Char ] -> (String -> String -> m [ Completion ]) -> CompletionFunc m completeWordWithPrev = error "TODO" |