summaryrefslogtreecommitdiffhomepage
path: root/Role/Developer.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Role/Developer.hs')
-rw-r--r--Role/Developer.hs108
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-19 23:44:57 +0000