summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorJoey Hess <joeyh@joeyh.name>2017-05-02 15:52:27 -0400
committerJoey Hess <joeyh@joeyh.name>2017-05-02 17:01:35 -0400
commitf559fcfadd7079140ed64bab68275527f46d334e (patch)
tree1f30f563093a27188a5b1da37aa764f4e58c0393
parent9456361ed8f6dd094a4c08cc352f9a1fd9d0069f (diff)
downloaddebug-me-f559fcfadd7079140ed64bab68275527f46d334e.tar.gz
add prevEntered pointer
Client requires this always point to the previous Entered it accepted, so a hash chain of Entered is built up, and there is no possibility for ambiguity about which order a client received two Entered activies in. So restoreHashes now has to try every possible combination of known hashes for both prevEntered and prevActivity. That could be significantly more work, but it would be unusual for there to be a lot of known hashes, so it should be ok. --graphviz shows this additional hash chain with grey edges (and leaves out edges identical to the other hash chain) While testing this with an artifical network lag, it turned out that signature verification was failing for Reject messages sent by the user. Didn't quite figure out what was at the bottom of that, but the Activity Entered that was sent back in a Reject message was clearly not useful, because it probably had both its prevEntered and prevActivity hashes set to Nothing (because restoreHashes didn't restore them, because the original Activity Entered was out of the expected chain). So, switched Rejected to use a Hash. (And renamed Rejected to EnteredRejected to make it more clear what it's rejecting.) Also, added a lastAccepted hash to EnteredRejected. This lets the developer find its way back to the accepted chain when some of its input gets rejected. This commit was sponsored by Trenton Cronholm on Patreon.
-rw-r--r--Crypto.hs4
-rw-r--r--Graphviz.hs31
-rw-r--r--Hash.hs7
-rw-r--r--PrevActivity.hs33
-rw-r--r--ProtocolBuffers.hs83
-rw-r--r--Role/Developer.hs45
-rw-r--r--Role/User.hs50
-rw-r--r--TODO25
-rw-r--r--Types.hs14
-rw-r--r--WebSockets.hs9
-rw-r--r--doc/protocol.mdwn64
11 files changed, 225 insertions, 140 deletions
diff --git a/Crypto.hs b/Crypto.hs
index d5273ae..8a3bd70 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -30,8 +30,8 @@ class Signed t where
instance Hashable a => Signed (Activity a) where
getSignature = activitySignature
- hashExceptSignature (Activity a mp mt _s) = hash $
- Tagged "Activity" [hash a, hash mp, hash mt]
+ hashExceptSignature (Activity a mpa mpe mt _s) = hash $
+ Tagged "Activity" [hash a, hash mpa, hash mpe, hash mt]
instance Signed Control where
getSignature = controlSignature
diff --git a/Graphviz.hs b/Graphviz.hs
index 59dba7f..f8f165c 100644
--- a/Graphviz.hs
+++ b/Graphviz.hs
@@ -8,7 +8,6 @@
module Graphviz (graphviz) where
import Types
-import Hash
import CmdLine
import Log
@@ -57,37 +56,37 @@ genGraph opts ls = digraph (Str "debug-me") $ do
, shape Circle
]
linkprev s a h
- (User (ControlMessage c), Nothing) -> showcontrol c l
- (Developer (ControlMessage c), Nothing) -> showcontrol c l
+ (User (ControlMessage c), Nothing) -> showcontrol c
+ (Developer (ControlMessage c), Nothing) -> showcontrol c
_ -> return ()
- showcontrol (Control (Rejected ar) _) l = do
- let hr = hash ar
+ showcontrol (Control (EnteredRejected hr _) _) = do
let rejstyle =
[ xcolor Red
, Style [dashed, filled]
]
- let nodename = display $ "Rejected " <> display hr
+ let nodename = display $ "Rejected: " <> display hr
node nodename $ rejstyle ++
[ textLabel "Rejected"
, shape BoxShape
]
- showactivity rejstyle $ Log
- { loggedMessage = Developer (ActivityMessage ar)
- , loggedHash = Just hr
- , loggedTimestamp = loggedTimestamp l
- }
edge nodename (display hr) rejstyle
- showcontrol _ _ = return ()
-
- linkprev s a h = case prevActivity a of
- Nothing -> return ()
- Just p -> link p h s
+ showcontrol _ = return ()
+
+ linkprev s a h = do
+ case prevActivity a of
+ Nothing -> return ()
+ Just p -> link p h s
+ case prevEntered a of
+ Nothing -> return ()
+ Just p -> link p h (s ++ enteredpointerstyle)
link a b s = edge (display a) (display b) $ s ++
if graphvizShowHashes opts
then [ textLabel (prettyDisplay a) ]
else []
+ enteredpointerstyle = [ xcolor Gray ]
+
xcolor :: X11Color -> Attribute
xcolor c = Color [toWC $ X11Color c]
diff --git a/Hash.hs b/Hash.hs
index db4eae8..bf8e166 100644
--- a/Hash.hs
+++ b/Hash.hs
@@ -40,8 +40,8 @@ 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 mp mt s) = hash $ Tagged "Activity"
- [hash a, hash mp, hash mt, hash s]
+ hash (Activity a mps mpe mt s) = hash $ Tagged "Activity"
+ [hash a, hash mps, hash mpe, hash mt, hash s]
instance Hashable Entered where
hash v = hash $ Tagged "Entered"
@@ -51,7 +51,8 @@ instance Hashable Seen where
hash v = hash $ Tagged "Seen" [hash (seenData v)]
instance Hashable ControlAction where
- hash (Rejected a) = hash $ Tagged "Rejected" a
+ hash (EnteredRejected h1 h2) = hash $ Tagged "EnteredRejected"
+ [hash h1, hash h2]
hash (SessionKey pk) = hash $ Tagged "SessionKey" pk
hash (SessionKeyAccepted pk) = hash $ Tagged "SessionKeyAccepted" pk
hash (SessionKeyRejected pk) = hash $ Tagged "SessionKeyRejected" pk
diff --git a/PrevActivity.hs b/PrevActivity.hs
index 0836c8b..74203fd 100644
--- a/PrevActivity.hs
+++ b/PrevActivity.hs
@@ -19,7 +19,10 @@ removeHashes msg = MissingHashes $ case msg of
Developer (ActivityMessage a) -> Developer (go a)
_ -> msg
where
- go a = ActivityMessage $ a { prevActivity = Nothing }
+ go a = ActivityMessage $ a
+ { prevActivity = Nothing
+ , prevEntered = Nothing
+ }
type RecentActivity = STM (SigVerifier, [Hash])
@@ -29,17 +32,27 @@ type RecentActivity = STM (SigVerifier, [Hash])
-- point the message's signature will verify.
restoreHashes :: RecentActivity -> MissingHashes AnyMessage -> STM AnyMessage
restoreHashes ra (MissingHashes msg) = case msg of
- User (ActivityMessage act) ->
- User . ActivityMessage <$> (go act =<< ra)
+ User (ActivityMessage act) ->
+ User . ActivityMessage <$> find act
Developer (ActivityMessage act) ->
- Developer . ActivityMessage <$> (go act =<< ra)
+ Developer . ActivityMessage <$> find act
User (ControlMessage {}) -> return msg
Developer (ControlMessage {}) -> return msg
where
- go act (_, []) = return act
- go act (sigverifier, (h:hs)) = do
- let act' = act { prevActivity = Just h }
- if verifySigned sigverifier act'
- then return act'
- else go act (sigverifier, hs)
+ find act = do
+ (sigverifier, l) <- ra
+ let l' = Nothing : map Just l
+ let ll = do
+ ah <- l'
+ eh <- l'
+ return $ act
+ { prevActivity = ah
+ , prevEntered = eh
+ }
+ go act sigverifier ll
+ go act _ [] = return act
+ go act sigverifier (l:ls) = do
+ if verifySigned sigverifier l
+ then return l
+ else go act sigverifier ls
diff --git a/ProtocolBuffers.hs b/ProtocolBuffers.hs
index d5d6a0e..2d59528 100644
--- a/ProtocolBuffers.hs
+++ b/ProtocolBuffers.hs
@@ -48,9 +48,6 @@ data MessageP a
data ActivityP a = ActivityP
{ activityP :: Required 6 (Message a)
- -- This is not included, because the hash is never actually sent
- -- over the wire!
- -- , prevAtivityP :: Optional 7 (Message HashP)
, elapsedTimeP :: Required 8 (Message ElapsedTimeP)
, activitySignatureP :: Required 9 (Message SignatureP)
}
@@ -63,52 +60,65 @@ data ControlP = ControlP
deriving (Generic)
data ControlActionP
- = RejectedP
- { rejectedP :: Required 12 (Message (ActivityP EnteredP)) }
+ = EnteredRejectedP
+ { enteredRejectedP :: Required 12 (Message HashP)
+ , enteredLastAcceptedP :: Optional 13 (Message HashP)
+ }
| SessionKeyP
- { sessionKeyP :: Required 13 (Message (PerhapsSignedP PublicKeyP)) }
+ { sessionKeyP :: Required 14 (Message (PerhapsSignedP PublicKeyP)) }
| SessionKeyAcceptedP
- { sessionKeyAcceptedP :: Required 14 (Message PublicKeyP) }
+ { sessionKeyAcceptedP :: Required 15 (Message PublicKeyP) }
| SessionKeyRejectedP
- { sessionKeyRejectedP :: Required 15 (Message PublicKeyP) }
+ { sessionKeyRejectedP :: Required 16 (Message PublicKeyP) }
| ChatMessageP
- { chatMessageSenderName :: Required 16 (Value B.ByteString)
- , chatMessage :: Required 17 (Value B.ByteString)
+ { chatMessageSenderName :: Required 17 (Value B.ByteString)
+ , chatMessage :: Required 18 (Value B.ByteString)
}
deriving (Generic)
data SignatureP
= Ed25519SignatureP
- { ed25519SignatureP :: Required 18 (Value B.ByteString) }
+ { ed25519SignatureP :: Required 19 (Value B.ByteString) }
| OtherSignatureP
- { otherSignatureP :: Required 19 (Value B.ByteString) }
+ { otherSignatureP :: Required 20 (Value B.ByteString) }
deriving (Generic)
data PublicKeyP = PublicKeyP
- { mkPublicKeyP :: Required 20 (Value B.ByteString) }
+ { mkPublicKeyP :: Required 21 (Value B.ByteString) }
deriving (Generic)
data PerhapsSignedP a
= GpgSignedP
- { gpgSignedValP :: Required 21 (Message a)
- , gpgSigP :: Required 22 (Message GpgSigP)
+ { gpgSignedValP :: Required 22 (Message a)
+ , gpgSigP :: Required 23 (Message GpgSigP)
}
| UnSignedP
- { mkUnSignedP :: Required 23 (Message a )
+ { mkUnSignedP :: Required 24 (Message a )
}
deriving (Generic)
data GpgSigP = GpgSigP
- { mkGpgSigP :: Required 24 (Value B.ByteString) }
+ { mkGpgSigP :: Required 25 (Value B.ByteString) }
deriving (Generic)
data ElapsedTimeP = ElapsedTimeP
- { mkElapsedTimeP :: Required 25 (Value Double) }
+ { mkElapsedTimeP :: Required 26 (Value Double) }
deriving (Generic)
data AnyMessageP
- = UserP { mkUserP :: Required 26 (Message (MessageP SeenP)) }
- | DeveloperP { mkDeveloperP :: Required 27 (Message (MessageP EnteredP)) }
+ = UserP { mkUserP :: Required 27 (Message (MessageP SeenP)) }
+ | DeveloperP { mkDeveloperP :: Required 28 (Message (MessageP EnteredP)) }
+ deriving (Generic)
+
+data HashP = HashP
+ { hashMethodP :: Required 29 (Message HashMethodP)
+ , hashValueP :: Required 30 (Value B.ByteString)
+ }
+ deriving (Generic)
+
+data HashMethodP
+ = SHA512P { mkSHA512P :: Required 31 (Value Bool) }
+ | SHA3P { mkSHA3P :: Required 32 (Value Bool) }
deriving (Generic)
-- | Conversion between protocol buffer messages and debug-me's main Types.
@@ -155,6 +165,7 @@ instance ProtocolBuffer p t => ProtocolBuffer (ActivityP p) (T.Activity t) where
fromProtocolBuffer p = T.Activity
{ T.activity = fromProtocolBuffer $ getField $ activityP p
, T.prevActivity = Nothing -- not sent over the wire
+ , T.prevEntered = Nothing -- not sent over the wire
, T.elapsedTime = fromProtocolBuffer $ getField $ elapsedTimeP p
, T.activitySignature = fromProtocolBuffer $ getField $ activitySignatureP p
}
@@ -170,8 +181,10 @@ instance ProtocolBuffer ControlP T.Control where
}
instance ProtocolBuffer ControlActionP T.ControlAction where
- toProtocolBuffer (T.Rejected t) = RejectedP
- { rejectedP = putField $ toProtocolBuffer t }
+ toProtocolBuffer t@(T.EnteredRejected {}) = EnteredRejectedP
+ { enteredRejectedP = putField $ toProtocolBuffer $ T.enteredRejected t
+ , enteredLastAcceptedP = putField $ toProtocolBuffer <$> T.enteredLastAccepted t
+ }
toProtocolBuffer (T.SessionKey t) = SessionKeyP
{ sessionKeyP = putField $ toProtocolBuffer t }
toProtocolBuffer (T.SessionKeyAccepted t) = SessionKeyAcceptedP
@@ -182,8 +195,10 @@ instance ProtocolBuffer ControlActionP T.ControlAction where
{ chatMessageSenderName = putField (val sendername)
, chatMessage = putField (val t)
}
- fromProtocolBuffer p@(RejectedP {}) = T.Rejected $
- fromProtocolBuffer $ getField $ rejectedP p
+ fromProtocolBuffer p@(EnteredRejectedP {}) = T.EnteredRejected
+ { T.enteredRejected = fromProtocolBuffer $ getField $ enteredRejectedP p
+ , T.enteredLastAccepted = fromProtocolBuffer <$> getField (enteredLastAcceptedP p)
+ }
fromProtocolBuffer p@(SessionKeyP {}) = T.SessionKey $
fromProtocolBuffer $ getField $ sessionKeyP p
fromProtocolBuffer p@(SessionKeyAcceptedP {}) = T.SessionKeyAccepted $
@@ -204,6 +219,22 @@ instance ProtocolBuffer SignatureP T.Signature where
fromProtocolBuffer p@(OtherSignatureP {}) = T.OtherSignature $
Val $ getField $ otherSignatureP p
+instance ProtocolBuffer HashP T.Hash where
+ toProtocolBuffer t = HashP
+ { hashMethodP = putField $ toProtocolBuffer $ T.hashMethod t
+ , hashValueP = putField $ val $ T.hashValue t
+ }
+ fromProtocolBuffer p = T.Hash
+ { T.hashMethod = fromProtocolBuffer $ getField $ hashMethodP p
+ , T.hashValue = Val $ getField $ hashValueP p
+ }
+
+instance ProtocolBuffer HashMethodP T.HashMethod where
+ toProtocolBuffer T.SHA512 = SHA512P { mkSHA512P = putField True }
+ toProtocolBuffer T.SHA3 = SHA3P { mkSHA3P = putField True }
+ fromProtocolBuffer (SHA512P {}) = T.SHA512
+ fromProtocolBuffer (SHA3P {}) = T.SHA3
+
instance ProtocolBuffer PublicKeyP T.PublicKey where
toProtocolBuffer (T.PublicKey t) = PublicKeyP
{ mkPublicKeyP = putField (val t) }
@@ -251,6 +282,10 @@ instance Encode ControlP
instance Decode ControlP
instance Encode ControlActionP
instance Decode ControlActionP
+instance Encode HashP
+instance Decode HashP
+instance Encode HashMethodP
+instance Decode HashMethodP
instance Encode SignatureP
instance Decode SignatureP
instance Encode PublicKeyP
diff --git a/Role/Developer.hs b/Role/Developer.hs
index 604ac6d..d8d9d2c 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -108,8 +108,10 @@ data DeveloperState = DeveloperState
, enteredSince :: [Hash]
-- ^ Messages we've sent since the last Seen.
, lastActivity :: Hash
+ -- ^ Last Entered or Seen activity
, lastActivityTs :: POSIXTime
- -- ^ Last message sent or received.
+ , lastEntered :: Maybe Hash
+ -- ^ Last Entered activity (either from us or another developer).
, fromOtherDevelopersSince :: [Hash]
-- ^ Messages received from other developers since the last Seen.
-- (The next Seen may chain from one of these.)
@@ -126,7 +128,8 @@ data DeveloperState = DeveloperState
developerStateRecentActivity :: TVar DeveloperState -> RecentActivity
developerStateRecentActivity devstate = do
st <- readTVar devstate
- let hs = lastSeen st : enteredSince st ++ fromOtherDevelopersSince st
+ let hs = lastSeen st : fromMaybe (lastSeen st) (lastEntered st)
+ : enteredSince st ++ fromOtherDevelopersSince st
return (userSigVerifier st <> developerSigVerifier st, hs)
-- | Read things typed by the developer, and forward them to the TMChan.
@@ -154,6 +157,7 @@ sendTtyInput ichan devstate logger = go
let act = mkSigned (developerSessionKey ds) $
Activity entered
(Just $ lastActivity ds)
+ (lastEntered ds)
(mkElapsedTime (lastActivityTs ds) ts)
writeTMChan ichan (ActivityMessage act)
let acth = hash act
@@ -162,6 +166,7 @@ sendTtyInput ichan devstate logger = go
, enteredSince = enteredSince ds ++ [acth]
, lastActivity = acth
, lastActivityTs = ts
+ , lastEntered = Just acth
}
writeTVar devstate ds'
return act
@@ -203,11 +208,11 @@ sendTtyOutput ochan devstate controlinput logger = go
forwardcontrol msg = case msg of
User (ControlMessage c) -> fwd c
Developer (ControlMessage c) -> case control c of
- Rejected _ -> return ()
- SessionKey _ -> return ()
- SessionKeyAccepted _ -> return ()
- SessionKeyRejected _ -> return ()
- ChatMessage _ _ -> fwd c
+ EnteredRejected {} -> return ()
+ SessionKey {} -> return ()
+ SessionKeyAccepted {} -> return ()
+ SessionKeyRejected {} -> return ()
+ ChatMessage {} -> fwd c
_ -> return ()
fwd = atomically . writeTMChan controlinput . ControlInputAction . control
@@ -308,20 +313,21 @@ getServerMessage ochan devstate ts = do
ignore = getServerMessage ochan devstate ts
- processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _ _)) = do
+ processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _ _ _)) = do
let (legal, ds') = isLegalSeen act ds ts
if legal
then do
writeTVar devstate ds'
return (TtyOutput b)
else return (ProtocolError ds $ "Illegal Seen value: " ++ show act)
- processuser ds (ControlMessage (Control (Rejected _) _)) = do
+ processuser ds (ControlMessage (Control (er@EnteredRejected {}) _)) = do
-- When they rejected a message we sent,
-- anything we sent subsequently will
-- also be rejected, so forget about it.
let ds' = ds
{ sentSince = mempty
, enteredSince = mempty
+ , lastEntered = enteredLastAccepted er
}
writeTVar devstate ds'
return Beep
@@ -345,8 +351,8 @@ getServerMessage ochan devstate ts = do
--
-- Does not check the signature.
isLegalSeen :: Activity Seen -> DeveloperState -> POSIXTime -> (Bool, DeveloperState)
-isLegalSeen (Activity _ Nothing _ _) ds _ = (False, ds)
-isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _) ds ts
+isLegalSeen (Activity _ Nothing _ _ _) ds _ = (False, ds)
+isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _ _) ds ts
-- Does it chain to the last Seen activity or to
-- something sent by another developer since the last Seen?
| hp == lastSeen ds || hp `elem` fromOtherDevelopersSince ds =
@@ -364,6 +370,7 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _) ds ts
, enteredSince = es'
, lastActivity = acth
, lastActivityTs = ts
+ , lastEntered = newlastentered
, fromOtherDevelopersSince = mempty
}
-- Does it chain to something we've entered since the last Seen
@@ -384,12 +391,25 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _) ds ts
, enteredSince = es'
, lastActivity = acth
, lastActivityTs = ts
+ , lastEntered = newlastentered
, fromOtherDevelopersSince = mempty
}
where
acth = hash act
yes ds' = (True, ds')
+ -- If there are multiple developers, need to set our lastEntered
+ -- to the prevEntered from the Activity Seen, so we can follow on to
+ -- another developer's activity.
+ --
+ -- But, if there's lag, we may have sent some Activity Entered
+ -- that had not reached the user yet when it constructed the
+ -- Activity Seen, so check if the prevEntered is one of the
+ -- things we've enteredSince; if so keep our lastEntered.
+ newlastentered = case prevEntered act of
+ Just v | v `notElem` enteredSince ds -> Just v
+ _ -> lastEntered ds
+
-- | Start by reading the initial two messages from the user,
-- their session key and the startup message.
processSessionStart :: MySessionKey -> TMChan (MissingHashes AnyMessage) -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output)
@@ -412,7 +432,7 @@ processSessionStart sk ochan logger dsv = do
<$> atomically (readTMChan ochan)
logger startmsg
let (starthash, output) = case startmsg of
- User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _ _))
+ User (ActivityMessage act@(Activity (Seen (Val b)) Nothing Nothing _ _))
| verifySigned sigverifier act ->
(hash act, TtyOutput b)
| otherwise ->
@@ -424,6 +444,7 @@ processSessionStart sk ochan logger dsv = do
, enteredSince = mempty
, lastActivity = starthash
, lastActivityTs = ts
+ , lastEntered = Nothing
, fromOtherDevelopersSince = mempty
, developerSessionKey = sk
, userSigVerifier = sigverifier
diff --git a/Role/User.hs b/Role/User.hs
index e1138c2..a7e4843 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -12,6 +12,7 @@ import Pty
import Memory
import Log
import Session
+import Hash
import Crypto
import Gpg
import CmdLine
@@ -98,13 +99,15 @@ data UserState = UserState
, userSessionKey :: MySessionKey
, sigVerifier :: SigVerifier
, lastSeenTs :: POSIXTime
+ , lastAcceptedEntered :: Maybe Hash
}
-- | RecentActivity that uses the UserState.
userStateRecentActivity :: TVar UserState -> RecentActivity
userStateRecentActivity us = do
st <- readTVar us
- let hs = mapMaybe loggedHash $ toList $ backLog st
+ let hs = catMaybes $ lastAcceptedEntered st
+ : map loggedHash (toList (backLog st))
return (sigVerifier st, hs)
-- | Start by establishing our session key, and displaying the starttxt.
@@ -118,7 +121,9 @@ startProtocol starttxt ochan logger = do
let c = mkSigned sk $ Control (SessionKey pk)
initialmessage $ ControlMessage c
let starttxt' = rawLine starttxt
- let act = mkSigned sk $ Activity (Seen (Val starttxt')) Nothing mempty
+ let act = mkSigned sk $ Activity
+ (Seen (Val starttxt'))
+ Nothing Nothing mempty
let startmsg = ActivityMessage act
B.hPut stdout starttxt'
hFlush stdout
@@ -130,6 +135,7 @@ startProtocol starttxt ochan logger = do
, userSessionKey = sk
, sigVerifier = mempty
, lastSeenTs = now
+ , lastAcceptedEntered = Nothing
}
-- | Forward things the user types to the Pty.
@@ -177,6 +183,7 @@ instance SendableToDeveloper Seen where
mkSigned (userSessionKey st) $
Activity seen
(loggedHash prev)
+ (lastAcceptedEntered st)
(mkElapsedTime (lastSeenTs st) now)
let l = mkLog (User msg) now
writeTMChan ochan msg
@@ -214,14 +221,15 @@ sendPtyInput ichan ochan controlinput p us logger = go
logger $ Developer msg
atomically $ writeTMChan controlinput (ControlInputAction c)
go
- Just (RejectedMessage rej) -> do
+ Just (RejectedMessage ent rej) -> do
+ logger $ Developer ent
logger $ User rej
go
Just (BadlySignedMessage _) -> go
data Input
= InputMessage (Message Entered)
- | RejectedMessage (Message Seen)
+ | RejectedMessage (Message Entered) (Message Seen)
| BadlySignedMessage (Message Entered)
-- Get message from developer, verify its signature is from a developer we
@@ -258,11 +266,18 @@ getDeveloperMessage' (MissingHashes wiremsg) ochan us now = do
if isLegalEntered entered (st { backLog = bl' })
then do
let l = mkLog (Developer msg) now
- writeTVar us (st { backLog = l :| toList bl' })
+ writeTVar us $ st
+ { backLog = l :| toList bl'
+ , lastAcceptedEntered = Just (hash entered)
+ }
return (InputMessage msg)
else do
- let reject = Rejected entered
- RejectedMessage <$> sendDeveloper ochan us reject now
+ let reject = EnteredRejected
+ { enteredRejected = hash entered
+ , enteredLastAccepted = lastAcceptedEntered st
+ }
+ RejectedMessage msg
+ <$> sendDeveloper ochan us reject now
ControlMessage (Control _ _) ->
return (InputMessage msg)
else return (BadlySignedMessage msg)
@@ -278,7 +293,7 @@ getDeveloperMessage' (MissingHashes wiremsg) ochan us now = do
-- If the Activity refers to an item not in the backlog, no truncation is
-- done.
truncateBacklog :: Backlog -> Activity Entered -> Backlog
-truncateBacklog (b :| l) (Activity _ (Just hp) _ _)
+truncateBacklog (b :| l) (Activity _ (Just hp) _ _ _)
| truncationpoint b = b :| []
| otherwise = b :| go [] l
where
@@ -288,7 +303,7 @@ truncateBacklog (b :| l) (Activity _ (Just hp) _ _)
| otherwise = go (x:c) xs
truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp
truncationpoint _ = False
-truncateBacklog bl (Activity _ Nothing _ _) = bl
+truncateBacklog bl (Activity _ Nothing _ _ _) = bl
-- | To avoid DOS attacks that try to fill up the backlog and so use all
-- memory, don't let the backlog contain more than 1000 items, or
@@ -302,23 +317,24 @@ reduceBacklog (b :| l) = b :| go 0 (take 1000 l)
| n > 16777216 = []
| otherwise = x : go (n + dataSize x) xs
--- | Entered activity is legal when it points to the last logged activity,
--- because this guarantees that the person who entered it saw
--- the current state of the system before manipulating it.
+-- | Entered activity is legal when its prevActivity points to the last
+-- logged activity, 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 Entered activity points
--- to an older activity, then the echoData must match the
+-- to an older prevActivity, then the echoData must match the
-- concatenation of all Seen activities after that one, up to the
-- last logged activity.
--
--- Activities that do not enter data point to the first message
--- sent in the debug-me session.
+-- Also, the prevEntered field must point to the last accepted
+-- Entered activity.
--
-- Does not check the signature.
isLegalEntered :: Activity Entered -> UserState -> Bool
-isLegalEntered (Activity _ Nothing _ _) _ = False
-isLegalEntered (Activity a (Just hp) _ _) us
+isLegalEntered (Activity _ Nothing _ _ _) _ = False
+isLegalEntered (Activity a (Just hp) lastentered _ _) us
+ | lastentered /= lastAcceptedEntered us = False
| loggedHash lastact == Just hp = True
| B.null (val (echoData a)) = False -- optimisation
| any (== Just hp) (map loggedHash bl) =
diff --git a/TODO b/TODO
index e3d5109..b048106 100644
--- a/TODO
+++ b/TODO
@@ -1,28 +1,3 @@
-* The current rules for when an Activity Entered is accepted allow it to
- refer to an older activity than the last one. If echoing is disabled,
- two Activity Entered could be sent, each pointing at the most recent
- Activity Seen, and there would be no proof of the order of the two.
- Reordering the two might cause different results though.
-
- This is not only a problem when 2 developers are connected; it also
- lets a single developer produce a proof chain that is ambiguous about
- what order they entered 2 things.
-
- Fix: Make a Activity Entered have a pointer to the previous Activity
- Entered that was accepted, in addition to the existing pointer. Then
- when one developer sends two Activity Entered that don't echo, there's
- still proof of ordering. When two developers are typing at the same
- time, only one of their inputs will be accepted. The client should only
- consider an Activity Entered legal if it points to the last Activity
- Entered that the client saw.
-
- May as well make Activity Seen have a pointer to the last accepted
- Activity Entered as well. This will make it easier when supported
- multiple developers, as each time a developer gets an Activity Seen,
- they can update their state to use the Activity Entered that it points
- to. (Perhaps not needed now that developers see other developer's
- Activity Entered.. But, this does let developers know what the current
- accepted line is.)
* Client should upload to multiple servers, for redundancy. This way,
if Joey runs a server, and Alice runs a server, the user can start
debug-me and not worry that Joey will connect, do something bad, and have
diff --git a/Types.hs b/Types.hs
index 233a7de..8f00793 100644
--- a/Types.hs
+++ b/Types.hs
@@ -65,6 +65,9 @@ instance DataSize a => DataSize (Message a) where
data Activity a = Activity
{ activity :: a
, prevActivity :: Maybe Hash
+ -- ^ Pointer to previous activity Seen/Entered
+ , prevEntered :: Maybe Hash
+ -- ^ Pointer to previous activity Entered
, elapsedTime :: ElapsedTime
, activitySignature :: Signature
}
@@ -92,8 +95,12 @@ instance DataSize Control where
+ dataSize (controlSignature c)
data ControlAction
- = Rejected (Activity Entered)
- -- ^ sent by user to indicate when an Entered value was rejected.
+ = EnteredRejected
+ { enteredRejected :: Hash
+ -- ^ Entered value that was rejected.
+ , enteredLastAccepted :: Maybe Hash
+ -- ^ The last Entered value that was accepted.
+ }
| SessionKey (PerhapsSigned PublicKey)
-- ^ sent by user at start, and later by developer,
-- to indicate their session key
@@ -108,7 +115,8 @@ data ControlAction
type SenderName = Val
instance DataSize ControlAction where
- dataSize (Rejected a) = dataSize a
+ dataSize (EnteredRejected h1 h2) = dataSize h1 +
+ maybe 0 dataSize h2
dataSize (SessionKey k) = dataSize k
dataSize (SessionKeyAccepted k) = dataSize k
dataSize (SessionKeyRejected k) = dataSize k
diff --git a/WebSockets.hs b/WebSockets.hs
index 7750cf8..a220c68 100644
--- a/WebSockets.hs
+++ b/WebSockets.hs
@@ -44,6 +44,7 @@ import Data.Maybe
import Text.Read
import Control.Monad
import Network.URI
+import System.IO
-- | Framing protocol used over a websocket connection.
--
@@ -126,7 +127,7 @@ runClientApp :: URI -> ClientApp a -> IO (Maybe a)
runClientApp serverurl app = do
rv <- newEmptyTMVarIO
let go conn = do
- r <- app conn
+ r <- app conn `catch` showerr
atomically $ putTMVar rv r
catchJust catchconnclosed
(runClientWith host port endpoint connectionOptions [] go)
@@ -139,9 +140,15 @@ runClientApp serverurl app = do
(':':s) -> fromMaybe 80 (readMaybe s)
_ -> 80
endpoint = uriPath serverurl
+
catchconnclosed ConnectionClosed = Just ()
catchconnclosed _ = Nothing
+ showerr :: SomeException -> IO a
+ showerr e = do
+ hPutStrLn stderr (show e)
+ throwIO e
+
-- | Make a client that sends and receives AnyMessages over a websocket.
clientApp
:: Mode
diff --git a/doc/protocol.mdwn b/doc/protocol.mdwn
index 5a0e679..2c4887e 100644
--- a/doc/protocol.mdwn
+++ b/doc/protocol.mdwn
@@ -16,13 +16,12 @@ Seen messages, and the developer responds with Activity Entered.
There are also Control messages, which can be sent by either
party at any time, and do not affect IO to the console.
-The first message in a debug-me session is a Control sent by the
-user, which establishes a session key (see below for details). The second
-message is an Activity Seen.
-
-Activity Seen and Activity Entered messages have a prevActivity,
-which points to the Hash of a previous Activity. (And is Nothing for the
-first Activity Seen.) So a chain of messages is built up.
+Activity Seen and Activity Entered messages have a prevActivity field,
+which points to the Hash of a previous Activity either Seen or Entered.
+There is also a prevEntered field, which points to the Hash of the most
+recent Activity Entered. (prevActivity is Nothing for the first Activity
+Seen, and prevEntered is Nothing until the developer enters something.)
+So a chain of messages is built up.
(The exact details about how objects are hashed is not described here; see
[Hash.hs](http://source.debug-me.branchable.com/?p=source.git;a=blob;f=Hash.hs;hb=HEAD)
@@ -43,21 +42,24 @@ entering "y" in response to "Display detailed reactor logs?" at the same time
that a new "Vent core to atmosphere?" question was being displayed!
The debug-me protocol is designed to prevent such conflicts of opinion.
-The user only processes a new Activity Entered when it meets one of these
+The user only accepts a new Activity Entered when it meets one of these
requirements:
1. The Activity Entered has as its prevActivity the last Activity
- (Entered or Seen) that the user processed.
+ (Entered or Seen) that the user accepted.
2. The Activity Entered has as its prevActivity an older Activity
- that the user processed, and its echoData matches the concacenation
+ that the user accepted, and its echoData matches the concacenation
of every Activity Seen after the prevActivity, up to the most recent
Activity Seen.
(This allows the developer to enter a command quickly without waiting
for each letter to echo back to them.)
+An Activity Entered must also have as its prevEntered field the hash of
+the last Activity Entered that was accepted, unless there have been none yet.
+
When an Activity Entered does not meet these rules, the user sends
-it back in a Rejected message to let the developer know the input was not
+back a EnteredRejected message to let the developer know the input was not
allowed.
The developer also checks the prevActivity of Activity Seen messages it
@@ -70,19 +72,27 @@ messages. The developer accepts a new Activity Seen when either:
that the developer generated, after the last Activity Seen
that the developer accepted.
-At the start of the debug-me session, Ed25519 session key pairs are
-generated by both the user and the developer. The first message
-in the protocol is the user sending their session pubic key
-in a Control message containing a SessionKey.
+(The developer does not check the prevEntered field of Activity Seen,
+however, the user should set it. When there are multiple developers,
+this helps one developer know when the user has accepted an Activity
+Entered from another developer.)
+
+## session startup
+
+At the start of the debug-me session, an Ed25519 session key pair are
+generated by the user. The first message in the protocol is the user
+sending their session pubic key in a Control message containing their
+SessionKey. The second message is an Activity Seen.
-Before the developer can enter anything, they must send a SessionKey message
-with their session key, and it must be accepted by the user. The developer
-must have a gpg private key, which is used to sign their session key.
-(The user may have a gpg private key, which may sign their session key
-if available, but this is optional.) The user will reject session keys
-that are not signed by a gpg key or when the gpg key is not one they
-trust. The user sends a SessionKeyAccepted/SessionKeyRejected control
-message to indicate if they accepted the developer's key or not.
+The developer also has a Ed25519 session key pair. Before the developer can
+enter anything, they must send a SessionKey message with their session key,
+and it must be accepted by the user. The developer must have a gpg private
+key, which is used to sign their session key. (The user may have a gpg
+private key, which may sign their session key if available, but this is
+optional.) The user will reject session keys that are not signed by a gpg
+key or when the gpg key is not one they trust. The user sends a
+SessionKeyAccepted/SessionKeyRejected control message to indicate if they
+accepted the developer's key or not.
Each message in the debug-me session is signed by the party that sends it,
using their session key. The hash of a message includes its signature, so
@@ -93,7 +103,7 @@ Note that there could be multiple developers, in which case each will
send their session key before being able to do anything except observe
the debug-me session.
-The prevActivity hash is actually not included in the data sent across the
-wire. It's left out to save space, and gets added back in by the receiver.
-The receiver uses the signature of the message to tell when it's found
-the right prevActivity hash to add back in.
+The prevActivity and prevEntered hashes are actually not included in the
+data sent across the wire. They are left out to save space, and get
+added back in by the receiver. The receiver uses the signature of the
+message to tell when it's found the right hashes to add back in.