diff options
Diffstat (limited to 'debug-me.hs')
| -rw-r--r-- | debug-me.hs | 59 |
1 files changed, 36 insertions, 23 deletions
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 |