Adapt interactive identity updates for Terminal

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"