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.

2 files changed, 491 insertions, 0 deletions

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