From daf79506ba6ac9fa6b795ad2a19684288b367a92 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 17 Apr 2017 12:07:02 -0400 Subject: add Rejected and tag hashes by type Need a way for the user to indicate when an Activity Entered is Rejected. Changed hashing to include type tags, so Acticity Entered and Activity Seen can never hash to the same hash. Got debug-me.hs to compile after these changes, but currently it's buggy after Activity Entered is Rejected. Started protocol.txt documentation. This commit was sponsored by Francois Marier on Patreon. --- debug-me.hs | 59 ++++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 36 insertions(+), 23 deletions(-) (limited to 'debug-me.hs') diff --git a/debug-me.hs b/debug-me.hs index 075ca17..cae0c3d 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -52,10 +52,10 @@ developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO () developer ichan ochan = do startact <- atomically $ readTChan ochan case startact of - Activity (Seen (Val b)) Nothing sig -> do + Activity (Proto (Seen (Val b))) Nothing sig -> do B.hPut stdout b hFlush stdout - _ -> return () + _ -> error $ "Startup protocol error, unexpected: " ++ show startact devstate <- newTVarIO (DeveloperState (hash startact) mempty) _ <- sendTtyInput ichan devstate `concurrently` sendTtyOutput ochan devstate @@ -83,9 +83,11 @@ sendTtyInput ichan devstate = go { enteredData = Val b , echoData = Val (sentSince ds) } - let act = Activity entered (Just $ lastSeen ds) dummySignature + let act = Activity (Proto entered) (Just $ lastSeen ds) dummySignature writeTChan ichan act - let ds' = ds { sentSince = sentSince ds <> b } + let ds' = ds + { sentSince = sentSince ds <> b + } writeTVar devstate ds' go @@ -102,7 +104,7 @@ sendTtyOutput ochan devstate = go act <- readTChan ochan ds <- readTVar devstate case act of - Activity (Seen (Val b)) (Just hp) sig + Activity (Proto (Seen (Val b))) (Just hp) sig | hp == lastSeen ds -> do let ss = sentSince ds let ss' = if b `B.isPrefixOf` ss @@ -120,15 +122,15 @@ sendTtyOutput ochan devstate = go 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 (Seen (Val (startmsg <> "\r\n"))) Nothing dummySignature + let startact = Activity (Proto (Seen (Val (startmsg <> "\r\n")))) Nothing dummySignature logger $ ActivitySeen (startact, hash startact) atomically $ writeTChan ochan startact backlog <- newTVarIO $ Backlog ((hash startact, startact) :| []) _ <- sendPtyOutput p ochan backlog logger - `concurrently` sendPtyInput ichan p backlog logger + `concurrently` sendPtyInput ichan ochan p backlog logger return () --- | Log of recent output, with the most recent output first. +-- | Log of recent Activity Seen, with the most recent first. data Backlog = Backlog (NonEmpty (Hash, Activity Seen)) deriving (Show) @@ -150,19 +152,23 @@ sendPtyOutput p ochan backlog logger = go go = do b <- readPty p act <- atomically $ do - Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog let seen = Seen (Val b) - let act = Activity seen (Just prevhash) dummySignature - writeTChan ochan act - writeTVar backlog (Backlog ((hash act, act) :| toList bl)) - return act + sendDeveloper ochan backlog (Proto seen) logger $ ActivitySeen (act, hash act) go +sendDeveloper :: TChan (Activity Seen) -> TVar Backlog -> Proto Seen -> STM (Activity Seen) +sendDeveloper ochan backlog pseen = do + Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog + let act = Activity pseen (Just prevhash) dummySignature + writeTChan ochan act + writeTVar backlog (Backlog ((hash act, act) :| toList bl)) + return act + -- | Read things to be entered from the TChan, verify if they're legal, -- and send them to the Pty. -sendPtyInput :: TChan (Activity Entered) -> Pty -> TVar Backlog -> Logger -> IO () -sendPtyInput ichan p backlog logger = go +sendPtyInput :: TChan (Activity Entered) -> TChan (Activity Seen) -> Pty -> TVar Backlog -> Logger -> IO () +sendPtyInput ichan ochan p backlog logger = go where go = do networkDelay @@ -177,15 +183,17 @@ sendPtyInput ichan p backlog logger = go writeTVar backlog bl' return (Right newact) else do - return (Left (newact, bl')) + let reject = Rejected newact + Left <$> sendDeveloper ochan backlog reject case v of Right entered -> do - logger $ ActivityEntered True (entered, hash entered) - writePty p (val (enteredData (activity entered))) + logger $ ActivityEntered (entered, hash entered) + case activity entered of + Proto e -> writePty p (val (enteredData e)) + Rejected r -> error $ "Protocol error: User side received a Rejected: " ++ show r go - Left (illegalentered, _bl) -> do - logger $ ActivityEntered False (illegalentered, hash illegalentered) - -- print bl + Left rejact -> do + logger $ ActivitySeen (rejact, hash rejact) go -- | Truncate the Backlog to remove entries older than the one @@ -213,13 +221,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 entered hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl)) +isLegal (Activity (Proto entered) hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl)) | Just lastseenhash == 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 (seenData . activity . snd) sincehp) + in echoData entered == mconcat (map (getdata . activity . snd) sincehp) | otherwise = False + where + getdata (Proto s) = seenData s + getdata (Rejected _) = mempty +-- Developer should never send Rejected. +isLegal (Activity (Rejected _) _ _) _ = False dummySignature :: Signature dummySignature = Signature mempty -- cgit v1.2.3