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.

1 files changed, 9 insertions, 487 deletions

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