From 6f7cf857b408401abdc4477c888495b4f13162c7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Apr 2017 17:30:32 -0400 Subject: reorganized message types Make Control messages be out-of-band async messages, without a pointer to a previous message. And then followed the type change through the code for hours.. This commit was sponsored by Nick Daly on Patreon. --- debug-me.hs | 294 +++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 164 insertions(+), 130 deletions(-) (limited to 'debug-me.hs') diff --git a/debug-me.hs b/debug-me.hs index cb353d9..e16576b 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -53,20 +53,21 @@ networkDelay :: IO () networkDelay = threadDelay 800000 -- 800 ms ; the latency to geosync orbit -- networkDelay = threadDelay 150000 -- 150 ms ; transatlantic latency -developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO () +developer :: TChan (Message Entered) -> TChan (Message Seen) -> IO () developer ichan ochan = withLogger "debug-me-developer.log" $ \logger -> do - startact <- atomically $ readTChan ochan - logger $ ActivitySeen startact - case startact of - Activity (Proto (Seen (Val b))) Nothing sig -> do + startmsg <- atomically $ readTChan ochan + logger $ User startmsg + starthash <- case startmsg of + ActivityMessage act@(Activity (Seen (Val b)) Nothing sig) -> do B.hPut stdout b hFlush stdout - _ -> protocolError $ "Unexpected startup: " ++ show startact + return (hash act) + _ -> protocolError $ "Unexpected startup: " ++ show startmsg devstate <- newTVarIO $ DeveloperState - { lastSeen = hash startact + { lastSeen = starthash , sentSince = mempty , enteredSince = mempty - , lastActivity = hash startact + , lastActivity = starthash } _ <- sendTtyInput ichan devstate logger `concurrently` sendTtyOutput ochan devstate logger @@ -81,7 +82,7 @@ data DeveloperState = DeveloperState deriving (Show) -- | Read things typed by the developer, and forward them to the TChan. -sendTtyInput :: TChan (Activity Entered) -> TVar DeveloperState -> Logger -> IO () +sendTtyInput :: TChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () sendTtyInput ichan devstate logger = go where go = do @@ -101,8 +102,8 @@ sendTtyInput ichan devstate logger = go { enteredData = Val b , echoData = Val ed } - let act = Activity (Proto entered) (Just $ lastActivity ds) dummySignature - writeTChan ichan act + let act = Activity entered (Just $ lastActivity ds) dummySignature + writeTChan ichan (ActivityMessage act) let acth = hash act let ds' = ds { sentSince = sentSince ds ++ [b] @@ -111,16 +112,16 @@ sendTtyInput ichan devstate logger = go } writeTVar devstate ds' return act - logger $ ActivityEntered act + logger $ Developer $ ActivityMessage act go -- | Read activity from the TChan and display it to the developer. -sendTtyOutput :: TChan (Activity Seen) -> TVar DeveloperState -> Logger -> IO () +sendTtyOutput :: TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO () sendTtyOutput ochan devstate logger = go where go = do - (v, act) <- atomically $ processOutput ochan devstate - logger $ ActivitySeen act + (v, msg) <- atomically $ processOutput ochan devstate + logger $ User msg case v of ProtocolError e -> protocolError e TtyOutput b -> do @@ -131,147 +132,178 @@ sendTtyOutput ochan devstate logger = go B.hPut stdout "\a" hFlush stdout go + NoOutput -> go -data Output = TtyOutput B.ByteString | Beep | ProtocolError String +data Output = TtyOutput B.ByteString | Beep | ProtocolError String | NoOutput -processOutput :: TChan (Activity Seen) -> TVar DeveloperState -> STM (Output, Activity Seen) +processOutput :: TChan (Message Seen) -> TVar DeveloperState -> STM (Output, Message Seen) processOutput ochan devstate = do - act <- readTChan ochan + msg <- readTChan ochan ds <- readTVar devstate - let (legal, ds') = isLegalSeen act ds - if legal - then case act of - Activity (Proto (Seen (Val b))) _ _ -> do + -- TODO check sig before doing anything else + o <- case msg of + ActivityMessage act@(Activity (Seen (Val b)) _ _) -> do + let (legal, ds') = isLegalSeen act ds + if legal + then do + writeTVar devstate ds' + return (TtyOutput b) + else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act) ++ "\n" ++ show ds) + ControlMessage (Control c _) -> case c of + Rejected _ -> do + -- When they rejected a message we sent, + -- anything we sent subsequently will + -- also be rejected, so forget about it. + let ds' = ds + { sentSince = mempty + , enteredSince = mempty + } writeTVar devstate ds' - return (TtyOutput b, act) - Activity (Rejected _) _ _ -> do - writeTVar devstate ds' - return (Beep, act) - else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act) ++ "\n" ++ show ds, act) + return Beep + SessionKey _ -> return NoOutput + SessionKeyAccepted _ -> return NoOutput + SessionKeyRejected _ -> return NoOutput + return (o, msg) --- | Check if the Seen activity is legal, and returns an updated --- DeveloperState. +-- | Check if the Seen activity is legal, forming a chain with previous +-- ones, 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. +isLegalSeen act@(Activity (Seen (Val b)) (Just hp) sig) ds + -- Does it chain to the last Seen activity? + | hp == lastSeen ds = + -- 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 = acth + , sentSince = ss' + , enteredSince = es' + , lastActivity = acth + } + -- 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 -> 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) + ss' = drop (i+1) ss + es' = drop (i+1) es in yes $ DeveloperState { lastSeen = acth , sentSince = ss' , enteredSince = es' , lastActivity = acth } - -- 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 _)) -> - let ss = sentSince ds - es = enteredSince ds - ss' = drop (i+1) ss - es' = drop (i+1) es - in yes $ DeveloperState - { lastSeen = acth - , sentSince = ss' - , enteredSince = es' - , lastActivity = acth - } where acth = 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 = acth - , lastActivity = acth - } 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 - let startact = Activity (Proto (Seen (Val (startmsg <> "\r\n")))) Nothing dummySignature - logger $ ActivitySeen startact - l <- mkActivityLog (ActivitySeen startact) <$> getPOSIXTime - atomically $ writeTChan ochan startact - backlog <- newTVarIO $ Backlog (l :| []) - _ <- sendPtyOutput p ochan backlog logger - `concurrently` sendPtyInput ichan ochan p backlog logger +user :: B.ByteString -> Pty -> TChan (Message Entered) -> TChan (Message Seen) -> IO () +user starttxt p ichan ochan = withLogger "debug-me.log" $ \logger -> do + let act = Activity (Seen (Val (starttxt <> "\r\n"))) Nothing dummySignature + let startmsg = ActivityMessage act + logger $ User startmsg + l <- mkLog (User startmsg) <$> getPOSIXTime + atomically $ writeTChan ochan startmsg + us <- newTVarIO $ UserState + { backLog = l :| [] + } + _ <- sendPtyOutput p ochan us logger + `concurrently` sendPtyInput ichan ochan p us logger return () -- | Log of recent Activity, with the most recent first. -data Backlog = Backlog (NonEmpty ActivityLog) +type Backlog = NonEmpty Log + +data UserState = UserState + { backLog :: Backlog + } deriving (Show) -- | Forward things written to the Pty out the TChan. -sendPtyOutput :: Pty -> TChan (Activity Seen) -> TVar Backlog -> Logger -> IO () -sendPtyOutput p ochan backlog logger = go +sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO () +sendPtyOutput p ochan us logger = go where go = do b <- readPty p now <- getPOSIXTime - act <- atomically $ do + l <- atomically $ do let seen = Seen (Val b) - sendDeveloper ochan backlog (Proto seen) now - logger $ ActivitySeen act + sendDeveloper ochan us seen now + logger $ User l go -sendDeveloper :: TChan (Activity Seen) -> TVar Backlog -> Proto Seen -> POSIXTime -> STM (Activity Seen) -sendDeveloper ochan backlog pseen now = do - Backlog (bl@(prev :| _)) <- readTVar backlog - let prevhash = loggedHash prev - let act = Activity pseen (Just prevhash) dummySignature - let l = mkActivityLog (ActivitySeen act) now - writeTChan ochan act - writeTVar backlog $ Backlog (l :| toList bl) - return act +class SendableToDeveloper t where + sendDeveloper :: TChan (Message Seen) -> TVar UserState -> t -> POSIXTime -> STM (Message Seen) + +instance SendableToDeveloper Seen where + sendDeveloper ochan us seen now = do + st <- readTVar us + let bl@(prev :| _) = backLog st + let msg = ActivityMessage $ + Activity seen (loggedHash prev) dummySignature + let l = mkLog (User msg) now + writeTChan ochan msg + writeTVar us $ st { backLog = l :| toList bl } + return msg + +instance SendableToDeveloper ControlAction where + sendDeveloper ochan _us c _now = do + let msg = ControlMessage $ Control c dummySignature + -- Control messages are not kept in the backlog. + writeTChan ochan msg + return msg -- | Read things to be entered from the TChan, verify if they're legal, -- and send them to the Pty. -sendPtyInput :: TChan (Activity Entered) -> TChan (Activity Seen) -> Pty -> TVar Backlog -> Logger -> IO () -sendPtyInput ichan ochan p backlog logger = go +sendPtyInput :: TChan (Message Entered) -> TChan (Message Seen) -> Pty -> TVar UserState -> Logger -> IO () +sendPtyInput ichan ochan p us logger = go where go = do networkDelay now <- getPOSIXTime v <- atomically $ do - entered <- readTChan ichan - bl <- readTVar backlog - -- Don't need to retain backlog before the Activity - -- that entered references. - let bl'@(Backlog bll) = reduceBacklog $ - truncateBacklog bl entered - if isLegalEntered entered bl' - then do - let l = mkActivityLog (ActivityEntered entered) now - writeTVar backlog (Backlog (l :| toList bll)) - return (Right entered) - else do - let reject = Rejected entered - Left <$> sendDeveloper ochan backlog reject now + msg <- readTChan ichan + st <- readTVar us + -- TODO check signature first + case msg of + ActivityMessage entered -> do + -- Don't need to retain backlog before the Activity + -- that entered references. + let bl' = reduceBacklog $ + truncateBacklog (backLog st) entered + if isLegalEntered entered (st { backLog = bl' }) + then do + let l = mkLog (Developer msg) now + writeTVar us (st { backLog = l :| toList bl' }) + return (Right msg) + else do + let reject = Rejected entered + Left <$> sendDeveloper ochan us reject now + ControlMessage (Control _ _) -> + return (Right msg) case v of - Right entered -> do - logger (ActivityEntered entered) - case activity entered of - Proto e -> writePty p (val (enteredData e)) - Rejected r -> protocolError $ "User side received a Rejected: " ++ show r + Right (ActivityMessage entered) -> do + logger $ Developer $ ActivityMessage entered + writePty p $ val $ enteredData $ activity entered go + Right (ControlMessage (Control c _)) -> case c of + Rejected r -> protocolError $ "User side received a Rejected: " ++ show r + SessionKey _ -> protocolError "Adding session keys to running session not supported yet" + SessionKeyAccepted _ -> protocolError "User side received a SessionKeyAccepted" + SessionKeyRejected _ -> protocolError "User side received a SessionKeyRejected" Left rejact -> do - logger $ ActivitySeen rejact + logger $ User rejact go -- | Truncate the Backlog to remove entries older than the one @@ -285,23 +317,24 @@ sendPtyInput ichan ochan p backlog logger = go -- If the Activity refers to an item not in the backlog, no truncation is -- done. truncateBacklog :: Backlog -> Activity Entered -> Backlog -truncateBacklog (Backlog (b :| l)) (Activity _ hp _) - | truncationpoint b = Backlog (b :| []) - | otherwise = Backlog (b :| go [] l) +truncateBacklog (b :| l) (Activity _ (Just hp) _) + | truncationpoint b = b :| [] + | otherwise = b :| go [] l where go c [] = reverse c go c (x:xs) | truncationpoint x = reverse (x:c) | otherwise = go (x:c) xs - truncationpoint x@(ActivityLog { loggedActivity = ActivitySeen {}}) = Just (loggedHash x) == hp + truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp truncationpoint _ = False +truncateBacklog bl (Activity _ Nothing _) = bl -- | To avoid DOS attacks that try to fill up the backlog and so use all -- memory, don't let the backlog contain more than 1000 items, or -- more than 16 megabytes of total data. (Excluding the most recent -- item). reduceBacklog :: Backlog -> Backlog -reduceBacklog (Backlog (b :| l)) = Backlog (b :| go 0 (take 1000 l)) +reduceBacklog (b :| l) = b :| go 0 (take 1000 l) where go _ [] = [] go n (x:xs) @@ -317,21 +350,22 @@ reduceBacklog (Backlog (b :| l)) = Backlog (b :| go 0 (take 1000 l)) -- to an older activity, then the echoData must match the -- concatenation of all Seen activities after that one, up to the -- last logged activity. -isLegalEntered :: Activity Entered -> Backlog -> Bool -isLegalEntered (Activity (Proto entered) hp sig) (Backlog (lastact :| bl)) - | Just (loggedHash lastact) == hp = True - | B.null (val (echoData entered)) = False -- optimisation - | any (== hp) (map (Just . loggedHash) bl) = - let sincehp = reverse (lastact : takeWhile (\l -> Just (loggedHash l) /= hp) bl) - in echoData entered == mconcat (map (getseen . loggedActivity) sincehp) +-- +-- Activities that do not enter data point to the first message +-- sent in the debug-me session. +isLegalEntered :: Activity Entered -> UserState -> Bool +isLegalEntered (Activity _ Nothing _) _ = False +isLegalEntered (Activity a (Just hp) sig) us + | loggedHash lastact == Just hp = True + | B.null (val (echoData a)) = False -- optimisation + | any (== Just hp) (map loggedHash bl) = + let sincehp = reverse (lastact : takeWhile (\l -> loggedHash l /= Just hp) bl) + in echoData a == mconcat (map (getseen . loggedMessage) sincehp) | otherwise = False where - getseen (ActivitySeen a) = case activity a of - Proto s -> seenData s - _ -> mempty - getseen (ActivityEntered _) = mempty --- Developer should never send Rejected. -isLegalEntered (Activity (Rejected _) _ _) _ = False + (lastact :| bl) = backLog us + getseen (User (ActivityMessage as)) = seenData $ activity as + getseen _ = mempty -- | Temporary hack while user and developer share a process. protocolError :: String -> IO a -- cgit v1.2.3