have server relay Devloper messages to other Developers

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
diff --git a/Server.hs b/Server.hs
index 5de184d..0906937 100644
--- a/Server.hs
+++ b/Server.hs
@@ -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
diff --git a/TODO b/TODO
index 36ba683..4763cc3 100644
--- a/TODO
+++ b/TODO
@@ -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.