From 6591e2b974ac22cbc2a06141edef76a775726e11 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 26 Apr 2017 14:23:37 -0400 Subject: have server relay Devloper messages to other Developers --- Role/Developer.hs | 69 ++++++++++++++++++++++++++++-------------------------- Role/Downloader.hs | 8 +++---- Role/Watcher.hs | 6 ++--- 3 files changed, 43 insertions(+), 40 deletions(-) (limited to 'Role') diff --git a/Role/Developer.hs b/Role/Developer.hs index 1cc5a10..d6cbf2b 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -24,17 +24,13 @@ import Control.Monad run :: DeveloperOpts -> IO () run = run' developer . debugUrl -run' :: (TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO ()) -> UrlString -> IO () +run' :: (TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO ()) -> UrlString -> IO () run' runner url = void $ runClientApp app where connect = ConnectMode (T.pack url) - app = clientApp connect Developer userMessages runner + app = clientApp connect Developer Just runner -userMessages :: LogMessage -> Maybe (Message Seen) -userMessages (User m) = Just m -userMessages (Developer _) = Nothing - -developer :: TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO () +developer :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO () developer ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do (devstate, startoutput) <- processSessionStart ochan logger emitOutput startoutput @@ -90,22 +86,22 @@ sendTtyInput ichan devstate logger = go go -- | Read activity from the TMChan and display it to the developer. -sendTtyOutput :: TMChan (Message Seen) -> TVar DeveloperState -> Logger -> IO () +sendTtyOutput :: TMChan LogMessage -> TVar DeveloperState -> Logger -> IO () sendTtyOutput ochan devstate logger = go where go = do - v <- atomically $ getUserMessage ochan devstate + v <- atomically $ getServerMessage ochan devstate case v of Nothing -> return () - Just (o, msg) -> do - logger $ User msg + Just (o, l) -> do + logger l emitOutput o go -- | Present our session key to the user. -- Wait for them to accept or reject it, while displaying any Seen data -- in the meantime. -authUser :: TMChan (Message Entered) -> TMChan (Message Seen) -> TVar DeveloperState -> Logger -> IO Bool +authUser :: TMChan (Message Entered) -> TMChan LogMessage -> TVar DeveloperState -> Logger -> IO Bool authUser ichan ochan devstate logger = do ds <- atomically $ readTVar devstate pk <- myPublicKey (developerSessionKey ds) @@ -117,8 +113,8 @@ authUser ichan ochan devstate logger = do where waitresp pk = do (o, msg) <- fromMaybe (error "Looks like that debug-me session is over.") - <$> atomically (getUserMessage ochan devstate) - logger $ User msg + <$> atomically (getServerMessage ochan devstate) + logger msg emitOutput o case o of GotControl (SessionKeyAccepted pk') @@ -132,6 +128,7 @@ data Output | Beep | ProtocolError String | GotControl ControlAction + | NoOutput emitOutput :: Output -> IO () emitOutput (ProtocolError e) = @@ -144,31 +141,37 @@ emitOutput Beep = do hFlush stdout emitOutput (GotControl _) = return () +emitOutput NoOutput = + return () --- | Get messages from user, check their signature, and make sure that they +-- | Get messages from server, check their signature, and make sure that they -- are properly chained from past messages, before returning. -getUserMessage :: TMChan (Message Seen) -> TVar DeveloperState -> STM (Maybe (Output, Message Seen)) -getUserMessage ochan devstate = do +getServerMessage :: TMChan LogMessage -> TVar DeveloperState -> STM (Maybe (Output, LogMessage)) +getServerMessage ochan devstate = do mmsg <- readTMChan ochan case mmsg of Nothing -> return Nothing - Just msg -> do + Just (User msg) -> do ds <- readTVar devstate - -- Check signature before doing anything else. + -- Check user's signature before doing anything else. if verifySigned (developerSigVerifier ds) msg then do - o <- process ds msg - return (Just (o, msg)) - else getUserMessage ochan devstate + o <- processuser ds msg + return (Just (o, User msg)) + else getServerMessage ochan devstate + Just (Developer msg) -> do + -- Not bothering to check signatures of messages + -- from other developers. XXX + return (Just (NoOutput, Developer msg)) where - process ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do + processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do let (legal, ds') = isLegalSeen act ds if legal then do writeTVar devstate ds' return (TtyOutput b) else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act)) - process ds (ControlMessage (Control (Rejected _) _)) = do + processuser ds (ControlMessage (Control (Rejected _) _)) = do -- When they rejected a message we sent, -- anything we sent subsequently will -- also be rejected, so forget about it. @@ -178,11 +181,11 @@ getUserMessage ochan devstate = do } writeTVar devstate ds' return Beep - process _ (ControlMessage (Control c@(SessionKey _) _)) = + processuser _ (ControlMessage (Control c@(SessionKey _) _)) = return (GotControl c) - process _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) = + processuser _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) = return (GotControl c) - process _ (ControlMessage (Control c@(SessionKeyRejected _) _)) = + processuser _ (ControlMessage (Control c@(SessionKeyRejected _) _)) = return (GotControl c) -- | Check if the Seen activity is legal, forming a chain with previous @@ -230,15 +233,15 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds acth = hash act yes ds' = (True, ds') --- | Start by reading the initial two messages from the user side, +-- | Start by reading the initial two messages from the user, -- their session key and the startup message. -processSessionStart :: TMChan (Message Seen) -> Logger -> IO (TVar DeveloperState, Output) +processSessionStart :: TMChan LogMessage -> Logger -> IO (TVar DeveloperState, Output) processSessionStart ochan logger = do sessionmsg <- fromMaybe (error "Did not get session initialization message") <$> atomically (readTMChan ochan) - logger $ User sessionmsg + logger sessionmsg sigverifier <- case sessionmsg of - ControlMessage c@(Control (SessionKey pk) _) -> + User (ControlMessage c@(Control (SessionKey pk) _)) -> let sv = mkSigVerifier pk in if verifySigned sv c then return sv @@ -246,9 +249,9 @@ processSessionStart ochan logger = do _ -> error $ "Unexpected session initialization message: " ++ show sessionmsg startmsg <- fromMaybe (error "Did not get session startup message") <$> atomically (readTMChan ochan) - logger $ User startmsg + logger startmsg let (starthash, output) = case startmsg of - ActivityMessage act@(Activity (Seen (Val b)) Nothing _) + User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _)) | verifySigned sigverifier act -> (hash act, TtyOutput b) _ -> error $ "Unexpected startup message: " ++ show startmsg diff --git a/Role/Downloader.hs b/Role/Downloader.hs index ede11a7..07148e8 100644 --- a/Role/Downloader.hs +++ b/Role/Downloader.hs @@ -7,12 +7,12 @@ import SessionID import Control.Concurrent.STM import Control.Concurrent.STM.TMChan -import Role.Developer (run', processSessionStart, getUserMessage, Output(..)) +import Role.Developer (run', processSessionStart, getServerMessage, Output(..)) run :: DownloadOpts -> IO () run = run' downloader . downloadUrl -downloader :: TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO () +downloader :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO () downloader _ichan ochan sid = do let logfile = sessionLogFile "." sid putStrLn $ "Starting download to " ++ logfile @@ -22,11 +22,11 @@ downloader _ichan ochan sid = do go logger st where go logger st = do - v <- atomically $ getUserMessage ochan st + v <- atomically $ getServerMessage ochan st case v of Nothing -> return () Just (o, msg) -> do - _ <- logger $ User msg + _ <- logger msg case o of ProtocolError e -> error ("Protocol error: " ++ e) _ -> go logger st diff --git a/Role/Watcher.hs b/Role/Watcher.hs index ddffa79..c13234f 100644 --- a/Role/Watcher.hs +++ b/Role/Watcher.hs @@ -8,19 +8,19 @@ import SessionID import Control.Concurrent.STM import Control.Concurrent.STM.TMChan -import Role.Developer (run', processSessionStart, getUserMessage, emitOutput) +import Role.Developer (run', processSessionStart, getServerMessage, emitOutput) run :: WatchOpts -> IO () run = run' watcher . watchUrl -watcher :: TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO () +watcher :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO () watcher _ichan ochan _ = inRawMode $ do (st, startoutput) <- processSessionStart ochan nullLogger emitOutput startoutput go st where go st = do - v <- atomically $ getUserMessage ochan st + v <- atomically $ getServerMessage ochan st case v of Nothing -> return () Just (o, _msg) -> do -- cgit v1.2.3