diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 89 | ||||
| -rw-r--r-- | src/State.hs | 133 | ||||
| -rw-r--r-- | src/Util.hs | 6 |
3 files changed, 163 insertions, 65 deletions
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 |