Shared state and identity update

4 files changed, 165 insertions, 65 deletions

diff --git a/erebos.cabal b/erebos.cabal
index 8e35452..fe60f87 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -23,9 +23,11 @@ executable erebos
                        Message,
                        Network,
                        PubKey,
+                       State,
                        Storage,
                        Storage.Internal
                        Storage.Key
+                       Util
 
   default-extensions:  FlexibleContexts,
                        FlexibleInstances,
diff --git a/src/Main.hs b/src/Main.hs
index 1785581..2a04796 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -12,68 +12,19 @@ import Data.Char
 import Data.List
 import Data.Maybe
 import qualified Data.Text as T
-import qualified Data.Text.IO as T
 import Data.Time.Format
 import Data.Time.LocalTime
 
 import System.Console.Haskeline
 import System.Environment
-import System.IO
 
 import Identity
 import Message
 import Network
 import PubKey
+import State
 import Storage
 
-
-data Erebos = Erebos
-    { erbIdentity :: Stored (Signed IdentityData)
-    , erbMessages :: StoredList DirectMessageThread
-    }
-
-instance Storable Erebos where
-    store' erb = storeRec $ do
-        storeRef "id" $ erbIdentity erb
-        storeZRef "dmsgs" $ erbMessages erb
-
-    load' = loadRec $ Erebos
-        <$> loadRef "id"
-        <*> loadZRef "dmsgs"
-
-
-loadErebosHead :: Storage -> IO Head
-loadErebosHead st = loadHeadDef st "erebos" $ do
-    putStr "Name: "
-    hFlush stdout
-    name <- T.getLine
-
-    (secret, public) <- generateKeys st
-    (_secretMsg, publicMsg) <- generateKeys st
-    (devSecret, devPublic) <- generateKeys st
-    (_devSecretMsg, devPublicMsg) <- generateKeys st
-
-    owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
-        { iddName = Just name, iddKeyMessage = Just publicMsg }
-    identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<< wrappedStore st (emptyIdentityData devPublic)
-        { iddOwner = Just owner, iddKeyMessage = Just devPublicMsg }
-
-    msgs <- emptySList st
-    return $ Erebos
-        { erbIdentity = identity
-        , erbMessages = msgs
-        }
-
-updateErebosHead_ :: Storage -> (Stored Erebos -> IO (Stored Erebos)) -> IO ()
-updateErebosHead_ st f = updateErebosHead st (fmap (,()) . f)
-
-updateErebosHead :: Storage -> (Stored Erebos -> IO (Stored Erebos, a)) -> IO a
-updateErebosHead st f = do
-    Just erebosHead <- loadHead st "erebos"
-    (erebos, x) <- f $ wrappedLoad (headRef erebosHead)
-    Right _ <- replaceHead erebos (Right erebosHead)
-    return x
-
 main :: IO ()
 main = do
     st <- liftIO $ openStorage "test"
@@ -95,14 +46,16 @@ main = do
                             BC.putStrLn $ showRef $ storedRef $ sigKey $ fromStored sig
                     _ -> error $ "unknown object type '" ++ objtype ++ "'"
 
+        ["update-identity"] -> updateIdentity st
+
         [bhost] -> interactiveLoop st bhost
         _       -> error "Expecting broadcast address"
 
 interactiveLoop :: Storage -> String -> IO ()
 interactiveLoop st bhost = runInputT defaultSettings $ do
-    erebosHead <- liftIO $ loadErebosHead st
-    let serebos = wrappedLoad (headRef erebosHead) :: Stored Erebos
-        Just self = verifyIdentity $ erbIdentity $ fromStored serebos
+    erebosHead <- liftIO $ loadLocalState st
+    let serebos = wrappedLoad (headRef erebosHead) :: Stored LocalState
+        Just self = verifyIdentity $ lsIdentity $ fromStored serebos
     outputStrLn $ T.unpack $ displayIdentity self
 
     haveTerminalUI >>= \case True -> return ()
@@ -133,12 +86,12 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
                 extPrintLn $ formatMessage tzone msg
                 if | Just powner <- finalOwner <$> peerIdentity peer
                    , idData powner == msgFrom msg
-                   -> updateErebosHead_ st $ \erb -> do
-                          slist <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
+                   -> updateLocalState_ st $ \erb -> do
+                          slist <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of
                                         Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) }
