user gpg key checking and prompting done!

1 files changed, 64 insertions, 24 deletions

diff --git a/ControlWindow.hs b/ControlWindow.hs
index cc63cef..02cffd6 100644
--- a/ControlWindow.hs
+++ b/ControlWindow.hs
@@ -8,6 +8,8 @@ import Types
 import CmdLine
 import ControlSocket
 import VirtualTerminal
+import Gpg
+import Gpg.Wot
 
 import System.IO
 import System.Environment
@@ -18,7 +20,8 @@ import Control.Concurrent.STM
 import Control.Concurrent.STM.TMChan
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
-import Data.ByteString.UTF8 (fromString)
+import Data.ByteString.UTF8 (fromString, toString)
+import Data.Char
 import Control.Monad
 import Data.Monoid
 import Prelude
@@ -38,7 +41,7 @@ controlWindow _ = do
 	-- window is open.
 	atomically $ writeTMChan ochan ControlWindowOpened
 	_ <- connectControlSocket socketfile ichan ochan
-		`race` displayInput ichan promptchan responsechan
+		`race` displayInput ochan ichan promptchan responsechan
 		`race` collectOutput ochan promptchan responsechan
 	return ()
 
@@ -66,39 +69,76 @@ openControlWindow = do
 	return (ichan, ochan)
 
 type Prompt = ()
-type Response = L.ByteString
+type Response = B.ByteString
 
 type PromptChan = TChan Prompt
 type ResponseChan = TChan Response
 
-displayInput :: TMChan ControlInput -> PromptChan -> ResponseChan -> IO ()
-displayInput ichan promptchan responsechan = loop
+collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO ()
+collectOutput ochan promptchan responsechan = do
+	myusername <- fromString <$> getLoginName
+	withLines stdin $ mapM_ $ processline myusername
+  where
+	processline myusername l = atomically $ do
+		-- Is any particular input being prompted for now?
+		mp <- tryReadTChan promptchan
+		case mp of
+			Just _ -> writeTChan responsechan $ L.toStrict l
+			Nothing -> writeTMChan ochan $ ControlOutputAction $
+				ChatMessage (Val myusername) (Val $ L.toStrict l)
+
+displayInput :: TMChan ControlOutput -> TMChan ControlInput -> PromptChan -> ResponseChan -> IO ()
+displayInput ochan ichan promptchan responsechan = loop
   where
 	loop = go =<< atomically (readTMChan ichan)
 	go Nothing = return ()
-	go (Just (ControlInputAction (SessionKey (GpgSigned _ devgpgsig)))) = do
-		error "TODO verify developer key"
+	go (Just (ControlInputAction (SessionKey k))) = do
+		askToAllow ochan promptchan responsechan k
+		loop
 	go (Just (ControlInputAction (ChatMessage username msg))) = do
 		B.putStr $ "<" <> val username <> "> " <> val msg
 		putStr "\n"
 		hFlush stdout
 		loop
-	go v = do
-		print v
-		loop
+	go _ = loop
 
-collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO ()
-collectOutput ochan promptchan responsechan = do
-	myusername <- fromString <$> getLoginName
-	withLines stdin $ mapM_ $ processline myusername
+askToAllow :: TMChan ControlOutput -> PromptChan -> ResponseChan -> PerhapsSigned PublicKey -> IO ()
+askToAllow ochan _ _ (UnSigned pk) = atomically $ writeTMChan ochan $
+	ControlOutputAction $ SessionKeyRejected pk
+askToAllow ochan promptchan responsechan k@(GpgSigned pk _) = do
+	putStrLn "Someone wants to connect to this debug-me session."
+	putStrLn "Checking their Gnupg signature ..."
+	v <- gpgVerify [] k
+	let reject = do
+		putStrLn "Rejecting their connection."
+		atomically $ writeTMChan ochan $
+			ControlOutputAction $ SessionKeyRejected pk
+	let accept = do
+		putStrLn "Accepting their connection. They can now enter commands in this debug-me session."
+		atomically $ writeTMChan ochan $
+			ControlOutputAction $ SessionKeyAccepted pk
+	case v of
+		Nothing -> do
+			putStrLn "Unable to download their Gnupg key, or signature verification failed."
+			reject
+		Just gpgkeyid -> do
+			putStrLn "Checking the Gnupg web of trust ..."
+			ss <- isInStrongSet gpgkeyid
+			ws <- downloadWotStats gpgkeyid
+			putStrLn $ describeWot ws ss
+			ok <- promptconnect
+			if ok
+				then accept
+				else reject
   where
-	processline myusername l
-		| "/" `L.isPrefixOf` l = atomically $ do
-			-- Is any particular input being prompted for now?
-			mp <- tryReadTChan promptchan
-			case mp of
-				Nothing -> return ()
-				Just _ -> writeTChan responsechan (L.drop 1 l)
-		| otherwise = atomically $
-			writeTMChan ochan $ ControlOutputAction $
-				ChatMessage (Val myusername) (Val $ L.toStrict l)
+	promptconnect = do
+		atomically $ writeTChan promptchan ()
+		putStr "Let them connect to the debug-me session and run commands? [y/n] "
+		hFlush stdout
+		r <- atomically $ readTChan responsechan
+		case map toLower (toString r) of
+			"y" -> return True
+			"yes" -> return True
+			"n" -> return False
+			"no" -> return False
+			_ -> promptconnect