diff options
| -rw-r--r-- | Graphviz.hs | 22 | ||||
| -rw-r--r-- | Hash.hs | 42 | ||||
| -rw-r--r-- | Types.hs | 23 | ||||
| -rw-r--r-- | debug-me.hs | 59 | ||||
| -rw-r--r-- | protocol.txt | 39 |
5 files changed, 141 insertions, 44 deletions
diff --git a/Graphviz.hs b/Graphviz.hs index 81ff71a..0809468 100644 --- a/Graphviz.hs +++ b/Graphviz.hs @@ -47,18 +47,16 @@ genGraph ls = digraph (Str "debug-me") $ do forM_ ls $ \l -> case l of ActivitySeen { activitySeen = (a, h) } -> do node (display h) - [ textLabel $ display $ seenData $ activity a - , shape Circle + [ textLabel $ display $ activity a + , shape BoxShape , xcolor Green ] chain a h ActivityEntered { activityEntered = (a, h) } -> do node (display h) - [ textLabel $ display $ enteredData $ activity a - , shape Square - , if activityEnteredAccepted l - then xcolor Green - else xcolor Red + [ textLabel $ display $ activity a + , shape Circle + , xcolor Green ] chain a h where @@ -77,3 +75,13 @@ instance Display Val where instance Display Hash where display (Hash m h) = T.pack (show m) <> display h + +instance Display Seen where + display = display . seenData + +instance Display Entered where + display = display . enteredData + +instance Display a => Display (Proto a) where + display (Proto a) = display a + display (Rejected a) = "Rejected " <> display (activity a) @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Hash where @@ -18,22 +18,46 @@ instance Hashable B.ByteString where instance Hashable Val where hash (Val v) = hash v +instance Hashable Hash where + hash = id + sha256 :: B.ByteString -> H.Digest H.SHA256 sha256 = H.hash --- | Hash the concacenation of the hashes. -instance Hashable [Hash] where - hash = hash . B.concat . map (val . hashValue) +-- | A value tagged with a ByteString describing the type of value. +-- This is hashed by hashing the concacenation of the hash of the +-- bytestring and the hash of the value. This way, items of different types +-- but with the same internal content will hash differently. For example, +-- a Seen "foo" and a Entered "foo" should not hash the same. +data Tagged a = Tagged B.ByteString a + +instance Hashable a => Hashable (Tagged a) where + hash (Tagged b a) = hash [hash b, hash a] instance Hashable a => Hashable (Activity a) where - hash (Activity a (Just p) s) = hash [hash a, p, hash s] - hash (Activity a Nothing s) = hash [hash a, hash s] + hash (Activity a (Just p) s) = hash $ Tagged "Activity" + [hash a, hash p, hash s] + hash (Activity a Nothing s) = hash $ Tagged "Activity" + [hash a, hash (), hash s] + +instance Hashable a => Hashable (Proto a) where + hash (Proto a) = hash $ Tagged "Proto" a + hash (Rejected a) = hash $ Tagged "Rejected" (hash a) instance Hashable Entered where - hash v = hash [hash (enteredData v), hash (echoData v)] + hash v = hash $ Tagged "Entered" + [hash (enteredData v), hash (echoData v)] instance Hashable Seen where - hash v = hash [hash (seenData v)] + hash v = hash $ Tagged "Seen" [hash (seenData v)] instance Hashable Signature where - hash (Signature s) = hash s + hash (Signature s) = hash $ Tagged "Signature" s + +-- | Hash a list of hashes by hashing the concacenation of the hashes. +instance Hashable [Hash] where + hash = hash . B.concat . map (val . hashValue) + +-- | Hash empty string for () +instance Hashable () where + hash () = hash (mempty :: B.ByteString) @@ -37,12 +37,25 @@ data Entered = Entered instance ToJSON Entered instance FromJSON Entered --- | An activity (either Entered or Seen) with a pointer +-- | High level protocol. +data Proto a + = Proto a + -- ^ either Entered or Seen + | Rejected (Activity Entered) + -- ^ sent by user to indicate when an Entered value was rejected. + deriving (Show, Generic) + +instance ToJSON (Proto Seen) +instance FromJSON (Proto Seen) +instance ToJSON (Proto Entered) +instance FromJSON (Proto Entered) + +-- | A Proto activity (either Entered or Seen) with a pointer -- to the Activity before this one. -- -- The Signature is over both the data in the activity, and its pointer. data Activity a = Activity - { activity :: a + { activity :: Proto a , prevActivity :: (Maybe Hash) , signature :: Signature } @@ -53,14 +66,14 @@ instance FromJSON (Activity Seen) instance ToJSON (Activity Entered) instance FromJSON (Activity Entered) --- | A log of Activity both Entered and Seen. +-- | A log of Activity both Entered and Seen, which can be recorded to +-- prove what happened in a debug-me session. data ActivityLog = ActivitySeen { activitySeen :: (Activity Seen, Hash) } | ActivityEntered - { activityEnteredAccepted :: Bool - , activityEntered :: (Activity Entered, Hash) + { activityEntered :: (Activity Entered, Hash) } deriving (Show, Generic) diff --git a/debug-me.hs b/debug-me.hs index 075ca17..cae0c3d 100644 --- a/debug-me.hs +++ b/debug-me.hs @@ -52,10 +52,10 @@ developer :: TChan (Activity Entered) -> TChan (Activity Seen) -> IO () developer ichan ochan = do startact <- atomically $ readTChan ochan case startact of - Activity (Seen (Val b)) Nothing sig -> do + Activity (Proto (Seen (Val b))) Nothing sig -> do B.hPut stdout b hFlush stdout - _ -> return () + _ -> error $ "Startup protocol error, unexpected: " ++ show startact devstate <- newTVarIO (DeveloperState (hash startact) mempty) _ <- sendTtyInput ichan devstate `concurrently` sendTtyOutput ochan devstate @@ -83,9 +83,11 @@ sendTtyInput ichan devstate = go { enteredData = Val b , echoData = Val (sentSince ds) } - let act = Activity entered (Just $ lastSeen ds) dummySignature + let act = Activity (Proto entered) (Just $ lastSeen ds) dummySignature writeTChan ichan act - let ds' = ds { sentSince = sentSince ds <> b } + let ds' = ds + { sentSince = sentSince ds <> b + } writeTVar devstate ds' go @@ -102,7 +104,7 @@ sendTtyOutput ochan devstate = go act <- readTChan ochan ds <- readTVar devstate case act of - Activity (Seen (Val b)) (Just hp) sig + Activity (Proto (Seen (Val b))) (Just hp) sig | hp == lastSeen ds -> do let ss = sentSince ds let ss' = if b `B.isPrefixOf` ss @@ -120,15 +122,15 @@ sendTtyOutput ochan devstate = go 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 (Seen (Val (startmsg <> "\r\n"))) Nothing dummySignature + let startact = Activity (Proto (Seen (Val (startmsg <> "\r\n")))) Nothing dummySignature logger $ ActivitySeen (startact, hash startact) atomically $ writeTChan ochan startact backlog <- newTVarIO $ Backlog ((hash startact, startact) :| []) _ <- sendPtyOutput p ochan backlog logger - `concurrently` sendPtyInput ichan p backlog logger + `concurrently` sendPtyInput ichan ochan p backlog logger return () --- | Log of recent output, with the most recent output first. +-- | Log of recent Activity Seen, with the most recent first. data Backlog = Backlog (NonEmpty (Hash, Activity Seen)) deriving (Show) @@ -150,19 +152,23 @@ sendPtyOutput p ochan backlog logger = go go = do b <- readPty p act <- atomically $ do - Backlog (bl@((prevhash, _) :| _)) <- readTVar backlog let seen = Seen (Val b) - let act = Activity seen (Just prevhash) dummySignature - writeTChan ochan act - writeTVar backlog (Backlog ((hash act, act) :| toList bl)) - return act + 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@((prevhash, _) :| _)) <- readTVar backlog + let act = Activity pseen (Just prevhash) dummySignature + writeTChan ochan act + writeTVar backlog (Backlog ((hash act, 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) -> Pty -> TVar Backlog -> Logger -> IO () -sendPtyInput ichan p backlog logger = go +sendPtyInput :: TChan (Activity Entered) -> TChan (Activity Seen) -> Pty -> TVar Backlog -> Logger -> IO () +sendPtyInput ichan ochan p backlog logger = go where go = do networkDelay @@ -177,15 +183,17 @@ sendPtyInput ichan p backlog logger = go writeTVar backlog bl' return (Right newact) else do - return (Left (newact, bl')) + let reject = Rejected newact + Left <$> sendDeveloper ochan backlog reject case v of Right entered -> do - logger $ ActivityEntered True (entered, hash entered) - writePty p (val (enteredData (activity entered))) + logger $ ActivityEntered (entered, hash entered) + 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 (illegalentered, _bl) -> do - logger $ ActivityEntered False (illegalentered, hash illegalentered) - -- print bl + Left rejact -> do + logger $ ActivitySeen (rejact, hash rejact) go -- | Truncate the Backlog to remove entries older than the one @@ -213,13 +221,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 entered hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl)) +isLegal (Activity (Proto entered) hp sig) (Backlog (lastseen@(lastseenhash, _lastseen) :| bl)) | Just lastseenhash == 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 (seenData . activity . snd) sincehp) + in echoData entered == mconcat (map (getdata . activity . snd) sincehp) | otherwise = False + where + getdata (Proto s) = seenData s + getdata (Rejected _) = mempty +-- Developer should never send Rejected. +isLegal (Activity (Rejected _) _ _) _ = False dummySignature :: Signature dummySignature = Signature mempty diff --git a/protocol.txt b/protocol.txt new file mode 100644 index 0000000..223f58a --- /dev/null +++ b/protocol.txt @@ -0,0 +1,39 @@ +The debug-me protocol is a series of JSON objects, exchanged between +the two participants, known as the user and the developer. + +The exact composition of the JSON objects is not described here; see +Types.hs for the data types that JSON serialization instances are derived +from. + +A debug-me session starts with the user sending an Activity Seen +containing some introductory message. This first Activity Seen has +Nothing as its prevActivity. All subsequent Activity sent by either the +user or developer has a prevActivity that points to the Hash of +the previous activity, so a chain of Activity is built up. + +The exact details about how these objects are hashed is not described here; +see Hash.hs for the implementation. Note that the JSON strings are *not* +directly hashed (to avoid tying hashing to JSON serialization details), +instead the values in the data types are hashed. + +The user and developer have different points of view; the debug-me protocol +makes sure that both sides agree on what is happening, to avoid +disagreements. For example, the developer could send an Activity Entered +at the same time the user is sending an Activity Seen. In this case, +the developer didn't see something that happened while they were entering +a command. So, when the user receives their Activity Entered, and sees that +its prevActivity does not point to the just sent Activity Seen, the user +will reject that input, sending back a Rejected message to let the +developer know. + +This requirement that the developer always send Activity Entered that points +to the last Activity that the user has sent/accepted is known as the +synchronicity requirement. + +The synchronicity requirement can be problematic when the developer is +entering a command, because each letter they type gets echoed back, and +that echo happens asynchronously. To avoid needing to wait for the letter +to be echoed back before the next letter can be entered, the debug-me +protocol allows the developer to include echoDatta in an Activity Entered. + + |