summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2019-10-11 22:19:15 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2019-10-11 22:19:15 +0200
commit61b04eb5fda0d1e94f673ad1c11f328a318bb09d (patch)
treef9dc3edde8de7f50e17bcd0bcc3873f8cda6c89c /src/Main.hs
parent681c68ef5843c13df1a8e5da3540b2b00ba2eb03 (diff)
Identity merging and verification
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs31
1 files changed, 16 insertions, 15 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 4a6d3cd..1785581 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -28,7 +28,7 @@ import Storage
data Erebos = Erebos
- { erbIdentity :: Stored Identity
+ { erbIdentity :: Stored (Signed IdentityData)
, erbMessages :: StoredList DirectMessageThread
}
@@ -53,9 +53,10 @@ loadErebosHead st = loadHeadDef st "erebos" $ do
(devSecret, devPublic) <- generateKeys st
(_devSecretMsg, devPublicMsg) <- generateKeys st
- owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name }
- identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<<
- wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner }
+ 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
@@ -101,7 +102,7 @@ interactiveLoop :: Storage -> String -> IO ()
interactiveLoop st bhost = runInputT defaultSettings $ do
erebosHead <- liftIO $ loadErebosHead st
let serebos = wrappedLoad (headRef erebosHead) :: Stored Erebos
- self = erbIdentity $ fromStored serebos
+ Just self = verifyIdentity $ erbIdentity $ fromStored serebos
outputStrLn $ T.unpack $ displayIdentity self
haveTerminalUI >>= \case True -> return ()
@@ -109,7 +110,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
extPrint <- getExternalPrint
let extPrintLn str = extPrint $ str ++ "\n";
(chanPeer, chanSvc) <- liftIO $
- startServer extPrintLn bhost $ erbIdentity $ fromStored serebos
+ startServer extPrintLn bhost self
peers <- liftIO $ newMVar []
@@ -131,9 +132,9 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
msg = fromStored smsg
extPrintLn $ formatMessage tzone msg
if | Just powner <- finalOwner <$> peerIdentity peer
- , powner == msgFrom msg
+ , idData powner == msgFrom msg
-> updateErebosHead_ st $ \erb -> do
- slist <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
+ slist <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ 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
@@ -151,7 +152,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
let process cstate = do
let pname = case csPeer cstate of
Nothing -> ""
- Just peer -> maybe "<unnamed>" T.unpack $ idName . fromStored . signedData . fromStored . finalOwner <=< peerIdentity $ peer
+ 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
@@ -171,7 +172,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
data CommandInput = CommandInput
- { ciSelf :: Stored Identity
+ { ciSelf :: UnifiedIdentity
, ciLine :: String
, ciPeers :: CommandM [Peer]
}
@@ -207,13 +208,13 @@ cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index"
cmdSend :: Command
cmdSend = void $ runMaybeT $ do
self <- asks ciSelf
- let st = storedStorage self
+ let st = storedStorage $ idData self
Just peer <- gets csPeer
Just powner <- return $ finalOwner <$> peerIdentity peer
_:_ <- return $ peerChannels peer
text <- asks ciLine
smsg <- liftIO $ updateErebosHead st $ \erb -> do
- (slist, smsg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
+ (slist, smsg) <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
Just thread -> do
(smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text)
(,smsg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb)
@@ -230,13 +231,13 @@ cmdSend = void $ runMaybeT $ do
cmdHistory :: Command
cmdHistory = void $ runMaybeT $ do
self <- asks ciSelf
- let st = storedStorage self
+ let st = storedStorage $ idData self
Just peer <- gets csPeer
Just powner <- return $ finalOwner <$> peerIdentity peer
Just erebosHead <- liftIO $ loadHead st "erebos"
let erebos = wrappedLoad (headRef erebosHead)
- Just thread <- return $ find ((==powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos
+ Just thread <- return $ find ((== idData powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos
tzone <- liftIO $ getCurrentTimeZone
liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread
@@ -244,7 +245,7 @@ cmdHistory = void $ runMaybeT $ do
formatMessage :: TimeZone -> DirectMessage -> String
formatMessage tzone msg = concat
[ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
- , maybe "<unnamed>" T.unpack $ idName $ fromStored $ signedData $ fromStored $ msgFrom msg
+ , maybe "<unnamed>" T.unpack $ iddName $ fromStored $ signedData $ fromStored $ msgFrom msg
, ": "
, T.unpack $ msgText msg
]