fully working signatures

This commit was sponsored by Ethan Aubin.

1 files changed, 204 insertions, 85 deletions

diff --git a/debug-me.hs b/debug-me.hs
index e16576b..dc50b1c 100644
--- a/debug-me.hs
+++ b/debug-me.hs
@@ -50,36 +50,58 @@ test = do
 		return exitstatus
 
 networkDelay :: IO ()
-networkDelay = threadDelay 800000 -- 800 ms ; the latency to geosync orbit
--- networkDelay = threadDelay 150000 -- 150 ms ; transatlantic latency
+-- 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 sig) -> do
-			B.hPut stdout b
-			hFlush stdout	
-			return (hash act)
-		_ -> protocolError $ "Unexpected startup: " ++ show startmsg
+		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
 		}
-	_ <- sendTtyInput ichan devstate logger
-		`concurrently` sendTtyOutput ochan devstate logger
-	return ()
+	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
 	}
-	deriving (Show)
 
 -- | Read things typed by the developer, and forward them to the TChan.
 sendTtyInput :: TChan (Message Entered) -> TVar DeveloperState -> Logger -> IO ()
@@ -102,7 +124,8 @@ sendTtyInput ichan devstate logger = go
 				{ enteredData = Val b
 				, echoData = Val ed
 				}
-			let act = Activity entered (Just $ lastActivity ds) dummySignature
+			let act = mkSigned (developerSessionKey ds) $
+				Activity entered (Just $ lastActivity ds)
 			writeTChan ichan (ActivityMessage act)
 			let acth = hash act
 			let ds' = ds
@@ -120,55 +143,96 @@ sendTtyOutput :: TChan (Message Seen) -> TVar DeveloperState -> Logger -> IO ()
 sendTtyOutput ochan devstate logger = go
   where
 	go = do
-		(v, msg) <- atomically $ processOutput ochan devstate
+		(o, msg) <- atomically $ getUserMessage ochan devstate
 		logger $ User msg
-		case v of
-			ProtocolError e -> protocolError e
-			TtyOutput b -> do
-				B.hPut stdout b
-				hFlush stdout
-				go
-			Beep -> do
-				B.hPut stdout "\a"
-				hFlush stdout
-				go
-			NoOutput -> go
+		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 | NoOutput
+data Output
+	= TtyOutput B.ByteString 
+	| Beep
+	| ProtocolError String
+	| GotControl ControlAction
 
-processOutput :: TChan (Message Seen) -> TVar DeveloperState -> STM (Output, Message Seen)
-processOutput ochan devstate = do
+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
-	-- TODO check sig before doing anything else
-	o <- case msg of
-		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) ++ "\n" ++ show ds)
-		ControlMessage (Control c _) -> case c of
-			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
-					}
+	-- 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 Beep
-			SessionKey _ -> return NoOutput
-			SessionKeyAccepted _ -> return NoOutput
-			SessionKeyRejected _ -> return NoOutput
-	return (o, msg)
+				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) sig) 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
@@ -179,7 +243,7 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) sig) ds
 		    (ss', es') = if b `B.isPrefixOf` mconcat ss
 		    	then (drop n ss, drop n es)
 			else (mempty, mempty)
-		in yes $ DeveloperState
+		in yes ds
 			{ lastSeen = acth
 			, sentSince = ss'
 			, enteredSince = es'
@@ -197,7 +261,7 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) sig) ds
 			    es = enteredSince ds
 			    ss' = drop (i+1) ss
 			    es' = drop (i+1) es
-			in yes $ DeveloperState
+			in yes ds
 				{ lastSeen = acth
 				, sentSince = ss'
 				, enteredSince = es'
@@ -210,25 +274,36 @@ 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
-	let act = Activity (Seen (Val (starttxt <> "\r\n"))) Nothing dummySignature
+	-- 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
-	logger $ User startmsg
+	initialmessage startmsg
 	l <- mkLog (User startmsg) <$> getPOSIXTime
-	atomically $ writeTChan ochan startmsg
 	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
 	}
-	deriving (Show)
 
 -- | Forward things written to the Pty out the TChan.
 sendPtyOutput :: Pty -> TChan (Message Seen) -> TVar UserState -> Logger -> IO ()
@@ -250,16 +325,19 @@ instance SendableToDeveloper Seen where
 	sendDeveloper ochan us seen now = do
 		st <- readTVar us
 		let bl@(prev :| _) = backLog st
-		let msg = ActivityMessage $ 
-			Activity seen (loggedHash prev) dummySignature
+		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
-		let msg = ControlMessage $ Control c dummySignature
+	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
@@ -272,39 +350,78 @@ sendPtyInput ichan ochan p us logger = go
 	go = do
 		networkDelay
 		now <- getPOSIXTime
-		v <- atomically $ do
-			msg <- readTChan ichan
-			st <- readTVar us
-			-- TODO check signature first
-			case msg of
+		v <- atomically $ getDeveloperMessage ichan ochan us now
+		case v of
+			InputMessage (ActivityMessage entered) -> do
+				logger $ Developer $ ActivityMessage entered
+				writePty p $ val $ enteredData $ activity entered
+				go
+			InputMessage (ControlMessage (Control c _)) -> 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.
+					-- 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 (Right msg)
+							return (InputMessage msg)
 						else do
 							let reject = Rejected entered
-							Left <$> sendDeveloper ochan us reject now
+							RejectedMessage <$> sendDeveloper ochan us reject now
 				ControlMessage (Control _ _) ->
-					return (Right msg)
-		case v of
-			Right (ActivityMessage entered) -> do
-				logger $ Developer $ ActivityMessage entered
-				writePty p $ val $ enteredData $ activity entered
-				go
-			Right (ControlMessage (Control c _)) -> case c of
-				Rejected r -> protocolError $ "User side received a Rejected: " ++ show r
-				SessionKey _ -> protocolError "Adding session keys to running session not supported yet"
-				SessionKeyAccepted _ -> protocolError "User side received a SessionKeyAccepted"
-				SessionKeyRejected _ -> protocolError "User side received a SessionKeyRejected"
-			Left rejact -> do
-				logger $ User rejact
-				go
+					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
@@ -353,9 +470,11 @@ reduceBacklog (b :| l) = b :| go 0 (take 1000 l)
 --
 -- 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) sig) us
+isLegalEntered (Activity a (Just hp) _) us
 	| loggedHash lastact == Just hp = True
 	| B.null (val (echoData a)) = False -- optimisation
 	| any (== Just hp) (map loggedHash bl) =