gpg sign developer session key

And part of what we need to have users verify them.

This commit was sponsored by andrea rota.

1 files changed, 73 insertions, 12 deletions

diff --git a/Crypto.hs b/Crypto.hs
index e56db89..b23c8de 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -1,16 +1,22 @@
-{-# LANGUAGE OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE OverloadedStrings, RankNTypes, DeriveGeneric #-}
 
 module Crypto where
 
 import Val
 import Hash
 import Types
+import Serialization
 
 import qualified Crypto.PubKey.Ed25519 as Ed25519
 import Crypto.Error
 import Crypto.Random.Entropy
 import Data.ByteArray (convert)
-import Data.ByteString
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import System.IO
+import System.Process
+import System.Exit
+import Data.List
 
 dummySignature :: Signature
 dummySignature = OtherSignature (Val mempty)
@@ -43,7 +49,7 @@ sign :: Signed v => MySessionKey -> v -> Signature
 sign (MySessionKey sk pk) v = Ed25519Signature $ Val $ convert $
 	Ed25519.sign sk pk (toSign v)
 
-toSign :: Signed v => v -> ByteString
+toSign :: Signed v => v -> B.ByteString
 toSign = val . hashValue . hashExceptSignature
 
 -- | Verifiy the signature of a Signed value.
@@ -56,10 +62,10 @@ verifySigned (SigVerifier verifier) v =
 				CryptoFailed _ -> False
 		OtherSignature _ -> False
 
-data SigVerifier = SigVerifier (ByteString -> Ed25519.Signature -> Bool)
+data SigVerifier = SigVerifier (B.ByteString -> Ed25519.Signature -> Bool)
 
 mkSigVerifier :: PublicKey -> SigVerifier
-mkSigVerifier (PublicKey (Val pk) _) = 
+mkSigVerifier (PublicKey (Val pk)) = 
 	case Ed25519.publicKey pk of
 		CryptoPassed pk' -> SigVerifier (Ed25519.verify pk')
 		CryptoFailed _ -> mempty
@@ -71,18 +77,73 @@ instance Monoid SigVerifier where
 
 data MySessionKey = MySessionKey Ed25519.SecretKey Ed25519.PublicKey
 
--- TODO add gpg signature when available
-myPublicKey :: MySessionKey -> IO PublicKey
-myPublicKey (MySessionKey _ pk) = do
-	let gpgsig = Nothing
-	return $ PublicKey (Val (convert pk)) gpgsig
-
 genMySessionKey :: IO MySessionKey
 genMySessionKey = do
 	-- Crypto.Random.Entropy may use rdrand, or /dev/random.
 	-- Even if you don't trust rdrand to be free of backdoors, 
 	-- it seems safe enough to use it for a session key that
 	-- is only used for signing, not encryption.
-	rand32 <- getEntropy 32 :: IO ByteString
+	rand32 <- getEntropy 32 :: IO B.ByteString
 	sk <- throwCryptoErrorIO $ Ed25519.secretKey rand32
 	return $ MySessionKey sk (Ed25519.toPublic sk)
+
+newtype GpgSign = GpgSign Bool
+
+myPublicKey :: MySessionKey -> GpgSign -> IO (PerhapsSigned PublicKey)
+myPublicKey (MySessionKey _ epk) (GpgSign gpgsign) = do
+	let pk = PublicKey (Val $ convert epk)
+	if gpgsign
+		then gpgSign pk
+		else return (UnSigned pk)
+
+gpgSign :: PublicKey -> IO (PerhapsSigned PublicKey)
+gpgSign pk = do
+	putStrLn "Using gpg to sign the debug-me session key."
+	(Just hin, Just hout, _, pid) <- createProcess $
+		(proc "gpg" ["--clearsign", "-a"])
+			{ std_in = CreatePipe
+			, std_out = CreatePipe
+			}
+	L.hPut hin $ encode pk
+	hClose hin
+	hSetBinaryMode hout True
+	sig <- GpgSig . Val <$> B.hGetContents hout
+	st <- waitForProcess pid
+	case st of
+		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
+-- 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	
+	-- 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", "-"]))
+			{ std_in = CreatePipe
+			, std_out = CreatePipe
+			}
+	B.hPut hin sig
+	hClose hin
+	hSetBinaryMode hout True
+	out <- L.hGetContents hout
+	st <- waitForProcess pid
+	return $ case st of
+		ExitFailure _ -> False
+		ExitSuccess -> Just pk == decode out
+  where
+	extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts
+		then gpgopts
+		else map ("--keyserver=" ++) defaultKeyServers ++ gpgopts
+
+-- | Default keyservers to use.
+defaultKeyServers :: [String]
+defaultKeyServers =
+	[ "pool.sks-keyservers.net"
+	, "pgpkeys.mit.edu"
+	]