1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
|
{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts #-}
module Main where
import Types
import Hash
import Pty
import CmdLine
import Graphviz
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import System.IO
import System.Process
import System.Exit
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.List.NonEmpty (NonEmpty(..), toList)
import Data.Monoid
import Data.Aeson
main :: IO ()
main = do
c <- getCmdLine
case mode c of
Test -> test
Graphviz logfile -> graphviz logfile
test :: IO ()
test = do
exitstatus <- go ">>> debug-me session starting"
putStrLn ""
putStrLn ">>> debug-me session is done"
exitWith exitstatus
where
go startmsg = runWithPty "dash" [] $ \(p, ph) -> do
ichan <- newTChanIO
ochan <- newTChanIO
dthread <- async (developer ichan ochan)
uthread <- async (user startmsg p ichan ochan)
exitstatus <- waitForProcess ph
cancel dthread
cancel uthread
return exitstatus
-- | 800 ms is about the latency to geosync orbit
networkDelay :: IO ()
networkDelay = threadDelay 800000 -- 150000 -- 800000
developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
developer ichan ochan = do
startact <- atomically $ readTChan ochan
case startact of
Activity (Proto (Seen (Val b))) Nothing sig -> do
B.hPut stdout b
hFlush stdout
_ -> error $ "Startup protocol error, unexpected: " ++ show startact
devstate <- newTVarIO $ DeveloperState
{ lastSeen = hash startact
, sentSince = mempty
, lastActivity = hash startact
}
_ <- sendTtyInput ichan devstate
`concurrently` sendTtyOutput ochan devstate
return ()
data DeveloperState = DeveloperState
{ lastSeen :: Hash
, sentSince :: B.ByteString
, lastActivity :: Hash
}
deriving (Show)
-- | Read things typed by the developer, and forward them to the TChan.
sendTtyInput :: TChan (Activity Entered) -> TVar DeveloperState -> IO ()
sendTtyInput ichan devstate = go
where
go = do
b <- B.hGetSome stdin 1024
if b == B.empty
then return ()
else send b
send b = do
atomically $ do
ds <- readTVar devstate
let entered = Entered
{ enteredData = Val b
, echoData = Val (sentSince ds)
}
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
-- | Read activity from the TChan and display it to the developer.
sendTtyOutput :: TChan (Activity Seen) -> TVar DeveloperState -> IO ()
sendTtyOutput ochan devstate = go
where
go = do
maybe (return ()) emit =<< atomically get
go
emit b = do
B.hPut stdout b
hFlush stdout
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
let ss = sentSince ds
let ss' = if b `B.isPrefixOf` ss
then B.drop (B.length b) ss
else mempty
let ds' = DeveloperState
{ 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 (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
let l = ActivitySeen (startact, hash startact)
logger l
atomically $ writeTChan ochan startact
backlog <- newTVarIO $ Backlog (l :| [])
_ <- sendPtyOutput p ochan backlog logger
`concurrently` sendPtyInput ichan ochan p backlog logger
return ()
-- | Log of recent Activity, with the most recent first.
data Backlog = Backlog (NonEmpty ActivityLog)
deriving (Show)
type Logger = ActivityLog -> IO ()
withLogger :: FilePath -> (Logger -> IO a) -> IO a
withLogger logfile a = withFile logfile WriteMode (a . mkLogger)
mkLogger :: Handle -> Logger
mkLogger h a = do
L.hPut h (encode a)
hPutStr h "\n"
hFlush h
-- | Forward things written to the Pty out the TChan.
sendPtyOutput :: Pty -> TChan (Activity Seen) -> TVar Backlog -> Logger -> IO ()
sendPtyOutput p ochan backlog logger = go
where
go = do
b <- readPty p
act <- atomically $ do
let seen = Seen (Val b)
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@(prev :| _)) <- readTVar backlog
let prevhash = activityLogHash prev
let act = Activity pseen (Just prevhash) dummySignature
writeTChan ochan act
writeTVar backlog (Backlog (ActivitySeen (act, hash 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) -> TChan (Activity Seen) -> Pty -> TVar Backlog -> Logger -> IO ()
sendPtyInput ichan ochan p backlog logger = go
where
go = do
networkDelay
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) = truncateBacklog bl entered
if isLegal entered bl'
then do
let l = ActivityEntered (entered, hash entered)
writeTVar backlog (Backlog (l :| toList bll))
return (Right (entered, l))
else do
let reject = Rejected entered
Left <$> sendDeveloper ochan backlog reject
case v of
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
go
Left rejact -> do
logger $ ActivitySeen (rejact, hash rejact)
go
-- | Truncate the Backlog to remove entries older than the one
-- that the Activity refers to.
--
-- 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 _)
| Just (activityLogHash b) == hp = Backlog (b :| [])
| otherwise = Backlog (b :| go [] l)
where
go c [] = reverse c
go c (x:xs)
| 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,
-- because this guarantees that the person who entered it saw
-- the current state of the system before manipulating it.
--
-- To support typeahead on slow links, some echoData may be provided
-- in the Entered activity. If the prevActivity points
-- to an older Seen activity, then the echoData must match the
-- 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 :| bl))
| Just (activityLogHash lastseen) == hp = True
| B.null (val (echoData entered)) = False -- optimisation
| 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
getseen (ActivitySeen (a, _)) = case activity a of
Proto s -> seenData s
_ -> mempty
getseen (ActivityEntered _) = mempty
-- Developer should never send Rejected.
isLegal (Activity (Rejected _) _ _) _ = False
dummySignature :: Signature
dummySignature = Signature mempty
|