From 1c88d1cecff743f59b9525bab01ecccffdb7d71a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 17 Apr 2017 12:54:56 -0400 Subject: Include Entered in the Activity chain So when the developer makes 2 keypresses close together, they send the second Activity Entered with the first Activity Entered as its HashPointer. This allows the developer to prove the order they did things. This commit was sponsored by Peter Hogg on Patreon. --- debug-me.hs | 93 +++++++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 59 insertions(+), 34 deletions(-) (limited to 'debug-me.hs') diff --git a/debug-me.hs b/debug-me.hs index cae0c3d..fe26e1f 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -46,7 +46,7 @@ test = do -- | 800 ms is about the latency to geosync orbit networkDelay :: IO () -networkDelay = threadDelay 150000 -- 800000 +networkDelay = threadDelay 800000 -- 150000 -- 800000 developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO () developer ichan ochan = do @@ -56,7 +56,11 @@ developer ichan ochan = do B.hPut stdout b hFlush stdout _ -> error $ "Startup protocol error, unexpected: " ++ show startact - devstate <- newTVarIO (DeveloperState (hash startact) mempty) + devstate <- newTVarIO $ DeveloperState + { lastSeen = hash startact + , sentSince = mempty + , lastActivity = hash startact + } _ <- sendTtyInput ichan devstate `concurrently` sendTtyOutput ochan devstate return () @@ -64,6 +68,7 @@ developer ichan ochan = do data DeveloperState = DeveloperState { lastSeen :: Hash , sentSince :: B.ByteString + , lastActivity :: Hash } deriving (Show) @@ -83,10 +88,11 @@ sendTtyInput ichan devstate = go { enteredData = Val b , echoData = Val (sentSince ds) } - let act = Activity (Proto entered) (Just $ lastSeen ds) dummySignature + let act = Activity (Proto entered) (Just $ lastActivity ds) dummySignature writeTChan ichan act let ds' = ds { sentSince = sentSince ds <> b + , lastActivity = hash act } writeTVar devstate ds' go @@ -96,13 +102,15 @@ sendTtyOutput :: TChan (Activity Seen) -> TVar DeveloperState -> IO () sendTtyOutput ochan devstate = go where go = do - b <- atomically get + maybe (return ()) emit =<< atomically get + go + emit b = do B.hPut stdout b hFlush stdout - 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 @@ -111,27 +119,40 @@ sendTtyOutput ochan devstate = go then B.drop (B.length b) ss else mempty let ds' = DeveloperState - { lastSeen = hash act + { lastSeen = h , sentSince = ss' + , lastActivity = h + } + writeTVar devstate ds' + return (Just b) + | hp == lastActivity ds -> do + let ds' = DeveloperState + { lastSeen = h + , sentSince = mempty + , lastActivity = h } writeTVar devstate ds' - return b - -- Got an activity out of order or - -- missed one somehow. Ignore it? - _ -> return mempty + 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" user :: B.ByteString -> Pty -> TChan (Activity Entered) -> TChan (Activity Seen) -> IO () user startmsg p ichan ochan = withLogger "debug-me.log" $ \logger -> do let startact = Activity (Proto (Seen (Val (startmsg <> "\r\n")))) Nothing dummySignature - logger $ ActivitySeen (startact, hash startact) + let l = ActivitySeen (startact, hash startact) + logger l atomically $ writeTChan ochan startact - backlog <- newTVarIO $ Backlog ((hash startact, startact) :| []) + backlog <- newTVarIO $ Backlog (l :| []) _ <- sendPtyOutput p ochan backlog logger `concurrently` sendPtyInput ichan ochan p backlog logger return () --- | Log of recent Activity Seen, with the most recent first. -data Backlog = Backlog (NonEmpty (Hash, Activity Seen)) +-- | Log of recent Activity, with the most recent first. +data Backlog = Backlog (NonEmpty ActivityLog) deriving (Show) type Logger = ActivityLog -> IO () @@ -159,10 +180,11 @@ sendPtyOutput p ochan backlog logger = go sendDeveloper :: TChan (Activity Seen) -> TVar Backlog -> Proto Seen -> STM (Activity Seen) sendDeveloper ochan backlog pseen = do - Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog + Backlog (bl@(prev :| _)) <- readTVar backlog + let prevhash = activityLogHash prev let act = Activity pseen (Just prevhash) dummySignature writeTChan ochan act - writeTVar backlog (Backlog ((hash act, act) :| toList bl)) + writeTVar backlog (Backlog (ActivitySeen (act, hash act) :| toList bl)) return act -- | Read things to be entered from the TChan, verify if they're legal, @@ -173,21 +195,22 @@ sendPtyInput ichan ochan p backlog logger = go go = do networkDelay v <- atomically $ do - newact <- readTChan ichan + entered <- readTChan ichan bl <- readTVar backlog -- Don't need to retain backlog before the Activity - -- that newact references. - let bl' = truncateBacklog bl newact - if isLegal newact bl' + -- that entered references. + let bl'@(Backlog bll) = truncateBacklog bl entered + if isLegal entered bl' then do - writeTVar backlog bl' - return (Right newact) + let l = ActivityEntered (entered, hash entered) + writeTVar backlog (Backlog (l :| toList bll)) + return (Right (entered, l)) else do - let reject = Rejected newact + let reject = Rejected entered Left <$> sendDeveloper ochan backlog reject case v of - Right entered -> do - logger $ ActivityEntered (entered, hash entered) + Right (entered, l) -> do + 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 @@ -203,12 +226,12 @@ sendPtyInput ichan ochan p backlog logger = go -- done. truncateBacklog :: Backlog -> Activity Entered -> Backlog truncateBacklog (Backlog (b :| l)) (Activity _ hp _) - | Just (fst b) == hp = Backlog (b :| []) + | Just (activityLogHash b) == hp = Backlog (b :| []) | otherwise = Backlog (b :| go [] l) where go c [] = reverse c go c (x:xs) - | Just (fst x) == hp = reverse (x:c) + | 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, @@ -221,16 +244,18 @@ truncateBacklog (Backlog (b :| l)) (Activity _ hp _) -- 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@(lastseenhash, _lastseen) :| bl)) - | Just lastseenhash == hp = True +isLegal (Activity (Proto entered) hp sig) (Backlog (lastseen :| bl)) + | Just (activityLogHash lastseen) == hp = True | B.null (val (echoData entered)) = False -- optimisation - | any (== hp) (map (Just . fst) bl) = - let sincehp = reverse (lastseen : takeWhile (\(h, _) -> Just h /= hp) bl) - in echoData entered == mconcat (map (getdata . activity . snd) sincehp) + | any (== hp) (map (Just . activityLogHash) bl) = + let sincehp = reverse (lastseen : takeWhile (\l -> Just (activityLogHash l) /= hp) bl) + in echoData entered == mconcat (map getseen sincehp) | otherwise = False where - getdata (Proto s) = seenData s - getdata (Rejected _) = mempty + getseen (ActivitySeen (a, _)) = case activity a of + Proto s -> seenData s + _ -> mempty + getseen (ActivityEntered _) = mempty -- Developer should never send Rejected. isLegal (Activity (Rejected _) _ _) _ = False -- cgit v1.2.3