-                                                          slistReplaceS thread thread' $ erbMessages $ fromStored erb
-                                        Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ erbMessages $ fromStored erb
-                          wrappedStore st (fromStored erb) { erbMessages = slist }
+                                                          slistReplaceS thread thread' $ lsMessages $ fromStored erb
+                                        Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ lsMessages $ fromStored erb
+                          wrappedStore st (fromStored erb) { lsMessages = slist }
 
                    | otherwise -> extPrint $ "Owner mismatch"
             | otherwise -> extPrint $ "Unknown service: " ++ T.unpack svc
@@ -155,7 +108,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
                              Just peer -> maybe "<unnamed>" T.unpack $ idName . finalOwner <=< peerIdentity $ peer
             input <- getInputLines $ pname ++ "> "
             let (cmd, line) = case input of
-                    '/':rest -> let (scmd, args) = dropWhile isSpace <$> span isAlphaNum rest
+                    '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest
                                  in if all isDigit scmd
                                        then (cmdSetPeer $ read scmd, args)
                                        else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
@@ -189,6 +142,7 @@ commands =
     [ ("history", cmdHistory)
     , ("peers", cmdPeers)
     , ("send", cmdSend)
+    , ("update-identity", cmdUpdateIdentity)
     ]
 
 cmdUnknown :: String -> Command
@@ -213,15 +167,15 @@ cmdSend = void $ runMaybeT $ do
     Just powner <- return $ finalOwner <$> peerIdentity peer
     _:_ <- return $ peerChannels peer
     text <- asks ciLine
-    smsg <- liftIO $ updateErebosHead st $ \erb -> do
-        (slist, smsg) <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
+    smsg <- liftIO $ updateLocalState st $ \erb -> do
+        (slist, smsg) <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of
             Just thread -> do
                 (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text)
-                (,smsg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb)
+                (,smsg) <$> slistReplaceS thread thread' (lsMessages $ fromStored erb)
             Nothing -> do
                 (smsg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack text)
