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
|
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Types
import Hash
import Pty
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 Data.List.NonEmpty (NonEmpty(..), toList)
import Data.Monoid
main :: IO ()
main = do
exitstatus <- go ">>> debug-me started"
putStrLn ""
putStrLn ">>> debug-me is exiting..."
exitWith exitstatus
where
go startmsg = runWithPty "bash" [] $ \(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 150000 -- 800000
developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
developer ichan ochan = do
startact <- atomically $ readTChan ochan
case startact of
StartActivity (Seen (Val b)) sig -> do
B.hPut stdout b
hFlush stdout
_ -> return ()
devstate <- newTVarIO (DeveloperState (hash startact) mempty)
_ <- sendTtyInput ichan devstate
`concurrently` sendTtyOutput ochan devstate
return ()
data DeveloperState = DeveloperState
{ lastSeen :: HashPointer
, sentSince :: B.ByteString
}
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 entered (lastSeen ds) dummySignature
writeTChan ichan act
let ds' = ds { sentSince = sentSince ds <> b }
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
b <- atomically get
B.hPut stdout b
hFlush stdout
go
get = do
act <- readTChan ochan
ds <- readTVar devstate
case act of
Activity (Seen (Val b)) 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 = hash act
, sentSince = ss'
}
writeTVar devstate ds'
return b
-- Got an activity out of order or
-- missed one somehow. Ignore it?
_ -> return mempty
user :: B.ByteString -> Pty -> TChan (Activity Entered) -> TChan (Activity Seen) -> IO ()
user startmsg p ichan ochan = do
let startact = StartActivity (Seen (Val (startmsg <> "\r\n"))) dummySignature
atomically $ writeTChan ochan startact
backlog <- newTVarIO $ Backlog ((hash startact, startact) :| [])
_ <- sendPtyOutput p ochan backlog
`concurrently` sendPtyInput ichan p backlog
return ()
-- | Log of recent output, with the most recent output first.
data Backlog = Backlog (NonEmpty (HashPointer, Activity Seen))
deriving (Show)
-- | Forward things written to the Pty out the TChan.
sendPtyOutput :: Pty -> TChan (Activity Seen) -> TVar Backlog -> IO ()
sendPtyOutput p ochan backlog = go
where
go = do
b <- readPty p
atomically $ do
Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog
let seen = Seen (Val b)
let act = Activity seen prevhash dummySignature
writeTChan ochan act
writeTVar backlog (Backlog ((hash act, act) :| toList bl))
go
-- | 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 -> IO ()
sendPtyInput ichan p backlog = go
where
go = do
networkDelay
mb <- atomically $ do
newact <- 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'
then do
writeTVar backlog bl'
return (Right (enteredData (activityContent newact)))
else do
return (Left ("illegal entry" :: String, newact, bl'))
case mb of
Right (Val b) -> do
writePty p b
go
Left _e -> do
-- print e
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 _)
| fst b == hp = Backlog (b :| [])
| otherwise = Backlog (b :| go [] l)
where
go c [] = reverse c
go c (x:xs)
| fst x == hp = reverse (x:c)
| otherwise = go (x:c) xs
truncateBacklog (Backlog bl) _ = Backlog bl
-- | 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 HashPointer in the activity 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 entered hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl))
| lastseenhash == hp = True
| B.null (val (echoData entered)) = False -- optimisation
| any (== hp) (map fst bl) =
let sincehp = reverse (lastseen : takeWhile (\(h, _) -> h /= hp) bl)
in echoData entered == mconcat (map (seenData . activityContent . snd) sincehp)
| otherwise = False
isLegal _ _ = False
dummySignature :: Signature
dummySignature = Signature mempty
|