initial http server

Incomplete, but the client is able to connect and send messages which
get logged.

Split up debug-me.hs into Role/*

Switched from cereal to binary, since websockets operate on lazy
ByteStrings, and using cereal would involve a copy on every receive.

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.

13 files changed, 783 insertions, 521 deletions

diff --git a/CmdLine.hs b/CmdLine.hs
index 2c71327..db3c749 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -9,10 +9,19 @@ data CmdLine = CmdLine
 	}
 
 data Mode
-	= Test 
-	| Graphviz GraphvizOpts
-	| Replay ReplayOpts
-	| Server ServerOpts
+	= UserMode UserOpts
+	| DeveloperMode DeveloperOpts
+	| GraphvizMode GraphvizOpts
+	| ReplayMode ReplayOpts
+	| ServerMode ServerOpts
+
+data UserOpts = UserOpts
+	{
+	}
+
+data DeveloperOpts = DeveloperOpts
+	{ debugUrl :: String
+	}
 
 data GraphvizOpts = GraphvizOpts
 	{ graphvizLogFile :: FilePath
@@ -32,10 +41,11 @@ parseCmdLine :: Parser CmdLine
 parseCmdLine = CmdLine <$> parseMode
 
 parseMode :: Parser Mode
-parseMode = (Graphviz <$> parsegraphviz)
-	<|> (Replay <$> parsereplay)
-	<|> (Server <$> parseserver)
-	<|> pure Test -- default, so last
+parseMode = (GraphvizMode <$> parsegraphviz)
+	<|> (ReplayMode <$> parsereplay)
+	<|> (ServerMode <$> parseserver)
+	<|> (DeveloperMode <$> parsedeveloper)
+	<|> pure (UserMode (UserOpts {})) -- default, so last
   where
 	parsegraphviz = GraphvizOpts
 		<$> option str
@@ -66,6 +76,12 @@ parseMode = (Graphviz <$> parsegraphviz)
 			<> showDefault
 			<> help "port for server to listen on"
 			)
+	parsedeveloper = DeveloperOpts
+		<$> option str
+			( long "debug"
+			<> metavar "url"
+			<> help "debug a user on the given url"
+			)
 
 getCmdLine :: IO CmdLine
 getCmdLine = execParser opts
diff --git a/Log.hs b/Log.hs
index 05cbdc3..ec7078e 100644
--- a/Log.hs
+++ b/Log.hs
@@ -71,6 +71,10 @@ withLogger logfile a = withFile logfile WriteMode (a . mkLogger)
 mkLogger :: Handle -> Logger
 mkLogger h a = do
 	l <- mkLog a <$> getPOSIXTime
+	writeLogHandle l h
+
+writeLogHandle :: Log -> Handle -> IO ()
+writeLogHandle l h = do
 	L.hPut h (encode l)
 	hPutStr h "\n"
 	hFlush h
diff --git a/Role/Developer.hs b/Role/Developer.hs
new file mode 100644
index 0000000..deceb6d
--- /dev/null
+++ b/Role/Developer.hs
@@ -0,0 +1,239 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Role.Developer where
+
+import Types
+import Hash
+import Log
+import Crypto
+import CmdLine
+import WebSockets
+
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import System.IO
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import Data.List
+
+run :: DeveloperOpts -> IO ()
+run os = runClientApp $ clientApp (ConnectMode (T.pack (debugUrl os))) developer
+
+developer :: TChan (Message Entered) -> TChan (Message Seen) -> IO ()
+developer ichan ochan = withLogger "debug-me-developer.log" $ \logger -> do
+	-- Start by reading the initial two messages from the user side,
+	-- their session key and the startup message.
+	sessionmsg <- atomically $ readTChan ochan
+	logger $ User sessionmsg
+	sigverifier <- case sessionmsg of
+		ControlMessage c@(Control (SessionKey pk) _) ->
+			let sv = mkSigVerifier pk
+			in if verifySigned sv c
+				then return sv
+				else error "Badly signed session initialization message"
+		_ -> error $ "Unexpected session initialization message: " ++ show sessionmsg
+	startmsg <- atomically $ readTChan ochan
+	logger $ User startmsg
+	starthash <- case startmsg of
+		ActivityMessage act@(Activity (Seen (Val b)) Nothing _)
+			| verifySigned sigverifier act -> do
+				B.hPut stdout b
+				hFlush stdout	
+				return (hash act)
+		_ -> error $ "Unexpected startup message: " ++ show startmsg
+
+	sk <- genMySessionKey
+	devstate <- newTVarIO $ DeveloperState
+		{ lastSeen = starthash
+		, sentSince = mempty
+		, enteredSince = mempty
+		, lastActivity = starthash
+		, developerSessionKey = sk
+		, developerSigVerifier = sigverifier
+		}
+	ok <- authUser ichan ochan devstate logger
+	if ok
+		then do
+			_ <- sendTtyInput ichan devstate logger
+				`concurrently` sendTtyOutput ochan devstate logger
+			return ()
+		else do
+			hPutStrLn stderr "\nUser did not grant access to their terminal."
+
+data DeveloperState = DeveloperState
+	{ lastSeen :: Hash
+	, sentSince :: [B.ByteString]
+	, enteredSince :: [Hash]
+	, lastActivity :: Hash
+	, developerSessionKey :: MySessionKey
+	, developerSigVerifier :: SigVerifier
+	}
+
+-- | Read things typed by the developer, and forward them to the TChan.
+sendTtyInput :: TChan (Message Entered) -> TVar DeveloperState -> Logger -> IO ()
+sendTtyInput ichan devstate logger = go
+  where
+	go = do
+		b <- B.hGetSome stdin 1024
+		if b == B.empty
+			then return ()
+			else send b
+	send b = do
+		act <- atomically $ do
+			ds <- readTVar devstate
+			let ed = if lastActivity ds == lastSeen ds
+				then B.concat $ sentSince ds
+				else case reverse (sentSince ds) of
+					[] -> mempty
+					(lb:_) -> lb
+			let entered = Entered
+				{ enteredData = Val b
+				, echoData = Val ed
+				}
+			let act = mkSigned (developerSessionKey ds) $
+				Activity entered (Just $ lastActivity ds)
+			writeTChan ichan (ActivityMessage act)
+			let acth = hash act
+			let ds' = ds
+				{ sentSince = sentSince ds ++ [b]
+				, enteredSince = enteredSince ds ++ [acth]
+				, lastActivity = acth
+				}
+			writeTVar devstate ds'
+			return act
+		logger $ Developer $ ActivityMessage act
+		go
+
+-- | Read activity from the TChan and display it to the developer.
+sendTtyOutput :: TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO ()
+sendTtyOutput ochan devstate logger = go
+  where
+	go = do
+		(o, msg) <- atomically $ getUserMessage ochan devstate
+		logger $ User msg
+		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 :: TChan (Message Entered) -> TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO Bool
+authUser ichan ochan devstate logger = do
+	ds <- atomically $ readTVar devstate
+	pk <- myPublicKey (developerSessionKey ds)
+	let msg = ControlMessage $ mkSigned (developerSessionKey ds) 
+		(Control (SessionKey pk))
+	atomically $ writeTChan ichan msg
+	logger $ Developer msg
+	waitresp pk
+  where
+	waitresp pk = do
+		(o, msg) <- atomically $ getUserMessage ochan devstate
+		logger $ User msg
+		emitOutput o
+		case o of
+			GotControl (SessionKeyAccepted pk')
+				| pk' == pk -> return True
+			GotControl (SessionKeyRejected pk')
+				| pk' == pk -> return False
+			_ -> waitresp pk
+
+data Output
+	= TtyOutput B.ByteString 
+	| Beep
+	| ProtocolError String
+	| GotControl ControlAction
+
+emitOutput :: Output -> IO ()
+emitOutput (ProtocolError e) =
+	error e
+emitOutput (TtyOutput b) = do
+	B.hPut stdout b
+	hFlush stdout
+emitOutput Beep = do
+	B.hPut stdout "\a"
+	hFlush stdout
+emitOutput (GotControl _) =
+	return ()
+
+-- | Get messages from user, check their signature, and make sure that they
+-- are properly chained from past messages, before returning.
+getUserMessage :: TChan (Message Seen) -> TVar DeveloperState -> STM (Output, Message Seen)
+getUserMessage ochan devstate = do
+	msg <- readTChan ochan
+	ds <- readTVar devstate
+	-- Check signature before doing anything else.
+	if verifySigned (developerSigVerifier ds) msg
+		then do
+			o <- process ds msg
+			return (o, msg)
+		else getUserMessage ochan devstate
+  where
+	process 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
+		-- When they rejected a message we sent,
+		-- anything we sent subsequently will
+		-- also be rejected, so forget about it.
+		let ds' = ds
+			{ sentSince = mempty
+			, enteredSince = mempty
+			}
+		writeTVar devstate ds'
+		return Beep
+	process _ (ControlMessage (Control c@(SessionKey _) _)) =
+		return (GotControl c)
+	process _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) =
+		return (GotControl c)
+	process _ (ControlMessage (Control c@(SessionKeyRejected _) _)) =
+		return (GotControl c)
+
+-- | Check if the Seen activity is legal, forming a chain with previous
+-- ones, and returns an updated DeveloperState.
+--
+-- Does not check the signature.
+isLegalSeen :: Activity Seen -> DeveloperState -> (Bool, DeveloperState)
+isLegalSeen (Activity _ Nothing _) ds = (False, ds)
+isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds
+	-- Does it chain to the last Seen activity?
+	| hp == lastSeen ds = 
+		-- Trim sentSince and enteredSince to
+		-- values after the Seen value.
+		let ss = sentSince ds
+		    es = enteredSince ds
+		    n = B.length b
+		    (ss', es') = if b `B.isPrefixOf` mconcat ss
+		    	then (drop n ss, drop n es)
+			else (mempty, mempty)
+		in yes ds
+			{ lastSeen = acth
+			, sentSince = ss'
+			, enteredSince = es'
+			, lastActivity = acth
+			}
+	-- Does it chain to something we've entered since the last Seen
+	-- value? Eg, user sent A, we replied B C, and the user has
+	-- now replied to B.
+	-- If so, we can drop B (and anything before it) from
+	-- enteredSince and sentSince.
+	| otherwise = case elemIndex hp (enteredSince ds) of
+		Nothing -> (False, ds)
+		Just i -> 
+			let ss = sentSince ds
+			    es = enteredSince ds
+			    ss' = drop (i+1) ss
+			    es' = drop (i+1) es
+			in yes ds
+				{ lastSeen = acth
+				, sentSince = ss'
+				, enteredSince = es'
+				, lastActivity = acth
+				}
+  where
+	acth = hash act
+	yes ds' = (True, ds')
diff --git a/Role/User.hs b/Role/User.hs
new file mode 100644
index 0000000..9412843
--- /dev/null
+++ b/Role/User.hs
@@ -0,0 +1,252 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Role.User where
+
+import Types
+import Pty
+import Memory
+import Log
+import Session
+import Crypto
+import CmdLine
+import WebSockets
+
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import System.Process
+import System.Exit
+import qualified Data.ByteString as B
+import Data.List.NonEmpty (NonEmpty(..), toList)
+import Data.Monoid
+import Data.Time.Clock.POSIX
+
+run :: UserOpts -> IO ExitCode
+run os = do
+	(cmd, cmdparams) <- shellCommand os
+	exitstatus <- go cmd cmdparams startSession
+	sessionDone
+	return exitstatus
+  where
+	go cmd cmdparams startmsg = runWithPty cmd cmdparams $ \(p, ph) -> do
+		runClientApp $ clientApp (InitMode mempty) $ \ichan ochan -> do
+			uthread <- async (user startmsg p ichan ochan)
+			exitstatus <- waitForProcess ph
+			cancel uthread
+			return exitstatus
+
+shellCommand :: UserOpts -> IO (String, [String])
+shellCommand os = return ("dash", [])
+
+-- | Log of recent Activity, with the most recent first.
+type Backlog = NonEmpty Log
+
+data UserState = UserState
+	{ backLog :: Backlog
+	, userSessionKey :: MySessionKey
+	, userSigVerifier :: SigVerifier
+	}
+
+user :: B.ByteString -> Pty -> TChan (Message Seen) -> TChan (Message Entered) -> IO ()
+user starttxt p ochan ichan = withLogger "debug-me.log" $ \logger -> do
+	-- Start by establishing our session key, and displaying the starttxt.
+	let initialmessage msg = do
+		atomically $ writeTChan ochan msg
+		logger $ User msg
+	sk <- genMySessionKey
+	pk <- myPublicKey sk
+	let c = mkSigned sk $ Control (SessionKey pk)
+	initialmessage $ ControlMessage c
+	let act = mkSigned sk $ Activity (Seen (Val (starttxt <> "\r\n"))) Nothing
+	let startmsg = ActivityMessage act
+	initialmessage startmsg
+	l <- mkLog (User startmsg) <$> getPOSIXTime
+	us <- newTVarIO $ UserState
+		{ backLog = l :| []
+		, userSessionKey = sk
+		, userSigVerifier = mempty
+		}
+	_ <- sendPtyOutput p ochan us logger
+		`concurrently` sendPtyInput ichan ochan p us logger
+	return ()
+
+-- | Forward things written to the Pty out the TChan.
+sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO ()
+sendPtyOutput p ochan us logger = go
+  where
+	go = do
+		b <- readPty p
+		now <- getPOSIXTime
+		l <- atomically $ do
+			let seen = Seen (Val b)
+			sendDeveloper ochan us seen now
+		logger $ User l
+		go
+
+class SendableToDeveloper t where
+	sendDeveloper :: TChan (Message Seen) -> TVar UserState -> t -> POSIXTime -> STM (Message Seen)
+
+instance SendableToDeveloper Seen where
+	sendDeveloper ochan us seen now = do
+		st <- readTVar us
+		let bl@(prev :| _) = backLog st
+		let msg = ActivityMessage $
+			mkSigned (userSessionKey st) $ 
+				Activity seen (loggedHash prev)
+		let l = mkLog (User msg) now
+		writeTChan ochan msg
+		writeTVar us $ st { backLog = l :| toList bl }
+		return msg
+
+instance SendableToDeveloper ControlAction where
+	sendDeveloper ochan us c _now = do
+		st <- readTVar us
+		let msg = ControlMessage $
+			mkSigned (userSessionKey st) (Control c)
+		-- Control messages are not kept in the backlog.
+		writeTChan ochan msg
+		return msg
+
+-- | Read things to be entered from the TChan, verify if they're legal,
+-- and send them to the Pty.
+sendPtyInput :: TChan (Message Entered) -> TChan (Message Seen) -> Pty -> TVar UserState -> Logger -> IO ()
+sendPtyInput ichan ochan p us logger = go
+  where
+	go = do
+		now <- getPOSIXTime
+		v <- atomically $ getDeveloperMessage ichan ochan us now
+		case v of
+			InputMessage msg@(ActivityMessage entered) -> do
+				logger $ Developer msg
+				writePty p $ val $ enteredData $ activity entered
+				go
+			InputMessage msg@(ControlMessage (Control c _)) -> do
+				logger $ Developer msg
+				case c of
+					SessionKey pk -> do
+						checkDeveloperPublicKey ochan us logger pk
+						go
+					Rejected r -> error $ "User side received a Rejected: " ++ show r
+					SessionKeyAccepted _ -> error "User side received a SessionKeyAccepted"
+					SessionKeyRejected _ -> error "User side received a SessionKeyRejected"
+			RejectedMessage rej -> do
+				logger $ User rej
+				go
+			BadlySignedMessage _ -> go
+
+data Input
+	= InputMessage (Message Entered)
+	| RejectedMessage (Message Seen)
+	| BadlySignedMessage (Message Entered)
+
+-- Get message from developer, verify its signature is from a developer we
+-- have allowed (unless it's a SessionKey control message, then the
+-- 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 :: TChan (Message Entered) -> TChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input
+getDeveloperMessage ichan ochan us now = do
+	msg <- readTChan ichan
+	st <- readTVar us
+	case msg of
+		ControlMessage (Control (SessionKey pk) _) -> do
+			let sigverifier = mkSigVerifier pk
+			if verifySigned sigverifier msg
+				then return (InputMessage msg)
+				else return (BadlySignedMessage msg)
+		_ -> if verifySigned (userSigVerifier st) msg
+			then case msg of
+				ActivityMessage entered -> do
+					-- Don't need to retain backlog
+					-- before the Activity that entered
+					-- references.
+					let bl' = reduceBacklog $
+						truncateBacklog (backLog st) entered
+					if isLegalEntered entered (st { backLog = bl' })
+						then do
+							let l = mkLog (Developer msg) now
+							writeTVar us (st { backLog = l :| toList bl' })
+							return (InputMessage msg)
+						else do
+							let reject = Rejected entered
+							RejectedMessage <$> sendDeveloper ochan us reject now
+				ControlMessage (Control _ _) ->
+					return (InputMessage msg)
+			else return (BadlySignedMessage msg)
+
+-- | Check if the public key a developer presented is one we want to use,
+-- and if so, add it to the userSigVerifier.
+checkDeveloperPublicKey :: TChan (Message Seen) -> TVar UserState -> Logger -> PublicKey -> IO ()
+checkDeveloperPublicKey ochan us logger pk = do
+	now <- getPOSIXTime
+	-- TODO check gpg sig..
+	msg <- atomically $ do
+		st <- readTVar us
+		let sv = userSigVerifier st
+		let sv' = sv `mappend` mkSigVerifier pk
+		let st' = st { userSigVerifier = sv' }
+		writeTVar us st'
+		sendDeveloper ochan us (SessionKeyAccepted pk) now
+	logger $ User msg
+
+-- | Truncate the Backlog to remove entries older than the one
+-- that the Activity Entered refers to, but only if the referred
+-- to Activity is an Activity Seen. 
+--
+-- Once the developer has referred to a given Activity Seen in
+-- their Activity Entered, they cannot refer backwards to anything
+-- that came before it.
+--
+-- If the Activity refers to an item not in the backlog, no truncation is
+-- done.
+truncateBacklog :: Backlog -> Activity Entered -> Backlog
+truncateBacklog (b :| l) (Activity _ (Just hp) _)
+	| truncationpoint b = b :| []
+	| otherwise = b :| go [] l
+  where
+	go c [] = reverse c
+	go c (x:xs)
+		| truncationpoint x = reverse (x:c)
+		| otherwise = go (x:c) xs
+	truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp
+	truncationpoint _ = False
+truncateBacklog bl (Activity _ Nothing _) = bl
+
+-- | To avoid DOS attacks that try to fill up the backlog and so use all
+-- memory, don't let the backlog contain more than 1000 items, or
+-- more than 16 megabytes of total data. (Excluding the most recent
+-- item).
+reduceBacklog :: Backlog -> Backlog
+reduceBacklog (b :| l) = b :| go 0 (take 1000 l)
+  where
+	go _ [] = []
+	go n (x:xs)
+		| n > 16777216 = []
+		| otherwise = x : go (n + dataSize x) xs
+
+-- | Entered activity is legal when it points to the last logged activity,
+-- because this guarantees that the person who entered it saw
+-- the current state of the system before manipulating it.
+--
+-- To support typeahead on slow links, some echoData may be provided
+-- in the Entered activity. If the Entered activity points
+-- to an older activity, then the echoData must match the
+-- concatenation of all Seen activities after that one, up to the
+-- last logged activity.
+--
+-- Activities that do not enter data point to the first message
+-- sent in the debug-me session.
+--
+-- Does not check the signature.
+isLegalEntered :: Activity Entered -> UserState -> Bool
+isLegalEntered (Activity _ Nothing _) _ = False
+isLegalEntered (Activity a (Just hp) _) us
+	| loggedHash lastact == Just hp = True
+	| B.null (val (echoData a)) = False -- optimisation
+	| any (== Just hp) (map loggedHash bl) =
+		let sincehp = reverse (lastact : takeWhile (\l -> loggedHash l /= Just hp) bl)
+		in echoData a == mconcat (map (getseen . loggedMessage) sincehp)
+	| otherwise = False
+  where
+	(lastact :| bl) = backLog us
+	getseen (User (ActivityMessage as)) = seenData $ activity as
+	getseen _ = mempty
diff --git a/Serialization.hs b/Serialization.hs
index 6940550..bba2a52 100644
--- a/Serialization.hs
+++ b/Serialization.hs
@@ -1,12 +1,12 @@
 module Serialization (
 	module Data.Aeson,
-	Serialize,
+	Binary,
 	Generic,
 	sumOptions
 ) where
 
 import GHC.Generics (Generic)
-import Data.Serialize
+import Data.Binary
 import Data.Aeson
 import qualified Data.Aeson.Types as Aeson
 
diff --git a/Server.hs b/Server.hs
index 5d919b8..37316c3 100644
--- a/Server.hs
+++ b/Server.hs
@@ -3,24 +3,105 @@
 module Server where
 
 import CmdLine
+import WebSockets
+import SessionID
+import Log
 
 import Network.Wai
 import Network.Wai.Handler.Warp
 import Network.Wai.Handler.WebSockets
 import qualified Network.WebSockets as WS
 import Network.HTTP.Types
-import Data.Text (Text)
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TMChan
+import Control.Concurrent.Async
+import qualified Data.Map as M
+import System.IO
+import Control.Exception
+import Data.Time.Clock.POSIX
 
 server :: ServerOpts -> IO ()
-server o = run (serverPort o) app
+server o = run (serverPort o) . app o =<< newServerState
 
-app :: Application
-app = websocketsOr WS.defaultConnectionOptions websocketApp webapp
+type ServerState = M.Map SessionID (TMChan Log)
+
+newServerState :: IO (TVar ServerState)
+newServerState = newTVarIO M.empty
+
+app :: ServerOpts -> TVar ServerState -> Application
+app o ssv = websocketsOr WS.defaultConnectionOptions (websocketApp o ssv) webapp
   where
 	webapp _ respond = respond $
 		responseLBS status400 [] "Not a WebSocket request"
 
-websocketApp :: WS.ServerApp
-websocketApp pending_conn = do
+websocketApp :: ServerOpts -> TVar ServerState -> WS.ServerApp
+websocketApp o ssv pending_conn = do
+	print ("new connection" :: String)
 	conn <- WS.acceptRequest pending_conn
-	WS.sendTextData conn ("Hello, client!" :: Text)
+	sendWireVersions conn
+	print ("new connection open" :: String)
+	-- wv <- negotiateWireVersion conn
+	-- print ("version negotiated" :: String, wv)
+	theirmode <- getMode conn
+	print ("Connected" :: String, theirmode)
+	case theirmode of
+		InitMode _ -> user o ssv conn
+		ConnectMode t -> case mkSessionID t of
+			Nothing -> error "Invalid session id!"
+			Just sid -> developer o ssv sid conn
+
+user :: ServerOpts -> TVar ServerState -> WS.Connection -> IO ()
+user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) ->
+	bracket (setup sid) (cleanup sid) (go logh)
+  where
+	setup sid = do
+		bchan <- newBroadcastTMChanIO
+		atomically $ modifyTVar' ssv $ M.insert sid bchan
+		return bchan
+
+	cleanup sid bchan = atomically $ do
+		closeTMChan bchan
+		modifyTVar' ssv $ M.delete sid
+
+	go logh bchan = do
+		logchan <- atomically $ dupTMChan bchan
+		userchan <- atomically $ dupTMChan bchan
+		_ <- storelog logh logchan
+			`concurrently` relaytouser userchan
+			`concurrently` relayfromuser bchan
+		return ()
+	
+	-- Read from logchan and store each value to the log file.
+	storelog logh logchan = do
+		v <- atomically $ readTMChan logchan
+		case v of
+			Nothing -> return ()
+			Just l -> do
+				writeLogHandle l logh
+				storelog logh logchan
+	
+	relaytouser userchan = relayToSocket conn $ do
+		v <- atomically $ readTMChan userchan
+		return $ case v of
+			Just l -> case loggedMessage l of
+				Developer m -> Just m
+				User _ -> Nothing
+			Nothing -> Nothing
+	
+	relayfromuser bchan = relayFromSocket conn $ \msg -> do
+		l <- mkLog (User msg) <$> getPOSIXTime
+		atomically $ writeTMChan bchan l
+
+developer ::  ServerOpts -> TVar ServerState -> SessionID -> WS.Connection -> IO ()
+developer o ssv sid conn = bracket setup cleanup go
+  where
+	setup = atomically $ M.lookup sid <$> readTVar ssv
+	cleanup _ = return ()
+	go Nothing = error "Invalid session id!"
+	go (Just logchan) = relayToSocket conn $ do
+		v <- atomically $ readTMChan logchan
+		return $ case v of
+			Just l -> case loggedMessage l of
+				User m -> Just m
+				Developer _ -> Nothing
+			Nothing -> Nothing
diff --git a/SessionID.hs b/SessionID.hs
new file mode 100644
index 0000000..a47de8f
--- /dev/null
+++ b/SessionID.hs
@@ -0,0 +1,28 @@
+module SessionID (SessionID, mkSessionID, sessionLogFile, withSessionID) where
+
+import System.FilePath
+import Data.Text
+import System.IO
+
+-- | A SessionID is the base name of the log file to use,
+-- and may not contain any path information.
+newtype SessionID = SessionID FilePath
+	deriving (Show, Eq, Ord)
+
+-- | Smart constructor that enforces security requirements.
+mkSessionID :: Text -> Maybe SessionID
+mkSessionID t = 
+	let f = unpack t
+	in if takeFileName f == f
+		then Just (SessionID f)
+		else Nothing
+
+sessionLogFile :: FilePath -> SessionID -> FilePath
+sessionLogFile dir (SessionID f) = dir </> "debug-me." ++ f ++ ".log"
+
+-- | Allocate a new SessionID and return an open Handle to its log file.
+withSessionID :: FilePath -> ((Handle, SessionID) -> IO a) -> IO a
+withSessionID dir a = do
+	-- TODO find an unused log file and open it
+	let sid = SessionID "1"
+	withFile "debug-me-server.log" WriteMode $ \h -> a (h, sid)
diff --git a/TODO b/TODO
index c9e93ec..6a63d26 100644
--- a/TODO
+++ b/TODO
@@ -17,4 +17,3 @@
 * Multiple developers should be able to connect to a single debug-me
   user. Most of the code was written with that in mind, but not tested
   yet..
-* Add a protocol version (probably to the SessionKey message)
diff --git a/Types.hs b/Types.hs
index 699fa59..b28713d 100644
--- a/Types.hs
+++ b/Types.hs
@@ -2,7 +2,7 @@
 
 {- | Main types for debug-me
  -
- - Note that changing types in ways that change the cereal serialization
+ - Note that changing types in ways that change the Binary serialization
  - changes debug-me's wire format. Changing types in ways that change the
  - aeson serialization changes debug-me's log format.
  -}
@@ -136,56 +136,56 @@ newtype GpgSig = GpgSig Val
 instance DataSize GpgSig where
 	dataSize (GpgSig s) = dataSize s
 
-instance Serialize Seen
+instance Binary Seen
 instance ToJSON Seen
 instance FromJSON Seen
-instance Serialize Entered
+instance Binary Entered
 instance ToJSON Entered
 instance FromJSON Entered
-instance Serialize (Activity Seen)
+instance Binary (Activity Seen)
 instance ToJSON (Activity Seen)
 instance FromJSON (Activity Seen)
-instance Serialize (Activity Entered)
+instance Binary (Activity Entered)
 instance ToJSON (Activity Entered)
 instance FromJSON (Activity Entered)
-instance Serialize Control
+instance Binary Control
 instance ToJSON Control
 instance FromJSON Control
-instance Serialize Hash
+instance Binary Hash
 instance ToJSON Hash
 instance FromJSON Hash
-instance Serialize HashMethod
+instance Binary HashMethod
 instance ToJSON HashMethod
 instance FromJSON HashMethod
-instance Serialize PublicKey
+instance Binary PublicKey
 instance ToJSON PublicKey
 instance FromJSON PublicKey
-instance Serialize GpgSig
+instance Binary GpgSig
 instance ToJSON GpgSig
 instance FromJSON GpgSig
 
-instance Serialize (Message Seen)
+instance Binary (Message Seen)
 instance ToJSON (Message Seen) where
 	toJSON = genericToJSON sumOptions
 	toEncoding = genericToEncoding sumOptions
 instance FromJSON (Message Seen) where
 	parseJSON = genericParseJSON sumOptions
 
-instance Serialize (Message Entered)
+instance Binary (Message Entered)
 instance ToJSON (Message Entered) where
 	toJSON = genericToJSON sumOptions
 	toEncoding = genericToEncoding sumOptions
 instance FromJSON (Message Entered) where
 	parseJSON = genericParseJSON sumOptions
 
-instance Serialize Signature
+instance Binary Signature
 instance ToJSON Signature where
 	toJSON = genericToJSON sumOptions
 	toEncoding = genericToEncoding sumOptions
 instance FromJSON Signature where
 	parseJSON = genericParseJSON sumOptions
 
-instance Serialize ControlAction
+instance Binary ControlAction
 instance ToJSON ControlAction where
 	toJSON = genericToJSON sumOptions
 	toEncoding = genericToEncoding sumOptions
diff --git a/Val.hs b/Val.hs
index 80ab8ed..3493bcd 100644
--- a/Val.hs
+++ b/Val.hs
@@ -19,7 +19,7 @@ newtype Val = Val { val :: B.ByteString }
 instance DataSize Val where
 	dataSize (Val b) = fromIntegral (B.length b)
 
-instance Serialize Val
+instance Binary Val
 
 -- | JSON instances for Val, using base64 encoding when the value
 -- is not utf-8 encoded, and otherwise using a more efficient encoding.
diff --git a/WebSockets.hs b/WebSockets.hs
new file mode 100644
index 0000000..1f18b14
--- /dev/null
+++ b/WebSockets.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE OverloadedStrings, DeriveGeneric, GeneralizedNewtypeDeriving, FlexibleContexts #-}
+
+module WebSockets where
+
+import Types
+import Serialization
+
+import Control.Concurrent.STM
+import Control.Concurrent.Async
+import Control.Exception
+import qualified Data.Aeson
+import qualified Data.Binary
+import qualified Network.WebSockets as WS
+import qualified Data.Text as T
+import Data.List
+import Data.Maybe
+
+runClientApp :: WS.ClientApp a -> IO a
+runClientApp = WS.runClient "localhost" 8080 "/"
+
+-- | Make a client that sends and receives Messages over a websocket.
+clientApp
+	:: (Binary (Message sent), Binary (Message received))
+	=> Mode
+	-> (TChan (Message sent) -> TChan (Message received) -> IO a)
+	-> WS.ClientApp a
+clientApp mode a conn = bracket setup cleanup go
+  where
+	setup = do
+		schan <- newTChanIO
+		rchan <- newTChanIO
+		sthread <- async $ relayFromSocket conn $
+			atomically . writeTChan rchan
+		rthread <- async $ relayToSocket conn $
+			Just <$> atomically (readTChan schan)
+		return (schan, rchan, sthread, rthread)
+	cleanup (_, _, sthread, rthread) = do
+		cancel sthread
+		cancel rthread
+	go (schan, rchan, _, _) = do
+		print "sendWireVersions start"
+		print "negotiateWireVersion start"
+		_ <- negotiateWireVersion conn
+		--sendWireVersions conn
+		print "negotiateWireVersion done"
+		sendMode conn mode
+		print "sendmode now done"
+		a schan rchan
+
+relayFromSocket :: Binary (Message received) => WS.Connection -> (Message received -> IO ()) -> IO ()
+relayFromSocket conn send = go
+  where
+	go = do
+		dm <- WS.receiveDataMessage conn
+		case dm of
+			WS.Binary b -> case Data.Binary.decodeOrFail b of
+				Right (_, _, msg) -> do
+					send msg
+					go
+				Left (_, _, err) -> error $ "Deserialization error: " ++ err
+			WS.Text _ -> error "Unexpected Text received on websocket"
+
+relayToSocket :: Binary (Message sent) => WS.Connection -> (IO (Maybe (Message sent))) -> IO ()
+relayToSocket conn get = go
+  where
+	go = do
+		mmsg <- get
+		case mmsg of
+			Nothing -> return ()
+			Just msg -> do
+				WS.sendDataMessage conn $ WS.Binary $
+					Data.Binary.encode msg
+				go
+
+newtype WireVersion = WireVersion T.Text
+	deriving (Show, Eq, Generic, Ord)
+
+instance FromJSON WireVersion
+instance ToJSON WireVersion
+
+supportedWireVersions :: [WireVersion]
+supportedWireVersions = [WireVersion "1"]
+
+sendWireVersions :: WS.Connection -> IO ()
+sendWireVersions conn = WS.sendTextData conn (Data.Aeson.encode supportedWireVersions)
+
+-- | Send supportedWireVersions and at the same time receive it from
+-- the remote side. The highest version present in both lists will be used.
+negotiateWireVersion :: WS.Connection -> IO WireVersion
+negotiateWireVersion conn = do
+	remoteversions <- WS.receiveData conn
+	print ("got versions" :: String)
+	case Data.Aeson.decode remoteversions of
+		Nothing -> error "Protocol error: WireVersion list was not sent"
+		Just l -> case reverse (intersect (sort supportedWireVersions) (sort l)) of
+			(v:_) -> return v
+			[] -> error $ "Unable to negotiate a WireVersion. I support: " ++ show supportedWireVersions ++ " They support: " ++ show l
+
+-- | Modes of operation that can be requested for a websocket connection.
+data Mode
+	= InitMode T.Text
+	| ConnectMode T.Text
+	deriving (Show, Eq, Generic)
+
+instance FromJSON Mode
+instance ToJSON Mode where
+
+sendMode :: WS.Connection -> Mode -> IO ()
+sendMode conn mode = WS.sendTextData conn (Data.Aeson.encode mode)
+
+getMode :: WS.Connection -> IO Mode
+getMode conn = fromMaybe (error "Unknown mode") . Data.Aeson.decode
+	<$> WS.receiveData conn
diff --git a/debug-me.cabal b/debug-me.cabal
index f32f195..c7639fd 100644
--- a/debug-me.cabal
+++ b/debug-me.cabal
@@ -23,21 +23,25 @@ Executable debug-me
   GHC-Options: -threaded -Wall -fno-warn-tabs -O2
   Build-Depends:
       base (>= 4.9 && < 5.0)
+    , network (>= 2.6)
     , bytestring == 0.10.*
     , cryptonite (>= 0.20)
     , unix (>= 2.7)
     , process (>= 1.4)
     , async (>= 2.1)
     , stm (>= 2.4)
+    , stm-chans (>= 3.0)
     , posix-pty (>= 0.2.1)
     , terminal-size (>= 0.3)
     , aeson (>= 0.11 && < 1.1)
     , sandi (>= 0.4)
     , text (>= 1.2.2)
-    , cereal (>= 0.5)
+    , binary (>= 0.8)
     , optparse-applicative (>= 0.12)
     , graphviz (== 2999.18.*)
     , time (>= 1.6)
+    , filepath (>= 1.4)
+    , containers (>= 0.5)
     , unbounded-delays (>= 0.1)
     , memory (>= 0.13)
     , warp (>= 3.2)
@@ -54,11 +58,15 @@ Executable debug-me
     Memory
     Pty
     Replay
+    Role.Developer
+    Role.User
     Session
     Types
     Serialization
     Server
+    SessionID
     Val
+    WebSockets
 
 source-repository head
   type: git
diff --git a/debug-me.hs b/debug-me.hs
index a17a740..25f18b8 100644
--- a/debug-me.hs
+++ b/debug-me.hs
@@ -1,499 +1,21 @@
-{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts #-}
-
 module Main where
 
-import Types
-import Hash
-import Pty
-import Memory
 import CmdLine
-import Log
+import qualified Role.User
+import qualified Role.Developer
 import Graphviz
 import Replay
-import Session
-import Crypto
 import Server
 
-import Control.Concurrent
-import Control.Concurrent.Async
-import Control.Concurrent.STM
-import System.IO
-import System.Process
+import Network.Socket
 import System.Exit
-import qualified Data.ByteString as B
-import Data.List
-import Data.List.NonEmpty (NonEmpty(..), toList)
-import Data.Monoid
-import Data.Time.Clock.POSIX
 
 main :: IO ()
-main = do
+main = withSocketsDo $ do
 	c <- getCmdLine
 	case mode c of
-		Test -> test
-		Graphviz o -> graphviz o
-		Replay o -> replay o
-		Server o -> server o
- 
-test :: IO ()
-test = do
-	exitstatus <- go startSession
-	sessionDone
-	exitWith exitstatus
-  where
-	go startmsg = runWithPty "dash" [] $ \(p, ph) -> do
-		ichan <- newTChanIO
-		ochan <- newTChanIO
-		dthread <- async (developer ichan ochan)
-		uthread <- async (user startmsg p ichan ochan)
-		exitstatus <- waitForProcess ph
-		cancel dthread
-		cancel uthread
-		return exitstatus
-
-networkDelay :: IO ()
--- networkDelay = threadDelay 800000 -- 800 ms ; the latency to geosync orbit
-networkDelay = threadDelay 150000 -- 150 ms ; transatlantic latency
-
-developer :: TChan (Message Entered) -> TChan (Message Seen) -> IO ()
-developer ichan ochan = withLogger "debug-me-developer.log" $ \logger -> do
-	-- Start by reading the initial two messages from the user side,
-	-- their session key and the startup message.
-	sessionmsg <- atomically $ readTChan ochan
-	logger $ User sessionmsg
-	sigverifier <- case sessionmsg of
-		ControlMessage c@(Control (SessionKey pk) _) ->
-			let sv = mkSigVerifier pk
-			in if verifySigned sv c
-				then return sv
-				else protocolError "Badly signed session initialization message"
-		_ -> protocolError $ "Unexpected session initialization message: " ++ show sessionmsg
-	startmsg <- atomically $ readTChan ochan
-	logger $ User startmsg
-	starthash <- case startmsg of
-		ActivityMessage act@(Activity (Seen (Val b)) Nothing _)
-			| verifySigned sigverifier act -> do
-				B.hPut stdout b
-				hFlush stdout	
-				return (hash act)
-		_ -> protocolError $ "Unexpected startup message: " ++ show startmsg
-
-	sk <- genMySessionKey
-	devstate <- newTVarIO $ DeveloperState
-		{ lastSeen = starthash
-		, sentSince = mempty
-		, enteredSince = mempty
-		, lastActivity = starthash
-		, developerSessionKey = sk
-		, developerSigVerifier = sigverifier
-		}
-	ok <- authUser ichan ochan devstate logger
-	if ok
-		then do
-			_ <- sendTtyInput ichan devstate logger
-				`concurrently` sendTtyOutput ochan devstate logger
-			return ()
-		else do
-			hPutStrLn stderr "\nUser did not grant access to their terminal."
-
-data DeveloperState = DeveloperState
-	{ lastSeen :: Hash
-	, sentSince :: [B.ByteString]
-	, enteredSince :: [Hash]
-	, lastActivity :: Hash
-	, developerSessionKey :: MySessionKey
-	, developerSigVerifier :: SigVerifier
-	}
-
--- | Read things typed by the developer, and forward them to the TChan.
-sendTtyInput :: TChan (Message Entered) -> TVar DeveloperState -> Logger -> IO ()
-sendTtyInput ichan devstate logger = go
-  where
-	go = do
-		b <- B.hGetSome stdin 1024
-		if b == B.empty
-			then return ()
-			else send b
-	send b = do
-		act <- atomically $ do
-			ds <- readTVar devstate
-			let ed = if lastActivity ds == lastSeen ds
-				then B.concat $ sentSince ds
-				else case reverse (sentSince ds) of
-					[] -> mempty
-					(lb:_) -> lb
-			let entered = Entered
-				{ enteredData = Val b
-				, echoData = Val ed
-				}
-			let act = mkSigned (developerSessionKey ds) $
-				Activity entered (Just $ lastActivity ds)
-			writeTChan ichan (ActivityMessage act)
-			let acth = hash act
-			let ds' = ds
-				{ sentSince = sentSince ds ++ [b]
-				, enteredSince = enteredSince ds ++ [acth]
-				, lastActivity = acth
-				}
-			writeTVar devstate ds'
-			return act
-		logger $ Developer $ ActivityMessage act
-		go
-
--- | Read activity from the TChan and display it to the developer.
-sendTtyOutput :: TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO ()
-sendTtyOutput ochan devstate logger = go
-  where
-	go = do
-		(o, msg) <- atomically $ getUserMessage ochan devstate
-		logger $ User msg
-		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 :: TChan (Message Entered) -> TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO Bool
-authUser ichan ochan devstate logger = do
-	ds <- atomically $ readTVar devstate
-	pk <- myPublicKey (developerSessionKey ds)
-	let msg = ControlMessage $ mkSigned (developerSessionKey ds) 
-		(Control (SessionKey pk))
-	atomically $ writeTChan ichan msg
-	logger $ Developer msg
-	waitresp pk
-  where
-	waitresp pk = do
-		(o, msg) <- atomically $ getUserMessage ochan devstate
-		logger $ User msg
-		emitOutput o
-		case o of
-			GotControl (SessionKeyAccepted pk')
-				| pk' == pk -> return True
-			GotControl (SessionKeyRejected pk')
-				| pk' == pk -> return False
-			_ -> waitresp pk
-
-data Output
-	= TtyOutput B.ByteString 
-	| Beep
-	| ProtocolError String
-	| GotControl ControlAction
-
-emitOutput :: Output -> IO ()
-emitOutput (ProtocolError e) =
-	protocolError e
-emitOutput (TtyOutput b) = do
-	B.hPut stdout b
-	hFlush stdout
-emitOutput Beep = do
-	B.hPut stdout "\a"
-	hFlush stdout
-emitOutput (GotControl _) =
-	return ()
-
--- | Get messages from user, check their signature, and make sure that they
--- are properly chained from past messages, before returning.
-getUserMessage :: TChan (Message Seen) -> TVar DeveloperState -> STM (Output, Message Seen)
-getUserMessage ochan devstate = do
-	msg <- readTChan ochan
-	ds <- readTVar devstate
-	-- Check signature before doing anything else.
-	if verifySigned (developerSigVerifier ds) msg
-		then do
-			o <- process ds msg
-			return (o, msg)
-		else getUserMessage ochan devstate
-  where
-	process 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
-		-- When they rejected a message we sent,
-		-- anything we sent subsequently will
-		-- also be rejected, so forget about it.
-		let ds' = ds
-			{ sentSince = mempty
-			, enteredSince = mempty
-			}
-		writeTVar devstate ds'
-		return Beep
-	process _ (ControlMessage (Control c@(SessionKey _) _)) =
-		return (GotControl c)
-	process _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) =
-		return (GotControl c)
-	process _ (ControlMessage (Control c@(SessionKeyRejected _) _)) =
-		return (GotControl c)
-
--- | Check if the Seen activity is legal, forming a chain with previous
--- ones, and returns an updated DeveloperState.
---
--- Does not check the signature.
-isLegalSeen :: Activity Seen -> DeveloperState -> (Bool, DeveloperState)
-isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _) ds
-	-- Does it chain to the last Seen activity?
-	| hp == lastSeen ds = 
-		-- Trim sentSince and enteredSince to
-		-- values after the Seen value.
-		let ss = sentSince ds
-		    es = enteredSince ds
-		    n = B.length b
-		    (ss', es') = if b `B.isPrefixOf` mconcat ss
-		    	then (drop n ss, drop n es)
-			else (mempty, mempty)
-		in yes ds
-			{ lastSeen = acth
-			, sentSince = ss'
-			, enteredSince = es'
-			, lastActivity = acth
-			}
-	-- Does it chain to something we've entered since the last Seen
-	-- value? Eg, user sent A, we replied B C, and the user has
-	-- now replied to B.
-	-- If so, we can drop B (and anything before it) from
-	-- enteredSince and sentSince.
-	| otherwise = case elemIndex hp (enteredSince ds) of
-		Nothing -> (False, ds)
-		Just i -> 
-			let ss = sentSince ds
-			    es = enteredSince ds
-			    ss' = drop (i+1) ss
-			    es' = drop (i+1) es
-			in yes ds
-				{ lastSeen = acth
-				, sentSince = ss'
-				, enteredSince = es'
-				, lastActivity = acth
-				}
-  where
-	acth = hash act
-	yes ds' = (True, ds')
-isLegalSeen (Activity _ Nothing _) ds = (False, ds)
-
-user :: B.ByteString -> Pty -> TChan (Message Entered) -> TChan (Message Seen) -> IO ()
-user starttxt p ichan ochan = withLogger "debug-me.log" $ \logger -> do
-	-- Start by establishing our session key, and displaying the starttxt.
-	let initialmessage msg = do
-		atomically $ writeTChan ochan msg
-		logger $ User msg
-	sk <- genMySessionKey
-	pk <- myPublicKey sk
-	let c = mkSigned sk $ Control (SessionKey pk)
-	initialmessage $ ControlMessage c
-	let act = mkSigned sk $ Activity (Seen (Val (starttxt <> "\r\n"))) Nothing
-	let startmsg = ActivityMessage act
-	initialmessage startmsg
-	l <- mkLog (User startmsg) <$> getPOSIXTime
-	us <- newTVarIO $ UserState
-		{ backLog = l :| []
-		, userSessionKey = sk
-		, userSigVerifier = mempty
-		}
-	_ <- sendPtyOutput p ochan us logger
-		`concurrently` sendPtyInput ichan ochan p us logger
-	return ()
-  where
-
--- | Log of recent Activity, with the most recent first.
-type Backlog = NonEmpty Log
-
-data UserState = UserState
-	{ backLog :: Backlog
-	, userSessionKey :: MySessionKey
-	, userSigVerifier :: SigVerifier
-	}
-
--- | Forward things written to the Pty out the TChan.
-sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO ()
-sendPtyOutput p ochan us logger = go
-  where
-	go = do
-		b <- readPty p
-		now <- getPOSIXTime
-		l <- atomically $ do
-			let seen = Seen (Val b)
-			sendDeveloper ochan us seen now
-		logger $ User l
-		go
-
-class SendableToDeveloper t where
-	sendDeveloper :: TChan (Message Seen) -> TVar UserState -> t -> POSIXTime -> STM (Message Seen)
-
-instance SendableToDeveloper Seen where
-	sendDeveloper ochan us seen now = do
-		st <- readTVar us
-		let bl@(prev :| _) = backLog st
-		let msg = ActivityMessage $
-			mkSigned (userSessionKey st) $ 
-				Activity seen (loggedHash prev)
-		let l = mkLog (User msg) now
-		writeTChan ochan msg
-		writeTVar us $ st { backLog = l :| toList bl }
-		return msg
-
-instance SendableToDeveloper ControlAction where
-	sendDeveloper ochan us c _now = do
-		st <- readTVar us
-		let msg = ControlMessage $
-			mkSigned (userSessionKey st) (Control c)
-		-- Control messages are not kept in the backlog.
-		writeTChan ochan msg
-		return msg
-
--- | Read things to be entered from the TChan, verify if they're legal,
--- and send them to the Pty.
-sendPtyInput :: TChan (Message Entered) -> TChan (Message Seen) -> Pty -> TVar UserState -> Logger -> IO ()
-sendPtyInput ichan ochan p us logger = go
-  where
-	go = do
-		networkDelay
-		now <- getPOSIXTime
-		v <- atomically $ getDeveloperMessage ichan ochan us now
-		case v of
-			InputMessage msg@(ActivityMessage entered) -> do
-				logger $ Developer msg
-				writePty p $ val $ enteredData $ activity entered
-				go
-			InputMessage msg@(ControlMessage (Control c _)) -> do
-				logger $ Developer msg
-				case c of
-					SessionKey pk -> do
-						checkDeveloperPublicKey ochan us logger pk
-						go
-					Rejected r -> protocolError $ "User side received a Rejected: " ++ show r
-					SessionKeyAccepted _ -> protocolError "User side received a SessionKeyAccepted"
-					SessionKeyRejected _ -> protocolError "User side received a SessionKeyRejected"
-			RejectedMessage rej -> do
-				logger $ User rej
-				go
-			BadlySignedMessage _ -> go
-
-data Input
-	= InputMessage (Message Entered)
-	| RejectedMessage (Message Seen)
-	| BadlySignedMessage (Message Entered)
-
--- Get message from developer, verify its signature is from a developer we
--- have allowed (unless it's a SessionKey control message, then the
--- 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 :: TChan (Message Entered) -> TChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input
-getDeveloperMessage ichan ochan us now = do
-	msg <- readTChan ichan
-	st <- readTVar us
-	case msg of
-		ControlMessage (Control (SessionKey pk) _) -> do
-			let sigverifier = mkSigVerifier pk
-			if verifySigned sigverifier msg
-				then return (InputMessage msg)
-				else return (BadlySignedMessage msg)
-		_ -> if verifySigned (userSigVerifier st) msg
-			then case msg of
-				ActivityMessage entered -> do
-					-- Don't need to retain backlog
-					-- before the Activity that entered
-					-- references.
-					let bl' = reduceBacklog $
-						truncateBacklog (backLog st) entered
-					if isLegalEntered entered (st { backLog = bl' })
-						then do
-							let l = mkLog (Developer msg) now
-							writeTVar us (st { backLog = l :| toList bl' })
-							return (InputMessage msg)
-						else do
-							let reject = Rejected entered
-							RejectedMessage <$> sendDeveloper ochan us reject now
-				ControlMessage (Control _ _) ->
-					return (InputMessage msg)
-			else return (BadlySignedMessage msg)
-
--- | Check if the public key a developer presented is one we want to use,
--- and if so, add it to the userSigVerifier.
-checkDeveloperPublicKey :: TChan (Message Seen) -> TVar UserState -> Logger -> PublicKey -> IO ()
-checkDeveloperPublicKey ochan us logger pk = do
-	now <- getPOSIXTime
-	-- TODO check gpg sig..
-	msg <- atomically $ do
-		st <- readTVar us
-		let sv = userSigVerifier st
-		let sv' = sv `mappend` mkSigVerifier pk
-		let st' = st { userSigVerifier = sv' }
-		writeTVar us st'
-		sendDeveloper ochan us (SessionKeyAccepted pk) now
-	logger $ User msg
-
--- | Truncate the Backlog to remove entries older than the one
--- that the Activity Entered refers to, but only if the referred
--- to Activity is an Activity Seen. 
---
--- Once the developer has referred to a given Activity Seen in
--- their Activity Entered, they cannot refer backwards to anything
--- that came before it.
---
--- If the Activity refers to an item not in the backlog, no truncation is
--- done.
-truncateBacklog :: Backlog -> Activity Entered -> Backlog
-truncateBacklog (b :| l) (Activity _ (Just hp) _)
-	| truncationpoint b = b :| []
-	| otherwise = b :| go [] l
-  where
-	go c [] = reverse c
-	go c (x:xs)
-		| truncationpoint x = reverse (x:c)
-		| otherwise = go (x:c) xs
-	truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp
-	truncationpoint _ = False
-truncateBacklog bl (Activity _ Nothing _) = bl
-
--- | To avoid DOS attacks that try to fill up the backlog and so use all
--- memory, don't let the backlog contain more than 1000 items, or
--- more than 16 megabytes of total data. (Excluding the most recent
--- item).
-reduceBacklog :: Backlog -> Backlog
-reduceBacklog (b :| l) = b :| go 0 (take 1000 l)
-  where
-	go _ [] = []
-	go n (x:xs)
-		| n > 16777216 = []
-		| otherwise = x : go (n + dataSize x) xs
-
--- | Entered activity is legal when it points to the last logged activity,
--- because this guarantees that the person who entered it saw
--- the current state of the system before manipulating it.
---
--- To support typeahead on slow links, some echoData may be provided
--- in the Entered activity. If the Entered activity points
--- to an older activity, then the echoData must match the
--- concatenation of all Seen activities after that one, up to the
--- last logged activity.
---
--- Activities that do not enter data point to the first message
--- sent in the debug-me session.
---
--- Does not check the signature.
-isLegalEntered :: Activity Entered -> UserState -> Bool
-isLegalEntered (Activity _ Nothing _) _ = False
-isLegalEntered (Activity a (Just hp) _) us
-	| loggedHash lastact == Just hp = True
-	| B.null (val (echoData a)) = False -- optimisation
-	| any (== Just hp) (map loggedHash bl) =
-		let sincehp = reverse (lastact : takeWhile (\l -> loggedHash l /= Just hp) bl)
-		in echoData a == mconcat (map (getseen . loggedMessage) sincehp)
-	| otherwise = False
-  where
-	(lastact :| bl) = backLog us
-	getseen (User (ActivityMessage as)) = seenData $ activity as
-	getseen _ = mempty
-
--- | Temporary hack while user and developer share a process.
-protocolError :: String -> IO a
-protocolError e = do
-	hPutStrLn stderr e
-	hFlush stderr
-	_ <- exitWith (ExitFailure 101)
-	error e
+		UserMode o -> Role.User.run o >>= exitWith
+		DeveloperMode o -> Role.Developer.run o
+		GraphvizMode o -> graphviz o
+		ReplayMode o -> replay o
+		ServerMode o -> server o