From 1aef7681082e411c135802881ebcd3ffd0168fcd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 12 Oct 2019 21:42:49 +0200
Subject: Shared state and identity update
---
src/Main.hs | 89 +++++++++++----------------------------
src/State.hs | 133 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Util.hs | 6 +++
3 files changed, 163 insertions(+), 65 deletions(-)
create mode 100644 src/State.hs
create mode 100644 src/Util.hs
(limited to 'src')
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
--
cgit v1.2.3