diff options
Diffstat (limited to 'Role')
| -rw-r--r-- | Role/Developer.hs | 71 | ||||
| -rw-r--r-- | Role/Downloader.hs | 8 | ||||
| -rw-r--r-- | Role/User.hs | 20 | ||||
| -rw-r--r-- | Role/Watcher.hs | 8 |
4 files changed, 75 insertions, 32 deletions
diff --git a/Role/Developer.hs b/Role/Developer.hs index b0d66a5..9e1f40e 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -1,6 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -module Role.Developer where +module Role.Developer ( + run, + run', + processSessionStart, + getServerMessage, + Output(..), + emitOutput, + DeveloperState, +) where import Types import Hash @@ -10,6 +18,7 @@ import CmdLine import WebSockets import SessionID import Pty +import PrevActivity import Control.Concurrent.Async import Control.Concurrent.STM @@ -20,20 +29,25 @@ import qualified Data.Text as T import Data.List import Data.Maybe import Control.Monad +import Data.Monoid import Data.Time.Clock.POSIX run :: DeveloperOpts -> IO () run = run' developer . debugUrl -run' :: (TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> UrlString -> IO () -run' runner url = void $ runClientApp app - where - connect = ConnectMode (T.pack url) - app = clientApp connect Developer Just runner +run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> UrlString -> IO () +run' runner url = do + app <- do + let connect = ConnectMode (T.pack url) + dsv <- newEmptyTMVarIO + let recentactivity = developerStateRecentActivity dsv + return $ clientApp connect recentactivity Developer Just $ + runner dsv + void $ runClientApp app -developer :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () -developer ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do - (devstate, startoutput) <- processSessionStart ochan logger +developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +developer dsv ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do + (devstate, startoutput) <- processSessionStart ochan logger dsv emitOutput startoutput ok <- authUser ichan ochan devstate logger if ok @@ -63,6 +77,16 @@ data DeveloperState = DeveloperState -- ^ Used to verify signatures on messages from other developers. } +-- | 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) + -- | Read things typed by the developer, and forward them to the TMChan. sendTtyInput :: TMChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () sendTtyInput ichan devstate logger = go @@ -287,8 +311,8 @@ 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 :: TMChan AnyMessage -> Logger -> IO (TVar DeveloperState, Output) -processSessionStart ochan logger = do +processSessionStart :: TMChan AnyMessage -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output) +processSessionStart ochan logger dsv = do sessionmsg <- fromMaybe (error "Did not get session initialization message") <$> atomically (readTMChan ochan) logger sessionmsg @@ -302,25 +326,30 @@ processSessionStart ochan logger = do then return sv else error "Badly signed session initialization message" _ -> error $ "Unexpected session initialization message: " ++ show sessionmsg - startmsg <- fromMaybe (error "Did not get session startup message") - <$> atomically (readTMChan ochan) - logger startmsg - let (starthash, output) = case startmsg of - User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _ _)) - | verifySigned sigverifier act -> - (hash act, TtyOutput b) - _ -> error $ "Unexpected startup message: " ++ show startmsg sk <- genMySessionKey ts <- getPOSIXTime st <- newTVarIO $ DeveloperState - { lastSeen = starthash + { lastSeen = hash () , sentSince = mempty , enteredSince = mempty - , lastActivity = starthash + , lastActivity = hash () , lastActivityTs = ts , fromOtherDevelopersSince = mempty , developerSessionKey = sk , userSigVerifier = sigverifier , developerSigVerifier = mempty } + atomically $ putTMVar dsv st + startmsg <- fromMaybe (error "Did not get session startup message") + <$> atomically (readTMChan ochan) + logger startmsg + let (starthash, output) = case startmsg of + User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _ _)) + | verifySigned sigverifier act -> + (hash act, TtyOutput b) + _ -> error $ "Unexpected startup message: " ++ show startmsg + atomically $ modifyTVar' st $ \ds -> ds + { lastSeen = starthash + , lastActivity = starthash + } return (st, output) diff --git a/Role/Downloader.hs b/Role/Downloader.hs index d49b4ec..4d5f6cc 100644 --- a/Role/Downloader.hs +++ b/Role/Downloader.hs @@ -4,7 +4,7 @@ import Types import Log import CmdLine import SessionID -import Role.Developer (run', processSessionStart, getServerMessage, Output(..)) +import Role.Developer import Control.Concurrent.STM import Control.Concurrent.STM.TMChan @@ -13,13 +13,13 @@ import Data.Time.Clock.POSIX run :: DownloadOpts -> IO () run = run' downloader . downloadUrl -downloader :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () -downloader _ichan ochan sid = do +downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +downloader dsv _ichan ochan sid = do let logfile = sessionLogFile "." sid putStrLn $ "Starting download to " ++ logfile putStrLn "(Will keep downloading until the debug-me session is done.)" withLogger logfile $ \logger -> do - (st, _startoutput) <- processSessionStart ochan logger + (st, _startoutput) <- processSessionStart ochan logger dsv go logger st where go logger st = do diff --git a/Role/User.hs b/Role/User.hs index e0599a8..fe679a5 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -11,6 +11,7 @@ import Crypto import CmdLine import WebSockets import SessionID +import PrevActivity import Control.Concurrent.Async import Control.Concurrent.STM @@ -31,17 +32,20 @@ run os = fromMaybe (ExitFailure 101) <$> connect connect = do putStr "Connecting to debug-me server..." hFlush stdout - runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ochan ichan sid -> do + usv <- newEmptyTMVarIO + let recentactivity = userStateRecentActivity usv + runClientApp $ clientApp (InitMode mempty) recentactivity 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:" putStrLn $ " debug-me --debug " ++ url hFlush stdout - withLogger "debug-me.log" $ go ochan ichan - go ochan ichan logger = do + withLogger "debug-me.log" $ go ochan ichan usv + go ochan ichan usv logger = do (cmd, cmdparams) <- shellCommand os runWithPty cmd cmdparams $ \(p, ph) -> do us <- startProtocol startSession ochan logger + atomically $ putTMVar usv us p1 <- async $ sendPtyOutput p ochan us logger p2 <- async $ sendPtyInput ichan ochan p us logger `race` forwardTtyInputToPty p @@ -73,6 +77,16 @@ data UserState = UserState , lastSeenTs :: POSIXTime } +-- | 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) + -- | Start by establishing our session key, and displaying the starttxt. startProtocol :: B.ByteString -> TMChan (Message Seen) -> Logger -> IO (TVar UserState) startProtocol starttxt ochan logger = do diff --git a/Role/Watcher.hs b/Role/Watcher.hs index 8bcc91c..a4328f8 100644 --- a/Role/Watcher.hs +++ b/Role/Watcher.hs @@ -5,7 +5,7 @@ import Log import Pty import CmdLine import SessionID -import Role.Developer (run', processSessionStart, getServerMessage, emitOutput) +import Role.Developer import Control.Concurrent.STM import Control.Concurrent.STM.TMChan @@ -14,9 +14,9 @@ import Data.Time.Clock.POSIX run :: WatchOpts -> IO () run = run' watcher . watchUrl -watcher :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () -watcher _ichan ochan _ = inRawMode $ do - (st, startoutput) <- processSessionStart ochan nullLogger +watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +watcher dsv _ichan ochan _ = inRawMode $ do + (st, startoutput) <- processSessionStart ochan nullLogger dsv emitOutput startoutput go st where |