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, 252 insertions, 0 deletions

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