diff options
Diffstat (limited to 'Role/Developer.hs')
-rw-r--r-- | Role/Developer.hs | 108 |
1 files changed, 54 insertions, 54 deletions
diff --git a/Role/Developer.hs b/Role/Developer.hs index 56af3b4..6763e1a 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -40,17 +40,15 @@ import Network.URI run :: DeveloperOpts -> IO () run = run' developer . debugUrl -run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> URI -> IO () +run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO ()) -> URI -> IO () run' runner url = do app <- do let connect = ConnectMode $ T.pack $ show url dsv <- newEmptyTMVarIO - let recentactivity = developerStateRecentActivity dsv - return $ clientApp connect recentactivity Developer Just $ - runner dsv + return $ clientApp connect Developer Just $ runner dsv void $ runClientApp app -developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO () developer dsv ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger -> do sk <- genMySessionKey (controlinput, controloutput) <- openControlWindow @@ -82,7 +80,7 @@ developer dsv ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger go _ _ _ _ SessionEnded = hPutStrLn stderr "\r\n** This debug-me session has already ended.\r" -watchSessionReadOnly :: TMChan AnyMessage -> Logger -> TVar DeveloperState -> IO () +watchSessionReadOnly :: TMChan (MissingHashes AnyMessage) -> Logger -> TVar DeveloperState -> IO () watchSessionReadOnly ochan logger st = loop where loop = do @@ -118,14 +116,11 @@ data DeveloperState = DeveloperState deriving (Show) -- | RecentActivity that uses the DeveloperState. -developerStateRecentActivity :: TMVar (TVar DeveloperState) -> RecentActivity -developerStateRecentActivity dsv = go =<< tryReadTMVar dsv - where - go Nothing = noRecentActivity - go (Just ds) = do - st <- readTVar ds - let hs = lastSeen st : enteredSince st ++ fromOtherDevelopersSince st - return (userSigVerifier st <> developerSigVerifier st, hs) +developerStateRecentActivity :: TVar DeveloperState -> RecentActivity +developerStateRecentActivity devstate = do + st <- readTVar devstate + let hs = lastSeen st : enteredSince st ++ fromOtherDevelopersSince st + return (userSigVerifier st <> developerSigVerifier st, hs) -- | Read things typed by the developer, and forward them to the TMChan. sendTtyInput :: TMChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () @@ -185,7 +180,7 @@ sendControlOutput controloutput ichan devstate logger = loop -- | Read activity from the TMChan and display it to the developer. -- -- Control messages are forwarded on to the ControlInput. -sendTtyOutput :: TMChan AnyMessage -> TVar DeveloperState -> TMChan ControlInput -> Logger -> IO () +sendTtyOutput :: TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> TMChan ControlInput -> Logger -> IO () sendTtyOutput ochan devstate controlinput logger = go where go = do @@ -214,7 +209,7 @@ data AuthResult = Authed | AuthFailed | SessionEnded -- | Present our session key to the user. -- Wait for them to accept or reject it, while displaying any Seen data -- in the meantime. -authUser :: PerhapsSigned PublicKey -> TMChan (Message Entered) -> TMChan AnyMessage -> TVar DeveloperState -> Logger -> IO AuthResult +authUser :: PerhapsSigned PublicKey -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> Logger -> IO AuthResult authUser spk ichan ochan devstate logger = do ds <- atomically $ readTVar devstate let msg = ControlMessage $ mkSigned (developerSessionKey ds) @@ -263,44 +258,49 @@ emitOutput NoOutput = -- | Get messages from server, check their signature, and make sure that they -- are properly chained from past messages, before returning. -getServerMessage :: TMChan AnyMessage -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, AnyMessage)) +getServerMessage :: TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, AnyMessage)) getServerMessage ochan devstate ts = do - let ignore = getServerMessage ochan devstate ts - mmsg <- readTMChan ochan - case mmsg of + mwiremsg <- readTMChan ochan + case mwiremsg of Nothing -> return Nothing - Just (User msg) -> do - ds <- readTVar devstate - -- Check user's signature before doing anything else. - if verifySigned (userSigVerifier ds) msg - then do - o <- processuser ds msg - return (Just (o, User msg)) - else return $ Just (ProtocolError ds $ "Bad signature on message from user: " ++ show msg, User msg) - -- When other developers connect, learn their SessionKeys. - Just (Developer msg@(ControlMessage (Control (SessionKey spk) _))) -> do - let sigverifier = mkSigVerifier $ case spk of - GpgSigned pk _ -> pk - UnSigned pk -> pk - if verifySigned sigverifier msg - then do - ds <- readTVar devstate - let sv = developerSigVerifier ds - let sv' = sv `mappend` sigverifier - writeTVar devstate $ ds - { developerSigVerifier = sv' - } - processdeveloper ds msg - return (Just (NoOutput, Developer msg)) - else ignore - Just (Developer msg) -> do - ds <- readTVar devstate - if verifySigned (developerSigVerifier ds) msg - then do - processdeveloper ds msg - return (Just (NoOutput, Developer msg)) - else ignore + Just msg -> process =<< restoreHashes recentactivity msg where + recentactivity = developerStateRecentActivity devstate + + process (User msg) = do + ds <- readTVar devstate + -- Check user's signature before doing anything else. + if verifySigned (userSigVerifier ds) msg + then do + o <- processuser ds msg + return (Just (o, User msg)) + else return $ Just (ProtocolError ds $ "Bad signature on message from user: " ++ show msg, User msg) + -- When other developers connect, learn their SessionKeys. + process (Developer msg@(ControlMessage (Control (SessionKey spk) _))) = do + let sigverifier = mkSigVerifier $ case spk of + GpgSigned pk _ -> pk + UnSigned pk -> pk + if verifySigned sigverifier msg + then do + ds <- readTVar devstate + let sv = developerSigVerifier ds + let sv' = sv `mappend` sigverifier + writeTVar devstate $ ds + { developerSigVerifier = sv' + } + processdeveloper ds msg + return (Just (NoOutput, Developer msg)) + else ignore + process (Developer msg) = do + ds <- readTVar devstate + if verifySigned (developerSigVerifier ds) msg + then do + processdeveloper ds msg + return (Just (NoOutput, Developer msg)) + else ignore + + ignore = getServerMessage ochan devstate ts + processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _ _)) = do let (legal, ds') = isLegalSeen act ds ts if legal @@ -385,9 +385,9 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _) ds ts -- | Start by reading the initial two messages from the user, -- their session key and the startup message. -processSessionStart :: MySessionKey -> TMChan AnyMessage -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output) +processSessionStart :: MySessionKey -> TMChan (MissingHashes AnyMessage) -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output) processSessionStart sk ochan logger dsv = do - sessionmsg <- fromMaybe (error "Did not get session initialization message") + MissingHashes sessionmsg <- fromMaybe (error "Did not get session initialization message") <$> atomically (readTMChan ochan) logger sessionmsg sigverifier <- case sessionmsg of @@ -413,7 +413,7 @@ processSessionStart sk ochan logger dsv = do , developerSigVerifier = mempty } atomically $ putTMVar dsv st - startmsg <- fromMaybe (error "Did not get session startup message") + MissingHashes startmsg <- fromMaybe (error "Did not get session startup message") <$> atomically (readTMChan ochan) logger startmsg let (starthash, output) = case startmsg of |