diff options
Diffstat (limited to 'debug-me.hs')
-rw-r--r-- | debug-me.hs | 142 |
1 files changed, 96 insertions, 46 deletions
diff --git a/debug-me.hs b/debug-me.hs index fe26e1f..07ff05b 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -16,6 +16,7 @@ import System.Process import System.Exit import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import Data.List import Data.List.NonEmpty (NonEmpty(..), toList) import Data.Monoid import Data.Aeson @@ -55,10 +56,11 @@ developer ichan ochan = do Activity (Proto (Seen (Val b))) Nothing sig -> do B.hPut stdout b hFlush stdout - _ -> error $ "Startup protocol error, unexpected: " ++ show startact + _ -> protocolError $ "Unexpected startup: " ++ show startact devstate <- newTVarIO $ DeveloperState { lastSeen = hash startact , sentSince = mempty + , enteredSince = mempty , lastActivity = hash startact } _ <- sendTtyInput ichan devstate @@ -67,7 +69,8 @@ developer ichan ochan = do data DeveloperState = DeveloperState { lastSeen :: Hash - , sentSince :: B.ByteString + , sentSince :: [B.ByteString] + , enteredSince :: [Hash] , lastActivity :: Hash } deriving (Show) @@ -86,13 +89,15 @@ sendTtyInput ichan devstate = go ds <- readTVar devstate let entered = Entered { enteredData = Val b - , echoData = Val (sentSince ds) + , echoData = Val $ B.concat $ sentSince ds } let act = Activity (Proto entered) (Just $ lastActivity ds) dummySignature writeTChan ichan act + let acth = hash act let ds' = ds - { sentSince = sentSince ds <> b - , lastActivity = hash act + { sentSince = sentSince ds ++ [b] + , enteredSince = enteredSince ds ++ [acth] + , lastActivity = acth } writeTVar devstate ds' go @@ -102,43 +107,80 @@ sendTtyOutput :: TChan (Activity Seen) -> TVar DeveloperState -> IO () sendTtyOutput ochan devstate = go where go = do - maybe (return ()) emit =<< atomically get - go - emit b = do - B.hPut stdout b - hFlush stdout + v <- atomically get + case v of + Left e -> protocolError e + Right (Just b) -> do + B.hPut stdout b + hFlush stdout + go + Right Nothing -> go get = do act <- readTChan ochan ds <- readTVar devstate - let h = hash act - case act of - Activity (Proto (Seen (Val b))) (Just hp) sig - | hp == lastSeen ds -> do - let ss = sentSince ds - let ss' = if b `B.isPrefixOf` ss - then B.drop (B.length b) ss - else mempty - let ds' = DeveloperState - { lastSeen = h - , sentSince = ss' - , lastActivity = h - } + let (legal, ds') = isLegalSeen act ds + if legal + then case act of + Activity (Proto (Seen (Val b))) _ _ -> do writeTVar devstate ds' - return (Just b) - | hp == lastActivity ds -> do - let ds' = DeveloperState - { lastSeen = h - , sentSince = mempty - , lastActivity = h - } - writeTVar devstate ds' - return (Just b) - | otherwise -> error "Protocol error: Received a Seen Val out of order" - Activity (Rejected a) (Just hp) sig -> do - let ds' = ds { lastSeen = h } - writeTVar devstate ds' - return Nothing - Activity _ Nothing _ -> error "Protocol error: Received a Seen Val with no prevActivity" + return $ Right $ Just b + Activity (Rejected _) _ _ -> do + writeTVar devstate ds' + return $ Right Nothing + else return $ Left $ "Illegal Seen value: " ++ show (act, hash act) ++ "\n" ++ show ds + +-- | Check if the Seen activity is legal, and returns an updated +-- DeveloperState. +isLegalSeen :: Activity Seen -> DeveloperState -> (Bool, DeveloperState) +isLegalSeen act@(Activity p (Just hp) sig) ds + -- Does it chain to the last Seen value? + | hp == lastSeen ds = case p of + Rejected _ -> yesrej + Proto (Seen (Val b)) -> + -- Trim sentSince and enteredSince to + -- values after the Seen value. + let ss = sentSince ds + es = enteredSince ds + n = B.length b + (ss', es') = if b `B.isPrefixOf` mconcat ss + then (drop n ss, drop n es) + else (mempty, mempty) + in yes $ DeveloperState + { lastSeen = h + , sentSince = ss' + , enteredSince = es' + , lastActivity = h + } + -- Does it chain to something we've entered since the last Seen + -- value? Eg, user sent A, we replied B C, and the user has + -- now replied to B. + -- If so, we can drop B (and anything before it) from + -- enteredSince and sentSince. + | otherwise = case elemIndex hp (enteredSince ds) of + Nothing -> (False, ds) + Just i -> case p of + Rejected _ -> yesrej + Proto (Seen (Val b)) -> + let ss = sentSince ds + es = enteredSince ds + ss' = drop (i+1) ss + es' = drop (i+1) es + in yes $ DeveloperState + { lastSeen = h + , sentSince = ss' + , enteredSince = es' + , lastActivity = h + } + where + h = hash act + yes ds' = (True, ds') + -- When they rejected a message we sent, anything we sent + -- subsequently will also be rejected, so forget about it. + yesrej = yes $ ds + { lastSeen = h + , lastActivity = h + } +isLegalSeen (Activity _ Nothing _) ds = (False, ds) user :: B.ByteString -> Pty -> TChan (Activity Entered) -> TChan (Activity Seen) -> IO () user startmsg p ichan ochan = withLogger "debug-me.log" $ \logger -> do @@ -200,7 +242,7 @@ sendPtyInput ichan ochan p backlog logger = go -- Don't need to retain backlog before the Activity -- that entered references. let bl'@(Backlog bll) = truncateBacklog bl entered - if isLegal entered bl' + if isLegalEntered entered bl' then do let l = ActivityEntered (entered, hash entered) writeTVar backlog (Backlog (l :| toList bll)) @@ -213,7 +255,7 @@ sendPtyInput ichan ochan p backlog logger = go logger l case activity entered of Proto e -> writePty p (val (enteredData e)) - Rejected r -> error $ "Protocol error: User side received a Rejected: " ++ show r + Rejected r -> protocolError $ "User side received a Rejected: " ++ show r go Left rejact -> do logger $ ActivitySeen (rejact, hash rejact) @@ -234,17 +276,17 @@ truncateBacklog (Backlog (b :| l)) (Activity _ hp _) | Just (activityLogHash x) == hp = reverse (x:c) | otherwise = go (x:c) xs --- | Entered activity is only legal if it points to the last Seen activvity, +-- | Entered activity is legal when it points to the last Seen activvity, -- because this guarantees that the person who entered it saw -- the current state of the system before manipulating it. -- -- To support typeahead on slow links, some echoData may be provided -- in the Entered activity. If the prevActivity points -- to an older Seen activity, then the echoData must match the --- concatenation of all activities after that one, up to the most recent --- Seen activity. -isLegal :: Activity Entered -> Backlog -> Bool -isLegal (Activity (Proto entered) hp sig) (Backlog (lastseen :| bl)) +-- concatenation of all Seen activities after that one, up to the +-- most recent Seen activity. +isLegalEntered :: Activity Entered -> Backlog -> Bool +isLegalEntered (Activity (Proto entered) hp sig) (Backlog (lastseen :| bl)) | Just (activityLogHash lastseen) == hp = True | B.null (val (echoData entered)) = False -- optimisation | any (== hp) (map (Just . activityLogHash) bl) = @@ -257,7 +299,15 @@ isLegal (Activity (Proto entered) hp sig) (Backlog (lastseen :| bl)) _ -> mempty getseen (ActivityEntered _) = mempty -- Developer should never send Rejected. -isLegal (Activity (Rejected _) _ _) _ = False +isLegalEntered (Activity (Rejected _) _ _) _ = False dummySignature :: Signature dummySignature = Signature mempty + +-- | Temporary hack while user and developer share a process. +protocolError :: String -> IO a +protocolError e = do + hPutStrLn stderr e + hFlush stderr + _ <- exitWith (ExitFailure 101) + error e |