From 686dcc8b172b77e3e612ba4badbb88879d0f5599 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 27 Apr 2017 15:26:50 -0400 Subject: Leave the prevMessage out of Activity serialization to save BW. Do include it in the data that gets signed, so it can be recovered by trying each likely (recently seen) Activity as the prevMessage, and checking the signature. The UserState and DeveloperState already had the necessary state about recently seen hashes, so this does not impact data use. One tricky bit is that relayFromSocket needs to wait for the TMChan to be empty before calling restorePrevActivityHash. Otherwise, the hashes of items in the channel that have not been processed yet won't be tried. The TMChan is not really being used as a channel since only 1 item can be in it. It could be converted to a TMVar, but closeTMChan is used so I left it as a channel. Note that the server does not restore hashes of messages that pass through it; it's just a dumb relay. Sending a single key press now only needs 94 bytes of data to be sent, down from 169! --- Also switched to SHA512, since hashes are no longer being sent over the wire and so the larger size does not matter. SHA512 is slightly faster and more secure. This commit was sponsored by Ewen McNeill. --- Hash.hs | 8 +++--- PrevActivity.hs | 43 +++++++++++++++++++++++++++++++++ ProtocolBuffers.hs | 30 +++-------------------- Role/Developer.hs | 71 ++++++++++++++++++++++++++++++++++++++---------------- Role/Downloader.hs | 8 +++--- Role/User.hs | 20 ++++++++++++--- Role/Watcher.hs | 8 +++--- Server.hs | 15 +++++++----- TODO | 6 ----- Types.hs | 8 +++--- WebSockets.hs | 25 ++++++++++++++----- debug-me.cabal | 1 + protocol.txt | 7 +++++- 13 files changed, 165 insertions(+), 85 deletions(-) create mode 100644 PrevActivity.hs diff --git a/Hash.hs b/Hash.hs index 3bfb5a2..3cc8d94 100644 --- a/Hash.hs +++ b/Hash.hs @@ -12,8 +12,8 @@ class Hashable a where hash :: a -> Hash instance Hashable B.ByteString where - -- Encodes the SHA256 using base16 format - hash = Hash SHA256 . Val . C8.pack . show . sha256 + -- Encodes the SHA512 using base16 format + hash = Hash SHA512 . Val . C8.pack . show . sha512 instance Hashable Val where hash (Val v) = hash v @@ -21,8 +21,8 @@ instance Hashable Val where instance Hashable Hash where hash = id -sha256 :: B.ByteString -> H.Digest H.SHA256 -sha256 = H.hash +sha512 :: B.ByteString -> H.Digest H.SHA512 +sha512 = H.hash -- | A value tagged with a ByteString describing the type of value. -- This is hashed by hashing the concacenation of the hash of the diff --git a/PrevActivity.hs b/PrevActivity.hs new file mode 100644 index 0000000..32e647d --- /dev/null +++ b/PrevActivity.hs @@ -0,0 +1,43 @@ +module PrevActivity where + +import Types +import Crypto + +import Control.Concurrent.STM + +-- | Remove the prevActivity from a message. Doing this before sending +-- it over the wire saves transmitting that data, without weakening +-- security at all. +removePrevActivityHash :: AnyMessage -> AnyMessage +removePrevActivityHash msg = case msg of + User (ActivityMessage a) -> User (go a) + Developer (ActivityMessage a) -> Developer (go a) + _ -> msg + where + go a = ActivityMessage $ a { prevActivity = Nothing } + +type RecentActivity = STM (SigVerifier, [Hash]) + +noRecentActivity :: RecentActivity +noRecentActivity = return (mempty, []) + +-- | Restore the prevActivity to a message received without one. +-- This needs a RecentActivity cache, and it tries hashes from that cache +-- as the prevActivity until it finds one that makes the message's +-- signature verify. +restorePrevActivityHash :: RecentActivity -> AnyMessage -> STM AnyMessage +restorePrevActivityHash ra msg = case msg of + User (ActivityMessage act) -> + User . ActivityMessage <$> (go act =<< ra) + Developer (ActivityMessage act) -> + Developer . ActivityMessage <$> (go act =<< ra) + 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) diff --git a/ProtocolBuffers.hs b/ProtocolBuffers.hs index 6d02096..53dfca0 100644 --- a/ProtocolBuffers.hs +++ b/ProtocolBuffers.hs @@ -40,7 +40,9 @@ data MessageP a data ActivityP a = ActivityP { activityP :: Required 6 (Message a) - , prevAtivityP :: Optional 7 (Message HashP) + -- 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,12 +65,6 @@ data ControlActionP { sessionKeyRejectedP :: Required 15 (Message PublicKeyP) } deriving (Generic) -data HashP = HashP - { hashMethodP :: Required 16 (Value B.ByteString) - , hashValueP :: Required 17 (Value B.ByteString) - } - deriving (Generic) - data SignatureP = Ed25519SignatureP { ed25519SignatureP :: Required 18 (Value B.ByteString) } @@ -141,13 +137,12 @@ instance ProtocolBuffer (ActivityP p) (T.Activity t) => ProtocolBuffer (MessageP instance ProtocolBuffer p t => ProtocolBuffer (ActivityP p) (T.Activity t) where toProtocolBuffer t = ActivityP { activityP = putField $ toProtocolBuffer $ T.activity t - , prevAtivityP = putField $ fmap toProtocolBuffer $ T.prevActivity t , elapsedTimeP = putField $ toProtocolBuffer $ T.elapsedTime t , activitySignatureP = putField $ toProtocolBuffer $ T.activitySignature t } fromProtocolBuffer p = T.Activity { T.activity = fromProtocolBuffer $ getField $ activityP p - , T.prevActivity = fmap fromProtocolBuffer $ getField $ prevAtivityP p + , T.prevActivity = Nothing -- not sent over the wire , T.elapsedTime = fromProtocolBuffer $ getField $ elapsedTimeP p , T.activitySignature = fromProtocolBuffer $ getField $ activitySignatureP p } @@ -180,21 +175,6 @@ instance ProtocolBuffer ControlActionP T.ControlAction where fromProtocolBuffer p@(SessionKeyRejectedP {}) = T.SessionKeyRejected $ fromProtocolBuffer $ getField $ sessionKeyRejectedP p -instance ProtocolBuffer HashP T.Hash where - toProtocolBuffer t = HashP - { hashMethodP = putField $ case T.hashMethod t of - T.SHA256 -> "2" - T.SHA3 -> "3" - , hashValueP = putField $ val $ T.hashValue t - } - fromProtocolBuffer p = T.Hash - { T.hashMethod = case getField (hashMethodP p) of - "2" -> T.SHA256 - "3" -> T.SHA3 - _ -> T.SHA256 - , T.hashValue = Val $ getField $ hashValueP p - } - instance ProtocolBuffer SignatureP T.Signature where toProtocolBuffer (T.Ed25519Signature t) = Ed25519SignatureP { ed25519SignatureP = putField $ val t } @@ -252,8 +232,6 @@ instance Encode ControlP instance Decode ControlP instance Encode ControlActionP instance Decode ControlActionP -instance Encode HashP -instance Decode HashP instance Encode SignatureP instance Decode SignatureP instance Encode PublicKeyP diff --git a/Role/Developer.hs b/Role/Developer.hs index b0d66a5..9e1f40e 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -1,6 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -module Role.Developer where +module Role.Developer ( + run, + run', + processSessionStart, + getServerMessage, + Output(..), + emitOutput, + DeveloperState, +) where import Types import Hash @@ -10,6 +18,7 @@ import CmdLine import WebSockets import SessionID import Pty +import PrevActivity import Control.Concurrent.Async import Control.Concurrent.STM @@ -20,20 +29,25 @@ import qualified Data.Text as T import Data.List import Data.Maybe import Control.Monad +import Data.Monoid import Data.Time.Clock.POSIX run :: DeveloperOpts -> IO () run = run' developer . debugUrl -run' :: (TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> UrlString -> IO () -run' runner url = void $ runClientApp app - where - connect = ConnectMode (T.pack url) - app = clientApp connect Developer Just runner +run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> UrlString -> IO () +run' runner url = do + app <- do + let connect = ConnectMode (T.pack url) + dsv <- newEmptyTMVarIO + let recentactivity = developerStateRecentActivity dsv + return $ clientApp connect recentactivity Developer Just $ + runner dsv + void $ runClientApp app -developer :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () -developer ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do - (devstate, startoutput) <- processSessionStart ochan logger +developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +developer dsv ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do + (devstate, startoutput) <- processSessionStart ochan logger dsv emitOutput startoutput ok <- authUser ichan ochan devstate logger if ok @@ -63,6 +77,16 @@ data DeveloperState = DeveloperState -- ^ Used to verify signatures on messages from other developers. } +-- | RecentActivity that uses the DeveloperState. +developerStateRecentActivity :: TMVar (TVar DeveloperState) -> RecentActivity +developerStateRecentActivity dsv = go =<< tryReadTMVar dsv + where + go Nothing = noRecentActivity + go (Just ds) = do + st <- readTVar ds + let hs = lastSeen st : enteredSince st ++ fromOtherDevelopersSince st + return (userSigVerifier st <> developerSigVerifier st, hs) + -- | Read things typed by the developer, and forward them to the TMChan. sendTtyInput :: TMChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () sendTtyInput ichan devstate logger = go @@ -287,8 +311,8 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _) ds ts -- | Start by reading the initial two messages from the user, -- their session key and the startup message. -processSessionStart :: TMChan AnyMessage -> Logger -> IO (TVar DeveloperState, Output) -processSessionStart ochan logger = do +processSessionStart :: TMChan AnyMessage -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output) +processSessionStart ochan logger dsv = do sessionmsg <- fromMaybe (error "Did not get session initialization message") <$> atomically (readTMChan ochan) logger sessionmsg @@ -302,25 +326,30 @@ processSessionStart ochan logger = do then return sv else error "Badly signed session initialization message" _ -> error $ "Unexpected session initialization message: " ++ show sessionmsg - startmsg <- fromMaybe (error "Did not get session startup message") - <$> atomically (readTMChan ochan) - logger startmsg - let (starthash, output) = case startmsg of - User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _ _)) - | verifySigned sigverifier act -> - (hash act, TtyOutput b) - _ -> error $ "Unexpected startup message: " ++ show startmsg sk <- genMySessionKey ts <- getPOSIXTime st <- newTVarIO $ DeveloperState - { lastSeen = starthash + { lastSeen = hash () , sentSince = mempty , enteredSince = mempty - , lastActivity = starthash + , lastActivity = hash () , lastActivityTs = ts , fromOtherDevelopersSince = mempty , developerSessionKey = sk , userSigVerifier = sigverifier , developerSigVerifier = mempty } + atomically $ putTMVar dsv st + startmsg <- fromMaybe (error "Did not get session startup message") + <$> atomically (readTMChan ochan) + logger startmsg + let (starthash, output) = case startmsg of + User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _ _)) + | verifySigned sigverifier act -> + (hash act, TtyOutput b) + _ -> error $ "Unexpected startup message: " ++ show startmsg + atomically $ modifyTVar' st $ \ds -> ds + { lastSeen = starthash + , lastActivity = starthash + } return (st, output) diff --git a/Role/Downloader.hs b/Role/Downloader.hs index d49b4ec..4d5f6cc 100644 --- a/Role/Downloader.hs +++ b/Role/Downloader.hs @@ -4,7 +4,7 @@ import Types import Log import CmdLine import SessionID -import Role.Developer (run', processSessionStart, getServerMessage, Output(..)) +import Role.Developer import Control.Concurrent.STM import Control.Concurrent.STM.TMChan @@ -13,13 +13,13 @@ import Data.Time.Clock.POSIX run :: DownloadOpts -> IO () run = run' downloader . downloadUrl -downloader :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () -downloader _ichan ochan sid = do +downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +downloader dsv _ichan ochan sid = do let logfile = sessionLogFile "." sid putStrLn $ "Starting download to " ++ logfile putStrLn "(Will keep downloading until the debug-me session is done.)" withLogger logfile $ \logger -> do - (st, _startoutput) <- processSessionStart ochan logger + (st, _startoutput) <- processSessionStart ochan logger dsv go logger st where go logger st = do diff --git a/Role/User.hs b/Role/User.hs index e0599a8..fe679a5 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -11,6 +11,7 @@ import Crypto import CmdLine import WebSockets import SessionID +import PrevActivity import Control.Concurrent.Async import Control.Concurrent.STM @@ -31,17 +32,20 @@ run os = fromMaybe (ExitFailure 101) <$> connect connect = do putStr "Connecting to debug-me server..." hFlush stdout - runClientApp $ clientApp (InitMode mempty) User developerMessages $ \ochan ichan sid -> do + usv <- newEmptyTMVarIO + let recentactivity = userStateRecentActivity usv + runClientApp $ clientApp (InitMode mempty) recentactivity User developerMessages $ \ochan ichan sid -> do let url = sessionIDUrl sid "localhost" 8081 putStrLn "" putStrLn "Others can connect to this session and help you debug by running:" putStrLn $ " debug-me --debug " ++ url hFlush stdout - withLogger "debug-me.log" $ go ochan ichan - go ochan ichan logger = do + withLogger "debug-me.log" $ go ochan ichan usv + go ochan ichan usv logger = do (cmd, cmdparams) <- shellCommand os runWithPty cmd cmdparams $ \(p, ph) -> do us <- startProtocol startSession ochan logger + atomically $ putTMVar usv us p1 <- async $ sendPtyOutput p ochan us logger p2 <- async $ sendPtyInput ichan ochan p us logger `race` forwardTtyInputToPty p @@ -73,6 +77,16 @@ data UserState = UserState , lastSeenTs :: POSIXTime } +-- | RecentActivity that uses the UserState. +userStateRecentActivity :: TMVar (TVar UserState) -> RecentActivity +userStateRecentActivity usv = go =<< tryReadTMVar usv + where + go Nothing = noRecentActivity + go (Just us) = do + st <- readTVar us + let hs = mapMaybe loggedHash $ toList $ backLog st + return (sigVerifier st, hs) + -- | Start by establishing our session key, and displaying the starttxt. startProtocol :: B.ByteString -> TMChan (Message Seen) -> Logger -> IO (TVar UserState) startProtocol starttxt ochan logger = do diff --git a/Role/Watcher.hs b/Role/Watcher.hs index 8bcc91c..a4328f8 100644 --- a/Role/Watcher.hs +++ b/Role/Watcher.hs @@ -5,7 +5,7 @@ import Log import Pty import CmdLine import SessionID -import Role.Developer (run', processSessionStart, getServerMessage, emitOutput) +import Role.Developer import Control.Concurrent.STM import Control.Concurrent.STM.TMChan @@ -14,9 +14,9 @@ import Data.Time.Clock.POSIX run :: WatchOpts -> IO () run = run' watcher . watchUrl -watcher :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () -watcher _ichan ochan _ = inRawMode $ do - (st, startoutput) <- processSessionStart ochan nullLogger +watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +watcher dsv _ichan ochan _ = inRawMode $ do + (st, startoutput) <- processSessionStart ochan nullLogger dsv emitOutput startoutput go st where diff --git a/Server.hs b/Server.hs index 62d0a3c..f8e8588 100644 --- a/Server.hs +++ b/Server.hs @@ -7,6 +7,7 @@ import CmdLine import WebSockets import SessionID import Log +import PrevActivity import Network.Wai import Network.Wai.Handler.Warp @@ -144,7 +145,7 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do -- (The user is allowed to send Developer messages too.. perhaps -- they got them from a developer connected to them some other -- way.) - relayfromuser session = relayFromSocket conn $ \msg -> do + relayfromuser session = relayFromSocket conn noRecentActivity (return ()) $ \msg -> do l <- mkLog msg <$> getPOSIXTime writeSession session l @@ -183,11 +184,13 @@ developer o ssv sid conn = bracket setup cleanup go -- Relay all Developer amessages from the developer's websocket -- to the broadcast channel. - relayfromdeveloper session = relayFromSocket conn $ \msg -> case msg of - Developer _ -> do - l <- mkLog msg <$> getPOSIXTime - writeSession session l - User _ -> return () -- developer cannot send User messages + relayfromdeveloper session = relayFromSocket conn noRecentActivity (return ()) + $ \msg -> case msg of + Developer _ -> do + l <- mkLog msg <$> getPOSIXTime + writeSession session l + -- developer cannot send User messages + User _ -> return () -- Relay user messages from the developer's clone of the -- broadcast channel to the developer's websocket. diff --git a/TODO b/TODO index 0d98317..5a070da 100644 --- a/TODO +++ b/TODO @@ -21,12 +21,6 @@ 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. -* Leave the prevMessage out of Activity serialization to save BW. - Do include it in the data that gets signed, so it can be recovered - by trying each likely (recently seen) Activity as the prevMessage, and - checking the signature. - (If doing this, might as well switch to SHA512, since hash size does not - matter.) * loadLog should verify the hashes (and signatures) in the log, and refuse to use logs that are not valid proofs of a session. (--replay and --graphvis need this; server's use of loadLog does not) diff --git a/Types.hs b/Types.hs index 18b197e..1335cdc 100644 --- a/Types.hs +++ b/Types.hs @@ -55,7 +55,7 @@ instance DataSize a => DataSize (Message a) where -- -- The Signature is over both the data in the activity, and its pointer. -- --- Note that the Signature is included in the Hash of an Activity, +-- The Signature is included in the Hash of an Activity, -- which is why it's part of the Activity. data Activity a = Activity { activity :: a @@ -107,12 +107,12 @@ data Hash = Hash deriving (Show, Generic, Eq) instance DataSize Hash where - dataSize (Hash { hashMethod = SHA256 }) = 64 + dataSize (Hash { hashMethod = SHA512 }) = 128 dataSize (Hash { hashMethod = SHA3 }) = 56 --- | We use SHA256. (SHA3 is included to future proof, and because it +-- | We use SHA512. (SHA3 is included to future proof, and because it -- improves the generated JSON.) -data HashMethod = SHA256 | SHA3 +data HashMethod = SHA512 | SHA3 deriving (Show, Generic, Eq) data Signature diff --git a/WebSockets.hs b/WebSockets.hs index f159271..00f762a 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -18,6 +18,7 @@ module WebSockets ( import Types import SessionID import ProtocolBuffers +import PrevActivity import Network.WebSockets hiding (Message) import Control.Concurrent.STM @@ -62,11 +63,12 @@ runClientApp app = do -- | Make a client that sends and receives AnyMessages over a websocket. clientApp :: Mode + -> RecentActivity -> (sent -> AnyMessage) -> (AnyMessage -> Maybe received) -> (TMChan sent -> TMChan received -> SessionID -> IO a) -> ClientApp a -clientApp mode mksent filterreceived a conn = do +clientApp mode recentactivity mksent filterreceived a conn = do -- Ping every 30 seconds to avoid timeouts caused by proxies etc. forkPingThread conn 30 _v <- negotiateWireVersion conn @@ -83,7 +85,7 @@ clientApp mode mksent filterreceived a conn = do sthread <- async $ relayToSocket conn mksent $ atomically (readTMChan schan) rthread <- async $ do - relayFromSocket conn $ \v -> do + relayFromSocket conn recentactivity (waitTillDrained rchan) $ \v -> do case filterreceived v of Nothing -> return () Just r -> atomically $ writeTMChan rchan r @@ -101,14 +103,24 @@ clientApp mode mksent filterreceived a conn = do void $ waitCatch rthread go sid (schan, rchan, _, _) = a schan rchan sid -relayFromSocket :: Connection -> (AnyMessage -> IO ()) -> IO () -relayFromSocket conn sender = go +waitTillDrained :: TMChan a -> IO () +waitTillDrained c = atomically $ do + e <- isEmptyTMChan c + if e + then return () + else retry + +relayFromSocket :: Connection -> RecentActivity -> IO () -> (AnyMessage -> IO ()) -> IO () +relayFromSocket conn recentactivity waitprevprocessed sender = go where go = do r <- receiveData conn case r of AnyMessage msg -> do - sender msg + waitprevprocessed + msg' <- atomically $ + restorePrevActivityHash recentactivity msg + sender msg' go Done -> return () WireProtocolError e -> protocolError conn e @@ -122,7 +134,8 @@ relayToSocket conn mksent getter = go case mmsg of Nothing -> return () Just msg -> do - sendBinaryData conn $ AnyMessage $ mksent msg + sendBinaryData conn $ AnyMessage $ + removePrevActivityHash $ mksent msg go -- | Framing protocol used over a websocket connection. diff --git a/debug-me.cabal b/debug-me.cabal index 70ea2ac..48d391a 100644 --- a/debug-me.cabal +++ b/debug-me.cabal @@ -61,6 +61,7 @@ Executable debug-me Log Memory Pty + PrevActivity ProtocolBuffers Replay Role.Developer diff --git a/protocol.txt b/protocol.txt index 25f239d..d290be7 100644 --- a/protocol.txt +++ b/protocol.txt @@ -21,7 +21,7 @@ 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. -(The exact details about how these objects are hashed is not described here; +(The exact details about how 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.) @@ -88,3 +88,8 @@ before it, etc. 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. -- cgit v1.2.3