diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 49 |
1 files changed, 26 insertions, 23 deletions
diff --git a/src/Main.hs b/src/Main.hs index 5ce9f86..1e8736b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -52,37 +52,38 @@ main = do forM_ (signedSignature signed) $ \sig -> do putStr $ "SIG " BC.putStrLn $ showRef $ storedRef $ sigKey $ fromStored sig - "identity" -> case verifyIdentity (wrappedLoad ref) of + "identity" -> case validateIdentity (wrappedLoad ref) of Just identity -> do - let disp idt = do + let disp :: Identity m -> IO () + disp idt = do maybe (return ()) (T.putStrLn . (T.pack "Name: " `T.append`)) $ idName idt BC.putStrLn . (BC.pack "KeyId: " `BC.append`) . showRefDigest . refDigest . storedRef $ idKeyIdentity idt BC.putStrLn . (BC.pack "KeyMsg: " `BC.append`) . showRefDigest . refDigest . storedRef $ idKeyMessage idt case idOwner idt of Nothing -> return () Just owner -> do - putStrLn $ "OWNER " ++ BC.unpack (showRefDigest $ refDigest $ storedRef $ idData owner) + mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idDataF owner disp owner disp identity Nothing -> putStrLn $ "Identity verification failed" _ -> error $ "unknown object type '" ++ objtype ++ "'" - ["update-identity"] -> updateIdentity st + ["update-identity"] -> updateSharedIdentity st [bhost] -> interactiveLoop st bhost _ -> error "Expecting broadcast address" interactiveLoop :: Storage -> String -> IO () interactiveLoop st bhost = runInputT defaultSettings $ do - erebosHead <- liftIO $ loadLocalState st - outputStrLn $ T.unpack $ maybe (error "failed to verify local identity") displayIdentity $ - verifyIdentity $ lsIdentity $ fromStored $ wrappedLoad $ headRef erebosHead + origIdentity <- liftIO $ loadLocalIdentity st + outputStrLn $ T.unpack $ displayIdentity origIdentity haveTerminalUI >>= \case True -> return () False -> error "Requires terminal" extPrint <- getExternalPrint let extPrintLn str = extPrint $ str ++ "\n"; - chanPeer <- liftIO $ + chanPeer <- liftIO $ do + erebosHead <- loadLocalStateHead st startServer erebosHead extPrintLn bhost [ (T.pack "attach", SomeService (emptyServiceState :: AttachService)) , (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService)) @@ -92,14 +93,15 @@ interactiveLoop st bhost = runInputT defaultSettings $ do void $ liftIO $ forkIO $ void $ forever $ do peer <- readChan chanPeer - let update [] = ([peer], Nothing) - update (p:ps) | peerIdentityRef p == peerIdentityRef peer = (peer : ps, Just p) - | otherwise = first (p:) $ update ps - if | PeerIdentityUnknown <- peerIdentity peer -> return () - | otherwise -> do + if | PeerIdentityFull pid <- peerIdentity peer -> do + let update [] = ([peer], Nothing) + update (p:ps) | PeerIdentityFull pid' <- peerIdentity p + , pid' `sameIdentity` pid = (peer : ps, Just p) + | otherwise = first (p:) $ update ps op <- modifyMVar peers (return . update) let shown = showPeer peer when (Just shown /= (showPeer <$> op)) $ extPrint shown + | otherwise -> return () let getInputLines prompt = do Just input <- lift $ getInputLine prompt @@ -111,8 +113,8 @@ interactiveLoop st bhost = runInputT defaultSettings $ do process cstate = do let pname = case csPeer cstate of Nothing -> "" - Just peer -> case peerOwner peer of - PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName pid + Just peer -> case peerIdentity peer of + PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid PeerIdentityRef wref -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">" PeerIdentityUnknown -> "<unknown>" input <- getInputLines $ pname ++ "> " @@ -122,10 +124,9 @@ interactiveLoop st bhost = runInputT defaultSettings $ do then (cmdSetPeer $ read scmd, args) else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args) _ -> (cmdSend, input) - curHead <- liftIO $ loadLocalState st + curIdentity <- liftIO $ loadLocalIdentity st res <- liftIO $ runExceptT $ flip execStateT cstate $ runReaderT cmd CommandInput - { ciSelf = fromMaybe (error "failed to verify local identity") $ - verifyIdentity $ lsIdentity $ fromStored $ wrappedLoad $ headRef curHead + { ciSelf = curIdentity , ciLine = line , ciPrint = extPrintLn , ciPeers = liftIO $ readMVar peers @@ -200,10 +201,11 @@ cmdSend = void $ do self <- asks ciSelf let st = storedStorage $ idData self Just peer <- gets csPeer - PeerIdentityFull powner <- return $ peerOwner peer + PeerIdentityFull pid <- return $ peerIdentity peer + let powner = finalOwner pid :: ComposedIdentity text <- asks ciLine smsg <- liftIO $ updateLocalState st $ \erb -> do - (slist, smsg) <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of + (slist, smsg) <- case find (sameIdentity powner . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of Just thread -> do (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text) (,smsg) <$> slistReplaceS thread thread' (lsMessages $ fromStored erb) @@ -222,18 +224,19 @@ cmdHistory = void $ do self <- asks ciSelf let st = storedStorage $ idData self Just peer <- gets csPeer - PeerIdentityFull powner <- return $ peerOwner peer + PeerIdentityFull pid <- return $ peerIdentity peer + let powner = finalOwner pid Just erebosHead <- liftIO $ loadHead st "erebos" let erebos = wrappedLoad (headRef erebosHead) - Just thread <- return $ find ((== idData powner) . msgPeer) $ fromSList $ lsMessages $ fromStored erebos + Just thread <- return $ find (sameIdentity powner . msgPeer) $ fromSList $ lsMessages $ fromStored erebos tzone <- liftIO $ getCurrentTimeZone liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do st <- asks $ storedStorage . idData . ciSelf - liftIO $ updateIdentity st + liftIO $ updateSharedIdentity st cmdAttach :: Command cmdAttach = join $ attachToOwner |