diff options
-rw-r--r-- | Hash.hs | 8 | ||||
-rw-r--r-- | PrevActivity.hs | 43 | ||||
-rw-r--r-- | ProtocolBuffers.hs | 30 | ||||
-rw-r--r-- | Role/Developer.hs | 71 | ||||
-rw-r--r-- | Role/Downloader.hs | 8 | ||||
-rw-r--r-- | Role/User.hs | 20 | ||||
-rw-r--r-- | Role/Watcher.hs | 8 | ||||
-rw-r--r-- | Server.hs | 15 | ||||
-rw-r--r-- | TODO | 6 | ||||
-rw-r--r-- | Types.hs | 8 | ||||
-rw-r--r-- | WebSockets.hs | 25 | ||||
-rw-r--r-- | debug-me.cabal | 1 | ||||
-rw-r--r-- | protocol.txt | 7 |
13 files changed, 165 insertions, 85 deletions
@@ -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 @@ -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. @@ -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) @@ -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. |