add Gpg web of trust parser

1 files changed, 29 insertions, 10 deletions

diff --git a/Gpg.hs b/Gpg.hs
index e3f4102..0d58f4f 100644
--- a/Gpg.hs
+++ b/Gpg.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings, RankNTypes, DeriveGeneric #-}
-
 module Gpg where
 
 import Val
@@ -10,11 +8,15 @@ import Crypto
 import Data.ByteArray (convert)
 import qualified Data.ByteString as B
 import System.IO
+import System.Posix.IO hiding (createPipe)
 import System.Process
 import System.Exit
 import Data.List
 import Control.Exception
 import System.Directory
+import Control.Concurrent.Async
+
+newtype GpgKeyId = GpgKeyId String
 
 newtype GpgSign = GpgSign Bool
 
@@ -47,13 +49,20 @@ gpgSign pk = do
 		ExitSuccess -> return $ GpgSigned pk sig
 		ExitFailure _ -> error "gpg failed"
 
--- | Verify the gpg signature. The key will be retrieved from a keyserver
--- if possible. Gpg outputs to stderr information about who signed the
+-- | Verify the gpg signature and return the keyid that signed it.
+-- Also makes sure that the gpg signed data is the hash of the 
+-- debug-me PublicKey.
+--
+-- The gpg key will be retrieved from a keyserver if necessary.
+--
+-- Gpg outputs to stderr information about who signed the
 -- data, so that will be visible to the user when eg, prompting
 -- them if they want to accept a connection from that person.
-gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO Bool
-gpgVerify _ (UnSigned _) = return False
-gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do	
+gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO (Maybe GpgKeyId)
+gpgVerify _ (UnSigned _) = return Nothing
+gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do
+	(statusreadh, statuswriteh) <- createPipe
+	statuswritefd <- handleToFd statuswriteh
 	-- This relies on gpgSign using --clearsign, so on successful
 	-- verification, the JSON encoded PublicKey is output to gpg's
 	-- stdout.
@@ -62,14 +71,17 @@ gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do
 			{ std_in = CreatePipe
 			, std_out = CreatePipe
 			}
+	closeFd statuswritefd
 	B.hPut hin sig
 	hClose hin
 	hSetBinaryMode hout True
-	signeddata <- B.hGetContents hout
+	(signeddata, gpgkeyid) <- B.hGetContents hout
+		`concurrently` (parseStatusFd <$> hGetContents statusreadh)
 	st <- waitForProcess pid
 	return $ case st of
-		ExitFailure _ -> False
-		ExitSuccess -> val (hashValue (hash pk)) == signeddata
+		ExitSuccess
+			| val (hashValue (hash pk)) == signeddata -> gpgkeyid
+		_ -> Nothing
   where
 	extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts
 		then gpgopts
@@ -81,3 +93,10 @@ defaultKeyServers =
 	[ "pool.sks-keyservers.net"
 	, "pgpkeys.mit.edu"
 	]
+
+parseStatusFd :: String -> Maybe GpgKeyId
+parseStatusFd = go . map words . lines
+  where
+	go [] = Nothing
+	go ((_:"VALIDSIG":keyid:_):_) = Just (GpgKeyId keyid)
+	go (_:rest) = go rest