summaryrefslogtreecommitdiffhomepage
path: root/debug-me.hs
diff options
context:
space:
mode:
Diffstat (limited to 'debug-me.hs')
-rw-r--r--debug-me.hs142
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-09 06:29:47 +0000