diff options
-rw-r--r-- | TODO | 5 | ||||
-rw-r--r-- | Types.hs | 4 | ||||
-rw-r--r-- | debug-me.hs | 93 |
3 files changed, 64 insertions, 38 deletions
@@ -1,3 +1,4 @@ +* async bugs * Uncommenting the networkDelay in sendPtyOutput exposes a bug in the Activity chain construction. * potential DOS where developer sends Activity Entered that all @@ -16,10 +17,6 @@ amount of time would also work; after eg 10 seconds it's very unlikely that a Activity Entered will legitimately refer to an old backlog item. -* 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. * Encryption! * Network! * Server! @@ -77,6 +77,10 @@ data ActivityLog } deriving (Show, Generic) +activityLogHash :: ActivityLog -> Hash +activityLogHash (ActivitySeen (_, h)) = h +activityLogHash (ActivityEntered (_, h)) = h + instance ToJSON (ActivityLog) instance FromJSON (ActivityLog) 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 |