diff options
Diffstat (limited to 'Role')
-rw-r--r-- | Role/Developer.hs | 108 | ||||
-rw-r--r-- | Role/Downloader.hs | 2 | ||||
-rw-r--r-- | Role/User.hs | 25 | ||||
-rw-r--r-- | Role/Watcher.hs | 2 |
4 files changed, 67 insertions, 70 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 diff --git a/Role/Downloader.hs b/Role/Downloader.hs index 094e7de..d013344 100644 --- a/Role/Downloader.hs +++ b/Role/Downloader.hs @@ -14,7 +14,7 @@ import Data.Time.Clock.POSIX run :: DownloadOpts -> IO () run = run' downloader . downloadUrl -downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO () downloader dsv _ichan ochan sid = do let logfile = sessionLogFile "." sid putStrLn $ "Starting download to " ++ logfile diff --git a/Role/User.hs b/Role/User.hs index 1e842d0..e999b1c 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -37,8 +37,7 @@ run os = fromMaybe (ExitFailure 101) <$> connect putStr "Connecting to debug-me server..." hFlush stdout usv <- newEmptyTMVarIO - let recentactivity = userStateRecentActivity usv - runClientApp $ clientApp (InitMode mempty) recentactivity User developerMessages $ \ochan ichan sid -> do + runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ochan ichan sid -> do let url = sessionIDUrl sid "localhost" 8081 putStrLn "" putStrLn "Others can connect to this session and help you debug by running:" @@ -89,14 +88,11 @@ data UserState = UserState } -- | RecentActivity that uses the UserState. -userStateRecentActivity :: TMVar (TVar UserState) -> RecentActivity -userStateRecentActivity usv = go =<< tryReadTMVar usv - where - go Nothing = noRecentActivity - go (Just us) = do - st <- readTVar us - let hs = mapMaybe loggedHash $ toList $ backLog st - return (sigVerifier st, hs) +userStateRecentActivity :: TVar UserState -> RecentActivity +userStateRecentActivity us = do + st <- readTVar us + let hs = mapMaybe loggedHash $ toList $ backLog st + return (sigVerifier st, hs) -- | Start by establishing our session key, and displaying the starttxt. startProtocol :: B.ByteString -> TMChan (Message Seen) -> Logger -> IO (TVar UserState) @@ -189,7 +185,7 @@ instance SendableToDeveloper ControlAction where -- | Read things to be entered from the TMChan, verify if they're legal, -- and send them to the Pty. Also handles control messages from the -- developer. -sendPtyInput :: TMChan (Message Entered) -> TMChan (Message Seen) -> TMChan ControlInput -> Pty -> TVar UserState -> Logger -> IO () +sendPtyInput :: TMChan (MissingHashes (Message Entered)) -> TMChan (Message Seen) -> TMChan ControlInput -> Pty -> TVar UserState -> Logger -> IO () sendPtyInput ichan ochan controlinput p us logger = go where go = do @@ -220,15 +216,16 @@ data Input -- signature of the message is only verified against the key in it), and -- make sure it's legal before returning it. If it's not legal, sends a -- Reject message. -getDeveloperMessage :: TMChan (Message Entered) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM (Maybe Input) +getDeveloperMessage :: TMChan (MissingHashes (Message Entered)) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM (Maybe Input) getDeveloperMessage ichan ochan us now = maybe (return Nothing) (\msg -> Just <$> getDeveloperMessage' msg ochan us now) =<< readTMChan ichan -getDeveloperMessage' :: Message Entered -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input -getDeveloperMessage' msg ochan us now = do +getDeveloperMessage' :: MissingHashes (Message Entered) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input +getDeveloperMessage' (MissingHashes wiremsg) ochan us now = do st <- readTVar us + Developer msg <- restoreHashes (userStateRecentActivity us) (MissingHashes (Developer wiremsg)) case msg of ControlMessage (Control (SessionKey spk) _) -> do let sigverifier = mkSigVerifier $ case spk of diff --git a/Role/Watcher.hs b/Role/Watcher.hs index 0867da1..8ed59d5 100644 --- a/Role/Watcher.hs +++ b/Role/Watcher.hs @@ -14,7 +14,7 @@ import Control.Concurrent.STM.TMChan run :: WatchOpts -> IO () run = run' watcher . watchUrl -watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO () watcher dsv _ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger -> inRawMode $ do sk <- genMySessionKey (st, startoutput) <- processSessionStart sk ochan logger dsv |