From b47e621749257331788e82e44d1565cf4d32d04b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 30 Apr 2017 13:54:02 -0400 Subject: fix probable race in use of restoreHashes I think there was a race where a SessionKey message had been drained from the TChan, but not yet added to the developer state, which was resonsible for recent instability at startup. It manifested as protocol errors where the prevActivity hash was wrongly Nothing. Fixed by adding a MissingHashes type to tag things whose hashes have been stripped, and adding back the hashes when needed, which always happens inside atomically blocks, so won't have such a race. --- PrevActivity.hs | 19 ++++------ Role/Developer.hs | 108 ++++++++++++++++++++++++++--------------------------- Role/Downloader.hs | 2 +- Role/User.hs | 25 ++++++------- Role/Watcher.hs | 2 +- Server.hs | 5 +-- TODO | 3 -- Types.hs | 4 ++ WebSockets.hs | 30 +++++---------- 9 files changed, 91 insertions(+), 107 deletions(-) diff --git a/PrevActivity.hs b/PrevActivity.hs index 32e647d..7c5e808 100644 --- a/PrevActivity.hs +++ b/PrevActivity.hs @@ -5,11 +5,11 @@ import Crypto import Control.Concurrent.STM --- | Remove the prevActivity from a message. Doing this before sending +-- | Remove the hashes 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 +removeHashes :: AnyMessage -> MissingHashes AnyMessage +removeHashes msg = MissingHashes $ case msg of User (ActivityMessage a) -> User (go a) Developer (ActivityMessage a) -> Developer (go a) _ -> msg @@ -18,15 +18,12 @@ removePrevActivityHash msg = case msg of type RecentActivity = STM (SigVerifier, [Hash]) -noRecentActivity :: RecentActivity -noRecentActivity = return (mempty, []) - --- | Restore the prevActivity to a message received without one. +-- | Restore the hashes to a message received. -- 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 +-- to find the one that was used when the message was sent, at which +-- 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) Developer (ActivityMessage act) -> diff --git a/Role/Developer.hs b/Role/Developer.hs index 56af3b4..6763e1a 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -40,17 +40,15 @@ import Network.URI run :: DeveloperOpts -> IO () run = run' developer . debugUrl -run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> URI -> IO () +run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO ()) -> URI -> IO () run' runner url = do app <- do let connect = ConnectMode $ T.pack $ show url dsv <- newEmptyTMVarIO - let recentactivity = developerStateRecentActivity dsv - return $ clientApp connect recentactivity Developer Just $ - runner dsv + return $ clientApp connect Developer Just $ runner dsv void $ runClientApp app -developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO () developer dsv ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger -> do sk <- genMySessionKey (controlinput, controloutput) <- openControlWindow @@ -82,7 +80,7 @@ developer dsv ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger go _ _ _ _ SessionEnded = hPutStrLn stderr "\r\n** This debug-me session has already ended.\r" -watchSessionReadOnly :: TMChan AnyMessage -> Logger -> TVar DeveloperState -> IO () +watchSessionReadOnly :: TMChan (MissingHashes AnyMessage) -> Logger -> TVar DeveloperState -> IO () watchSessionReadOnly ochan logger st = loop where loop = do @@ -118,14 +116,11 @@ data DeveloperState = DeveloperState deriving (Show) -- | 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) +developerStateRecentActivity :: TVar DeveloperState -> RecentActivity +developerStateRecentActivity devstate = do + st <- readTVar devstate + 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 () @@ -185,7 +180,7 @@ sendControlOutput controloutput ichan devstate logger = loop -- | Read activity from the TMChan and display it to the developer. -- -- Control messages are forwarded on to the ControlInput. -sendTtyOutput :: TMChan AnyMessage -> TVar DeveloperState -> TMChan ControlInput -> Logger -> IO () +sendTtyOutput :: TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> TMChan ControlInput -> Logger -> IO () sendTtyOutput ochan devstate controlinput logger = go where go = do @@ -214,7 +209,7 @@ data AuthResult = Authed | AuthFailed | SessionEnded -- | Present our session key to the user. -- Wait for them to accept or reject it, while displaying any Seen data -- in the meantime. -authUser :: PerhapsSigned PublicKey -> TMChan (Message Entered) -> TMChan AnyMessage -> TVar DeveloperState -> Logger -> IO AuthResult +authUser :: PerhapsSigned PublicKey -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> Logger -> IO AuthResult authUser spk ichan ochan devstate logger = do ds <- atomically $ readTVar devstate let msg = ControlMessage $ mkSigned (developerSessionKey ds) @@ -263,44 +258,49 @@ emitOutput NoOutput = -- | Get messages from server, check their signature, and make sure that they -- are properly chained from past messages, before returning. -getServerMessage :: TMChan AnyMessage -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, AnyMessage)) +getServerMessage :: TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, AnyMessage)) getServerMessage ochan devstate ts = do - let ignore = getServerMessage ochan devstate ts - mmsg <- readTMChan ochan - case mmsg of + mwiremsg <- readTMChan ochan + case mwiremsg of Nothing -> return Nothing - Just (User msg) -> do - ds <- readTVar devstate - -- Check user's signature before doing anything else. - if verifySigned (userSigVerifier ds) msg - then do - o <- processuser ds msg - return (Just (o, User msg)) - else return $ Just (ProtocolError ds $ "Bad signature on message from user: " ++ show msg, User msg) - -- When other developers connect, learn their SessionKeys. - Just (Developer msg@(ControlMessage (Control (SessionKey spk) _))) -> do - let sigverifier = mkSigVerifier $ case spk of - GpgSigned pk _ -> pk - UnSigned pk -> pk - if verifySigned sigverifier msg - then do - ds <- readTVar devstate - let sv = developerSigVerifier ds - let sv' = sv `mappend` sigverifier - writeTVar devstate $ ds - { developerSigVerifier = sv' - } - processdeveloper ds msg - return (Just (NoOutput, Developer msg)) - else ignore - Just (Developer msg) -> do - ds <- readTVar devstate - if verifySigned (developerSigVerifier ds) msg - then do - processdeveloper ds msg - return (Just (NoOutput, Developer msg)) - else ignore + Just msg -> process =<< restoreHashes recentactivity msg where + recentactivity = developerStateRecentActivity devstate + + process (User msg) = do + ds <- readTVar devstate + -- Check user's signature before doing anything else. + if verifySigned (userSigVerifier ds) msg + then do + o <- processuser ds msg + return (Just (o, User msg)) + else return $ Just (ProtocolError ds $ "Bad signature on message from user: " ++ show msg, User msg) + -- When other developers connect, learn their SessionKeys. + process (Developer msg@(ControlMessage (Control (SessionKey spk) _))) = do + let sigverifier = mkSigVerifier $ case spk of + GpgSigned pk _ -> pk + UnSigned pk -> pk + if verifySigned sigverifier msg + then do + ds <- readTVar devstate + let sv = developerSigVerifier ds + let sv' = sv `mappend` sigverifier + writeTVar devstate $ ds + { developerSigVerifier = sv' + } + processdeveloper ds msg + return (Just (NoOutput, Developer msg)) + else ignore + process (Developer msg) = do + ds <- readTVar devstate + if verifySigned (developerSigVerifier ds) msg + then do + processdeveloper ds msg + return (Just (NoOutput, Developer msg)) + else ignore + + ignore = getServerMessage ochan devstate ts + processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _ _)) = do let (legal, ds') = isLegalSeen act ds ts if legal @@ -385,9 +385,9 @@ 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 :: MySessionKey -> TMChan AnyMessage -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output) +processSessionStart :: MySessionKey -> TMChan (MissingHashes AnyMessage) -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output) processSessionStart sk ochan logger dsv = do - sessionmsg <- fromMaybe (error "Did not get session initialization message") + MissingHashes sessionmsg <- fromMaybe (error "Did not get session initialization message") <$> atomically (readTMChan ochan) logger sessionmsg sigverifier <- case sessionmsg of @@ -413,7 +413,7 @@ processSessionStart sk ochan logger dsv = do , developerSigVerifier = mempty } atomically $ putTMVar dsv st - startmsg <- fromMaybe (error "Did not get session startup message") + MissingHashes startmsg <- fromMaybe (error "Did not get session startup message") <$> atomically (readTMChan ochan) logger startmsg let (starthash, output) = case startmsg of diff --git a/Role/Downloader.hs b/Role/Downloader.hs index 094e7de..d013344 100644 --- a/Role/Downloader.hs +++ b/Role/Downloader.hs @@ -14,7 +14,7 @@ import Data.Time.Clock.POSIX run :: DownloadOpts -> IO () run = run' downloader . downloadUrl -downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO () downloader dsv _ichan ochan sid = do let logfile = sessionLogFile "." sid putStrLn $ "Starting download to " ++ logfile diff --git a/Role/User.hs b/Role/User.hs index 1e842d0..e999b1c 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -37,8 +37,7 @@ run os = fromMaybe (ExitFailure 101) <$> connect putStr "Connecting to debug-me server..." hFlush stdout usv <- newEmptyTMVarIO - let recentactivity = userStateRecentActivity usv - runClientApp $ clientApp (InitMode mempty) recentactivity User developerMessages $ \ochan ichan sid -> do + runClientApp $ clientApp (InitMode mempty) 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:" @@ -89,14 +88,11 @@ data UserState = UserState } -- | 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) +userStateRecentActivity :: TVar UserState -> RecentActivity +userStateRecentActivity 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) @@ -189,7 +185,7 @@ instance SendableToDeveloper ControlAction where -- | Read things to be entered from the TMChan, verify if they're legal, -- and send them to the Pty. Also handles control messages from the -- developer. -sendPtyInput :: TMChan (Message Entered) -> TMChan (Message Seen) -> TMChan ControlInput -> Pty -> TVar UserState -> Logger -> IO () +sendPtyInput :: TMChan (MissingHashes (Message Entered)) -> TMChan (Message Seen) -> TMChan ControlInput -> Pty -> TVar UserState -> Logger -> IO () sendPtyInput ichan ochan controlinput p us logger = go where go = do @@ -220,15 +216,16 @@ data Input -- signature of the message is only verified against the key in it), and -- make sure it's legal before returning it. If it's not legal, sends a -- Reject message. -getDeveloperMessage :: TMChan (Message Entered) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM (Maybe Input) +getDeveloperMessage :: TMChan (MissingHashes (Message Entered)) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM (Maybe Input) getDeveloperMessage ichan ochan us now = maybe (return Nothing) (\msg -> Just <$> getDeveloperMessage' msg ochan us now) =<< readTMChan ichan -getDeveloperMessage' :: Message Entered -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input -getDeveloperMessage' msg ochan us now = do +getDeveloperMessage' :: MissingHashes (Message Entered) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input +getDeveloperMessage' (MissingHashes wiremsg) ochan us now = do st <- readTVar us + Developer msg <- restoreHashes (userStateRecentActivity us) (MissingHashes (Developer wiremsg)) case msg of ControlMessage (Control (SessionKey spk) _) -> do let sigverifier = mkSigVerifier $ case spk of diff --git a/Role/Watcher.hs b/Role/Watcher.hs index 0867da1..8ed59d5 100644 --- a/Role/Watcher.hs +++ b/Role/Watcher.hs @@ -14,7 +14,7 @@ import Control.Concurrent.STM.TMChan run :: WatchOpts -> IO () run = run' watcher . watchUrl -watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () +watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO () watcher dsv _ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger -> inRawMode $ do sk <- genMySessionKey (st, startoutput) <- processSessionStart sk ochan logger dsv diff --git a/Server.hs b/Server.hs index b9f46dd..deafe41 100644 --- a/Server.hs +++ b/Server.hs @@ -7,7 +7,6 @@ import CmdLine import WebSockets import SessionID import Log -import PrevActivity import Network.Wai import Network.Wai.Handler.Warp @@ -145,7 +144,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 mytid session = relayFromSocket conn noRecentActivity (return ()) $ \msg -> do + relayfromuser mytid session = relayFromSocket conn $ \msg -> do l <- mkLog msg <$> getPOSIXTime writeSession mytid session l @@ -184,7 +183,7 @@ developer o ssv sid conn = bracket setup cleanup go -- Relay all Developer amessages from the developer's websocket -- to the broadcast channel. - relayfromdeveloper mytid session = relayFromSocket conn noRecentActivity (return ()) + relayfromdeveloper mytid session = relayFromSocket conn $ \msg -> case msg of Developer _ -> do l <- mkLog msg <$> getPOSIXTime diff --git a/TODO b/TODO index 50bd348..6975aff 100644 --- a/TODO +++ b/TODO @@ -1,6 +1,3 @@ -* Multiple --downloads at the same time or close together fail - with "thread blocked indefinitely in an STM transaction" - Also see it occasionally when connecting with what was --debug. * 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 diff --git a/Types.hs b/Types.hs index 78c59a2..7622f6a 100644 --- a/Types.hs +++ b/Types.hs @@ -64,6 +64,10 @@ data Activity a = Activity } deriving (Show, Generic) +-- | Used when a value has had its hashes erased for more efficient +-- transfer over the wire. +data MissingHashes a = MissingHashes a + instance DataSize a => DataSize (Activity a) where dataSize a = dataSize (activity a) + maybe 0 dataSize (prevActivity a) diff --git a/WebSockets.hs b/WebSockets.hs index 7cb140b..bbf21e3 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -63,12 +63,11 @@ 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) + -> (TMChan sent -> TMChan (MissingHashes received) -> SessionID -> IO a) -> ClientApp a -clientApp mode recentactivity mksent filterreceived a conn = do +clientApp mode mksent filterreceived a conn = do -- Ping every 30 seconds to avoid timeouts caused by proxies etc. forkPingThread conn 30 _v <- negotiateWireVersion conn @@ -85,10 +84,10 @@ clientApp mode recentactivity mksent filterreceived a conn = do sthread <- async $ relayToSocket conn mksent $ atomically (readTMChan schan) rthread <- async $ do - relayFromSocket conn recentactivity (waitTillDrained rchan) $ \v -> do + relayFromSocket conn $ \v -> do case filterreceived v of Nothing -> return () - Just r -> atomically $ writeTMChan rchan r + Just r -> atomically $ writeTMChan rchan (MissingHashes r) -- Server sent Done, so close channels. atomically $ do closeTMChan schan @@ -104,24 +103,14 @@ clientApp mode recentactivity mksent filterreceived a conn = do void $ waitCatch rthread go sid (schan, rchan, _, _) = a schan rchan sid -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 +relayFromSocket :: Connection -> (AnyMessage -> IO ()) -> IO () +relayFromSocket conn sender = go where go = do r <- receiveData conn case r of AnyMessage msg -> do - waitprevprocessed - msg' <- atomically $ - restorePrevActivityHash recentactivity msg - sender msg' + sender msg go Done -> return () WireProtocolError e -> protocolError conn e @@ -135,8 +124,9 @@ relayToSocket conn mksent getter = go case mmsg of Nothing -> return () Just msg -> do - sendBinaryData conn $ AnyMessage $ - removePrevActivityHash $ mksent msg + let MissingHashes wiremsg = + removeHashes $ mksent msg + sendBinaryData conn $ AnyMessage wiremsg go -- | Framing protocol used over a websocket connection. -- cgit v1.2.3