split module

1 files changed, 83 insertions, 0 deletions

diff --git a/Gpg.hs b/Gpg.hs
new file mode 100644
index 0000000..e3f4102
--- /dev/null
+++ b/Gpg.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings, RankNTypes, DeriveGeneric #-}
+
+module Gpg where
+
+import Val
+import Hash
+import Types
+import Crypto
+
+import Data.ByteArray (convert)
+import qualified Data.ByteString as B
+import System.IO
+import System.Process
+import System.Exit
+import Data.List
+import Control.Exception
+import System.Directory
+
+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."
+	-- Write it to a temp file because gpg sometimes is unhappy
+	-- about password prompting when stdin is not connected to
+	-- the console.
+	tmpdir <- getTemporaryDirectory
+	(tmpfile, tmph) <- openTempFile tmpdir "debug-me.tmp"
+	B.hPut tmph $ val $ hashValue $ hash pk
+	hClose tmph
+	(_, Just hout, _, pid) <- createProcess $
+		(proc "gpg" ["--output", "-", "--clearsign", "-a", tmpfile])
+			{ std_out = CreatePipe
+			}
+	hSetBinaryMode hout True
+	sig <- GpgSig . Val <$> B.hGetContents hout
+	st <- waitForProcess pid
+	_ <- try (removeFile tmpfile) :: IO (Either IOException ())
+	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
+	signeddata <- B.hGetContents hout
+	st <- waitForProcess pid
+	return $ case st of
+		ExitFailure _ -> False
+		ExitSuccess -> val (hashValue (hash pk)) == signeddata
+  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"
+	]