diff options
-rw-r--r-- | Role/Developer.hs | 69 | ||||
-rw-r--r-- | Role/Downloader.hs | 8 | ||||
-rw-r--r-- | Role/Watcher.hs | 6 | ||||
-rw-r--r-- | Server.hs | 45 | ||||
-rw-r--r-- | TODO | 5 | ||||
-rw-r--r-- | protocol.txt | 19 |
6 files changed, 84 insertions, 68 deletions
diff --git a/Role/Developer.hs b/Role/Developer.hs index 1cc5a10..d6cbf2b 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -24,17 +24,13 @@ import Control.Monad run :: DeveloperOpts -> IO () run = run' developer . debugUrl -run' :: (TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO ()) -> UrlString -> IO () +run' :: (TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO ()) -> UrlString -> IO () run' runner url = void $ runClientApp app where connect = ConnectMode (T.pack url) - app = clientApp connect Developer userMessages runner + app = clientApp connect Developer Just runner -userMessages :: LogMessage -> Maybe (Message Seen) -userMessages (User m) = Just m -userMessages (Developer _) = Nothing - -developer :: TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO () +developer :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO () developer ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do (devstate, startoutput) <- processSessionStart ochan logger emitOutput startoutput @@ -90,22 +86,22 @@ sendTtyInput ichan devstate logger = go go -- | Read activity from the TMChan and display it to the developer. -sendTtyOutput :: TMChan (Message Seen) -> TVar DeveloperState -> Logger -> IO () +sendTtyOutput :: TMChan LogMessage -> TVar DeveloperState -> Logger -> IO () sendTtyOutput ochan devstate logger = go where go = do - v <- atomically $ getUserMessage ochan devstate + v <- atomically $ getServerMessage ochan devstate case v of Nothing -> return () - Just (o, msg) -> do - logger $ User msg + Just (o, l) -> do + logger l emitOutput o go -- | Present our session key to the user. -- Wait for them to accept or reject it, while displaying any Seen data -- in the meantime. -authUser :: TMChan (Message Entered) -> TMChan (Message Seen) -> TVar DeveloperState -> Logger -> IO Bool +authUser :: TMChan (Message Entered) -> TMChan LogMessage -> TVar DeveloperState -> Logger -> IO Bool authUser ichan ochan devstate logger = do ds <- atomically $ readTVar devstate pk <- myPublicKey (developerSessionKey ds) @@ -117,8 +113,8 @@ authUser ichan ochan devstate logger = do where waitresp pk = do (o, msg) <- fromMaybe (error "Looks like that debug-me session is over.") - <$> atomically (getUserMessage ochan devstate) - logger $ User msg + <$> atomically (getServerMessage ochan devstate) + logger msg emitOutput o case o of GotControl (SessionKeyAccepted pk') @@ -132,6 +128,7 @@ data Output | Beep | ProtocolError String | GotControl ControlAction + | NoOutput emitOutput :: Output -> IO () emitOutput (ProtocolError e) = @@ -144,31 +141,37 @@ emitOutput Beep = do hFlush stdout emitOutput (GotControl _) = return () +emitOutput NoOutput = + return () --- | Get messages from user, check their signature, and make sure that they +-- | Get messages from server, check their signature, and make sure that they -- are properly chained from past messages, before returning. -getUserMessage :: TMChan (Message Seen) -> TVar DeveloperState -> STM (Maybe (Output, Message Seen)) -getUserMessage ochan devstate = do +getServerMessage :: TMChan LogMessage -> TVar DeveloperState -> STM (Maybe (Output, LogMessage)) +getServerMessage ochan devstate = do mmsg <- readTMChan ochan case mmsg of Nothing -> return Nothing - Just msg -> do + Just (User msg) -> do ds <- readTVar devstate - -- Check signature before doing anything else. + -- Check user's signature before doing anything else. if verifySigned (developerSigVerifier ds) msg then do - o <- process ds msg - return (Just (o, msg)) - else getUserMessage ochan devstate + o <- processuser ds msg + return (Just (o, User msg)) + else getServerMessage ochan devstate + Just (Developer msg) -> do + -- Not bothering to check signatures of messages + -- from other developers. XXX + return (Just (NoOutput, Developer msg)) where - process ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do + processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _)) = do let (legal, ds') = isLegalSeen act ds if legal then do writeTVar devstate ds' return (TtyOutput b) else return (ProtocolError $ "Illegal Seen value: " ++ show (act, hash act)) - process ds (ControlMessage (Control (Rejected _) _)) = do + processuser ds (ControlMessage (Control (Rejected _) _)) = do -- When they rejected a message we sent, -- anything we sent subsequently will -- also be rejected, so forget about it. @@ -178,11 +181,11 @@ getUserMessage ochan devstate = do } writeTVar devstate ds' return Beep - process _ (ControlMessage (Control c@(SessionKey _) _)) = + processuser _ (ControlMessage (Control c@(SessionKey _) _)) = return (GotControl c) - process _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) = + processuser _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) = return (GotControl c) - process _ (ControlMessage (Control c@(SessionKeyRejected _) _)) = + processuser _ (ControlMessage (Control c@(SessionKeyRejected _) _)) = return (GotControl c) -- | Check if the Seen activity is legal, forming a chain with previous @@ -230,15 +233,15 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds acth = hash act yes ds' = (True, ds') --- | Start by reading the initial two messages from the user side, +-- | Start by reading the initial two messages from the user, -- their session key and the startup message. -processSessionStart :: TMChan (Message Seen) -> Logger -> IO (TVar DeveloperState, Output) +processSessionStart :: TMChan LogMessage -> Logger -> IO (TVar DeveloperState, Output) processSessionStart ochan logger = do sessionmsg <- fromMaybe (error "Did not get session initialization message") <$> atomically (readTMChan ochan) - logger $ User sessionmsg + logger sessionmsg sigverifier <- case sessionmsg of - ControlMessage c@(Control (SessionKey pk) _) -> + User (ControlMessage c@(Control (SessionKey pk) _)) -> let sv = mkSigVerifier pk in if verifySigned sv c then return sv @@ -246,9 +249,9 @@ processSessionStart ochan logger = do _ -> error $ "Unexpected session initialization message: " ++ show sessionmsg startmsg <- fromMaybe (error "Did not get session startup message") <$> atomically (readTMChan ochan) - logger $ User startmsg + logger startmsg let (starthash, output) = case startmsg of - ActivityMessage act@(Activity (Seen (Val b)) Nothing _) + User (ActivityMessage act@(Activity (Seen (Val b)) Nothing _)) | verifySigned sigverifier act -> (hash act, TtyOutput b) _ -> error $ "Unexpected startup message: " ++ show startmsg diff --git a/Role/Downloader.hs b/Role/Downloader.hs index ede11a7..07148e8 100644 --- a/Role/Downloader.hs +++ b/Role/Downloader.hs @@ -7,12 +7,12 @@ import SessionID import Control.Concurrent.STM import Control.Concurrent.STM.TMChan -import Role.Developer (run', processSessionStart, getUserMessage, Output(..)) +import Role.Developer (run', processSessionStart, getServerMessage, Output(..)) run :: DownloadOpts -> IO () run = run' downloader . downloadUrl -downloader :: TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO () +downloader :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO () downloader _ichan ochan sid = do let logfile = sessionLogFile "." sid putStrLn $ "Starting download to " ++ logfile @@ -22,11 +22,11 @@ downloader _ichan ochan sid = do go logger st where go logger st = do - v <- atomically $ getUserMessage ochan st + v <- atomically $ getServerMessage ochan st case v of Nothing -> return () Just (o, msg) -> do - _ <- logger $ User msg + _ <- logger msg case o of ProtocolError e -> error ("Protocol error: " ++ e) _ -> go logger st diff --git a/Role/Watcher.hs b/Role/Watcher.hs index ddffa79..c13234f 100644 --- a/Role/Watcher.hs +++ b/Role/Watcher.hs @@ -8,19 +8,19 @@ import SessionID import Control.Concurrent.STM import Control.Concurrent.STM.TMChan -import Role.Developer (run', processSessionStart, getUserMessage, emitOutput) +import Role.Developer (run', processSessionStart, getServerMessage, emitOutput) run :: WatchOpts -> IO () run = run' watcher . watchUrl -watcher :: TMChan (Message Entered) -> TMChan (Message Seen) -> SessionID -> IO () +watcher :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO () watcher _ichan ochan _ = inRawMode $ do (st, startoutput) <- processSessionStart ochan nullLogger emitOutput startoutput go st where go st = do - v <- atomically $ getUserMessage ochan st + v <- atomically $ getServerMessage ochan st case v of Nothing -> return () Just (o, _msg) -> do @@ -14,6 +14,7 @@ import Network.Wai.Handler.WebSockets import Network.WebSockets hiding (Message) import qualified Network.WebSockets as WS import Network.HTTP.Types +import Control.Concurrent import Control.Concurrent.STM import Control.Concurrent.STM.TMChan import Control.Concurrent.Async @@ -24,6 +25,7 @@ import qualified Data.Text as T import Data.Time.Clock.POSIX import System.IO import System.Directory +import System.Mem.Weak type ServerState = M.Map SessionID Session @@ -33,17 +35,21 @@ newServerState = newTVarIO M.empty -- | A session consists of a broadcast TMChan, which both users and -- developers write messages to. Writes are stored in the log file, -- and a log lock allows atomic access to the log file for replays. -data Session = Session (TMChan Log) (TVar Handle) (TMVar LogLock) +data Session = Session (TMChan (Broadcast Log)) (TVar Handle) (TMVar LogLock) data LogLock = LogLock +-- | A broadcast message, with the ThreadId of the sending thread +-- (which probably wants to ignore the message it sent). +data Broadcast a = Broadcast a (Weak ThreadId) + newSession :: TVar Handle -> IO Session newSession loghv = Session <$> newBroadcastTMChanIO <*> pure loghv <*> newTMVarIO LogLock -listenSession :: Session -> STM (TMChan Log) +listenSession :: Session -> STM (TMChan (Broadcast Log)) listenSession (Session bchan _ _) = dupTMChan bchan -- | While writing a log to the session the LogLock is drained until @@ -55,9 +61,10 @@ writeSession (Session bchan loghv loglock) l = do <$> takeTMVar loglock <*> readTVar loghv writeLogHandle l logh + tid <- mkWeakThreadId =<< myThreadId atomically $ do putTMVar loglock ll - writeTMChan bchan l + writeTMChan bchan (Broadcast l tid) -- | Run an action with the log file quiescent (and its write handle closed), -- and nothing being added to the session's broadcast TMChan. @@ -145,7 +152,7 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do relaytouser userchan = do v <- atomically $ readTMChan userchan case v of - Just l -> case loggedMessage l of + Just (Broadcast l _from) -> case loggedMessage l of Developer m -> do sendBinaryData conn (LogMessage (Developer m)) relaytouser userchan @@ -169,8 +176,9 @@ developer o ssv sid conn = bracket setup cleanup go go (Just session) = do sendBinaryData conn (Ready ServerSends sid) devchan <- replayBacklogAndListen o sid session conn + mytid <- myThreadId _ <- relayfromdeveloper session - `concurrently` relaytodeveloper devchan + `concurrently` relaytodeveloper mytid devchan return () -- Relay all Developer amessages from the developer's websocket @@ -183,17 +191,24 @@ developer o ssv sid conn = bracket setup cleanup go -- Relay user messages from the developer's clone of the -- broadcast channel to the developer's websocket. - relaytodeveloper devchan = do + relaytodeveloper mytid devchan = do v <- atomically $ readTMChan devchan case v of - Just l -> case loggedMessage l of - User m -> do - sendBinaryData conn (LogMessage (User m)) - relaytodeveloper devchan - -- TODO: Relay messages from other - -- developers, without looping back - -- the developer's own messages. - Developer _ -> relaytodeveloper devchan + Just (Broadcast l from) -> do + let sendit = sendBinaryData conn + (LogMessage $ loggedMessage l) + case loggedMessage l of + User _ -> sendit + -- Relay messages from other + -- developers, without looping + -- back the developer's own messages. + Developer _ -> do + mtid <- deRefWeak from + case mtid of + Just tid | tid == mytid -> + return () + _ -> sendit + relaytodeveloper mytid devchan Nothing -> do sendBinaryData conn Done return () @@ -207,7 +222,7 @@ developer o ssv sid conn = bracket setup cleanup go -- -- Note that the session may appear to freeze for other users while -- this is running. -replayBacklogAndListen :: ServerOpts -> SessionID -> Session -> WS.Connection -> IO (TMChan Log) +replayBacklogAndListen :: ServerOpts -> SessionID -> Session -> WS.Connection -> IO (TMChan (Broadcast Log)) replayBacklogAndListen o sid session conn = preventWriteWhile session o sid $ do replayBacklog o sid conn @@ -30,10 +30,6 @@ to. * When Role.Developer.processSessionStart throws an error, it's caught somewhere, and the process exits quietly with exit code 0. -* --watch and --download only get Seen messages, not Entered messages, - because the server does not send Developer messages to them. - To fix, need a way to avoid looping Entered messages sent by a developer - back to themselves. * --download gets a log without pauses, because timestamps are not included in the wire protocol. Perhaps move the log timestamp to data LogMessage? @@ -54,6 +50,7 @@ "run debug-me --trust-gpg-key=whatever" * How to prevent abusing servers to store large quantities of data that are not legitimate debug-me logs, but are formatted like them? + Perhaps add POW to the wire protocol? * Multiple developers should be able to connect to a single debug-me user and all send Entered messages. Most of the code was written with that in mind, but not tested yet.. diff --git a/protocol.txt b/protocol.txt index 687c085..5bf0f7e 100644 --- a/protocol.txt +++ b/protocol.txt @@ -3,9 +3,10 @@ the two participants, known as the user and the developer. (The exact composition of the JSON objects is not described here; see Types.hs for the data types that JSON serialization instances are derived -from. Also, debug-me uses a binary format instead of sending JSON +from. Also, debug-me uses a binary format instead of sending JSON over the wire. The wire format is currently implemented using the -Haskell cereal library, and is not specified.) +Haskell cereal library, and is not specified. There is also a simple +framing protocol used for communicating over websockets; see WebSockets.hs) The Activity type is the main message type. The user sends Activity Seen messages, and the developer responds with Activity Entered. @@ -73,17 +74,17 @@ in a Control message containing a SessionKey. 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 will 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 message -to indicate if they accepted the developer's key or not. - -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. +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 the activity chain proves who sent a message, and who sent the message 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. |