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. --- Role/Developer.hs | 71 ++++++++++++++++++++++++++++++++++++++---------------- Role/Downloader.hs | 8 +++--- Role/User.hs | 20 ++++++++++++--- Role/Watcher.hs | 8 +++--- 4 files changed, 75 insertions(+), 32 deletions(-) (limited to 'Role') 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 -- cgit v1.2.3