From e40f11ded2e560af33962dd0b7a6f6e3d6069e30 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 17 Apr 2017 15:03:43 -0400 Subject: developer side checking of chain almost done Seems to work well with networkDelay on both sides now. However, typing "top" causes the "to" to be accepted, but the "p" is rejected. --- debug-me.hs | 142 ++++++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 96 insertions(+), 46 deletions(-) (limited to 'debug-me.hs') 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 -- cgit v1.2.3