user gpg key checking and prompting done!

1 files changed, 20 insertions, 10 deletions

diff --git a/Gpg.hs b/Gpg.hs
index 0d58f4f..8d8df0b 100644
--- a/Gpg.hs
+++ b/Gpg.hs
@@ -7,6 +7,7 @@ import Crypto
 
 import Data.ByteArray (convert)
 import qualified Data.ByteString as B
+import qualified Data.ByteString.UTF8 as B8
 import System.IO
 import System.Posix.IO hiding (createPipe)
 import System.Process
@@ -17,6 +18,7 @@ import System.Directory
 import Control.Concurrent.Async
 
 newtype GpgKeyId = GpgKeyId String
+	deriving (Show)
 
 newtype GpgSign = GpgSign Bool
 
@@ -58,16 +60,17 @@ gpgSign pk = do
 -- 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.
+--
+-- This relies on gpgSign using --clearsign, so on successful
+-- verification, the JSON encoded PublicKey is output to gpg's
+-- stdout.
 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.
 	(Just hin, Just hout, _, pid) <- createProcess $
-		(proc "gpg" (extraopts ++ ["--verify", "--output", "-"]))
+		(proc "gpg" (verifyopts statuswritefd))
 			{ std_in = CreatePipe
 			, std_out = CreatePipe
 			}
@@ -78,14 +81,21 @@ gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do
 	(signeddata, gpgkeyid) <- B.hGetContents hout
 		`concurrently` (parseStatusFd <$> hGetContents statusreadh)
 	st <- waitForProcess pid
-	return $ case st of
-		ExitSuccess
-			| val (hashValue (hash pk)) == signeddata -> gpgkeyid
-		_ -> Nothing
+	let norm = filter (not . B.null) . B8.lines
+	let pkissigned = norm (val (hashValue (hash pk))) == norm signeddata
+	return $ if st == ExitSuccess && pkissigned
+		then gpgkeyid
+		else Nothing
   where
 	extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts
 		then gpgopts
-		else map ("--keyserver=" ++) defaultKeyServers ++ gpgopts
+		else concatMap (\s -> ["--keyserver", s]) defaultKeyServers
+			++ gpgopts
+	verifyopts statuswritefd = extraopts ++
+		[ "--status-fd", show statuswritefd
+		, "--verify"
+		, "--output", "-"
+		]
 
 -- | Default keyservers to use.
 defaultKeyServers :: [String]
@@ -98,5 +108,5 @@ parseStatusFd :: String -> Maybe GpgKeyId
 parseStatusFd = go . map words . lines
   where
 	go [] = Nothing
-	go ((_:"VALIDSIG":keyid:_):_) = Just (GpgKeyId keyid)
+	go ((_:"VALIDSIG":_:_:_:_:_:_:_:_:_:keyid:_):_) = Just (GpgKeyId keyid)
 	go (_:rest) = go rest