-                (,smsg) <$> slistAddS thread' (erbMessages $ fromStored erb)
-        erb' <- wrappedStore st (fromStored erb) { erbMessages = slist }
+                (,smsg) <$> slistAddS thread' (lsMessages $ fromStored erb)
+        erb' <- wrappedStore st (fromStored erb) { lsMessages = slist }
         return (erb', smsg)
     liftIO $ sendToPeer self peer (T.pack "dmsg") smsg
 
@@ -237,10 +191,15 @@ cmdHistory = void $ runMaybeT $ do
 
     Just erebosHead <- liftIO $ loadHead st "erebos"
     let erebos = wrappedLoad (headRef erebosHead)
-    Just thread <- return $ find ((== idData powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos
+    Just thread <- return $ find ((== idData powner) . msgPeer) $ fromSList $ lsMessages $ fromStored erebos
     tzone <- liftIO $ getCurrentTimeZone
     liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread
 
+cmdUpdateIdentity :: Command
+cmdUpdateIdentity = void $ runMaybeT $ do
+    st <- asks $ storedStorage . idData . ciSelf
+    liftIO $ updateIdentity st
+
 
 formatMessage :: TimeZone -> DirectMessage -> String
 formatMessage tzone msg = concat
diff --git a/src/State.hs b/src/State.hs
new file mode 100644
index 0000000..272044a
--- /dev/null
+++ b/src/State.hs
@@ -0,0 +1,133 @@
+module State (
+    LocalState(..),
+    SharedState(..),
+
+    loadLocalState,
+    updateLocalState, updateLocalState_,
+    updateIdentity,
+) where
+
+import Data.List
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+import System.IO
+
+import Identity
+import Message
+import PubKey
+import Storage
+import Util
+
+data LocalState = LocalState
+    { lsIdentity :: Stored (Signed IdentityData)
+    , lsShared :: [Stored SharedState]
+    , lsMessages :: StoredList DirectMessageThread -- TODO: move to shared
+    }
+
+data SharedState = SharedState
+    { ssPrev :: [Stored SharedState]
+    , ssIdentity :: [Stored (Signed IdentityData)]
+    }
+
+instance Storable LocalState where
+    store' st = storeRec $ do
+        storeRef "id" $ lsIdentity st
+        mapM_ (storeRef "shared") $ lsShared st
+        storeRef "dmsg" $ lsMessages st
+
+    load' = loadRec $ LocalState
+        <$> loadRef "id"
+        <*> loadRefs "shared"
+        <*> loadRef "dmsg"
+
+instance Storable SharedState where
+    store' st = storeRec $ do
+        mapM_ (storeRef "PREV") $ ssPrev st
+        mapM_ (storeRef "id") $ ssIdentity st
+
+    load' = loadRec $ SharedState
+        <$> loadRefs "PREV"
+        <*> loadRefs "id"
+
+
+loadLocalState :: Storage -> IO Head
+loadLocalState st = loadHeadDef st "erebos" $ do
+    putStr "Name: "
+    hFlush stdout
+    name <- T.getLine
+
+    (secret, public) <- generateKeys st
+    (_secretMsg, publicMsg) <- generateKeys st
+    (devSecret, devPublic) <- generateKeys st
+    (_devSecretMsg, devPublicMsg) <- generateKeys st
+
+    owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
+        { iddName = Just name, iddKeyMessage = Just publicMsg }
+    identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<< wrappedStore st (emptyIdentityData devPublic)
+        { iddOwner = Just owner, iddKeyMessage = Just devPublicMsg }
+
+    msgs <- emptySList st
+
+    shared <- wrappedStore st $ SharedState
+        { ssPrev = []
+        , ssIdentity = [owner]
+        }
+    return $ LocalState
+        { lsIdentity = identity
+        , lsShared = [shared]
+        , lsMessages = msgs
+        }
+
+updateLocalState_ :: Storage -> (Stored LocalState -> IO (Stored LocalState)) -> IO ()
+updateLocalState_ st f = updateLocalState st (fmap (,()) . f)
+
+updateLocalState :: Storage -> (Stored LocalState -> IO (Stored LocalState, a)) -> IO a
+updateLocalState ls f = do
+    Just erebosHead <- loadHead ls "erebos"
+    (st, x) <- f $ wrappedLoad (headRef erebosHead)
+    Right _ <- replaceHead st (Right erebosHead)
+    return x
+
+updateSharedState_ :: Storage -> (Stored SharedState -> IO (Stored SharedState)) -> IO ()
+updateSharedState_ st f = updateSharedState st (fmap (,()) . f)
+
+updateSharedState :: Storage -> (Stored SharedState -> IO (Stored SharedState, a)) -> IO a
+updateSharedState st f = updateLocalState st $ \ls -> do
+    (shared, x) <- f =<< mergeSharedStates (lsShared $ fromStored ls)
+    (,x) <$> wrappedStore st (fromStored ls) { lsShared = [shared] }
+
+mergeSharedStates :: [(Stored SharedState)] -> IO (Stored SharedState)
+mergeSharedStates [s] = return s
+mergeSharedStates ss@(s:_) = wrappedStore (storedStorage s) $ SharedState
+        { ssPrev = ss
+        , ssIdentity = uniq $ sort $ concatMap (ssIdentity . fromStored) $ ss -- TODO: ancestor elimination
+        }
+mergeSharedStates [] = error "mergeSharedStates: empty list"
+
+updateIdentity :: Storage -> IO ()
+updateIdentity st = updateSharedState_ st $ \sshared -> do
+    let shared = fromStored sshared
+        Just identity = verifyIdentityF $ ssIdentity shared
+        public = idKeyIdentity identity
+
+    T.putStr $ T.concat $ concat
+        [ [ T.pack "Name" ]
+        , case idName identity of
+               Just name -> [T.pack " [", name, T.pack "]"]
+               Nothing -> []
+        , [ T.pack ": " ]
+        ]
+    hFlush stdout
+    name <- T.getLine
+
+    identity' <- if
+        | T.null name -> idData <$> mergeIdentity identity
+        | otherwise -> do
+            Just secret <- loadKey public
+            wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
+                { iddPrev = ssIdentity shared
+                , iddName = Just name
+                }
+
+    wrappedStore st shared { ssIdentity = [identity'] }
diff --git a/src/Util.hs b/src/Util.hs
new file mode 100644
index 0000000..99d51f6
--- /dev/null
+++ b/src/Util.hs
@@ -0,0 +1,6 @@
+module Util where
+
+uniq :: Eq a => [a] -> [a]
+uniq (x:y:xs) | x == y    = uniq (x:xs)
+              | otherwise = x : uniq (y:xs)
+uniq xs = xs