summaryrefslogtreecommitdiffhomepage
path: root/debug-me.hs
diff options
context:
space:
mode:
Diffstat (limited to 'debug-me.hs')
-rw-r--r--debug-me.hs93
1 files changed, 59 insertions, 34 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-09 11:30:20 +0000