diff options
| -rw-r--r-- | erebos.cabal | 1 | ||||
| -rw-r--r-- | main/Main.hs | 29 | ||||
| -rw-r--r-- | main/State.hs | 80 | ||||
| -rw-r--r-- | main/Terminal.hs | 4 | ||||
| -rw-r--r-- | src/Erebos/State.hs | 72 |
5 files changed, 105 insertions, 81 deletions
diff --git a/erebos.cabal b/erebos.cabal index e704a3f..27716fa 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -185,6 +185,7 @@ executable erebos main-is: Main.hs other-modules: Paths_erebos + State Terminal Test Test.Service 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" diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs index f0af8a0..a2ecb9e 100644 --- a/src/Erebos/State.hs +++ b/src/Erebos/State.hs @@ -1,13 +1,12 @@ module Erebos.State ( LocalState(..), - SharedState, SharedType(..), + SharedState(..), SharedType(..), SharedTypeID, mkSharedTypeID, + MonadStorage(..), MonadHead(..), updateLocalHead_, - loadLocalStateHead, - updateSharedState, updateSharedState_, lookupSharedValue, makeSharedStateUpdate, @@ -15,8 +14,6 @@ module Erebos.State ( headLocalIdentity, mergeSharedIdentity, - updateSharedIdentity, - interactiveIdentityUpdate, ) where import Control.Monad.Except @@ -24,16 +21,10 @@ import Control.Monad.Reader import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC -import Data.Foldable -import Data.Maybe -import Data.Text qualified as T -import Data.Text.IO qualified as T import Data.Typeable import Data.UUID (UUID) import Data.UUID qualified as U -import System.IO - import Erebos.Identity import Erebos.Object import Erebos.PubKey @@ -106,35 +97,6 @@ instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where snd <$> updateHead h f -loadLocalStateHead :: MonadIO m => Storage -> m (Head LocalState) -loadLocalStateHead st = loadHeads st >>= \case - (h:_) -> return h - [] -> liftIO $ do - putStr "Name: " - hFlush stdout - name <- T.getLine - - putStr "Device: " - hFlush stdout - devName <- T.getLine - - 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 = [] - } - localIdentity :: LocalState -> UnifiedIdentity localIdentity ls = maybe (error "failed to verify local identity") (updateOwners $ maybe [] idExtDataF $ lookupSharedValue $ lsShared ls) @@ -178,33 +140,3 @@ mergeSharedIdentity = updateLocalHead $ updateSharedState $ \case identity <- mergeIdentity cidentity return (Just $ toComposedIdentity identity, identity) Nothing -> throwOtherError "no existing shared identity" - -updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => m () -updateSharedIdentity = updateLocalHead_ $ updateSharedState_ $ \case - Just identity -> do - Just . toComposedIdentity <$> interactiveIdentityUpdate identity - Nothing -> throwOtherError "no existing shared identity" - -interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => Identity f -> m UnifiedIdentity -interactiveIdentityUpdate identity = do - let public = idKeyIdentity identity - - name <- liftIO $ do - T.putStr $ T.concat $ concat - [ [ T.pack "Name" ] - , case idName identity of - Just name -> [T.pack " [", name, T.pack "]"] - Nothing -> [] - , [ T.pack ": " ] - ] - hFlush stdout - T.getLine - - 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 - } |