diff options
Diffstat (limited to 'Role/Developer.hs')
| -rw-r--r-- | Role/Developer.hs | 71 |
1 files changed, 50 insertions, 21 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) |