gpg sign developer session key

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

This commit was sponsored by andrea rota.

8 files changed, 140 insertions, 32 deletions

diff --git a/CmdLine.hs b/CmdLine.hs
index f00f0be..a2f900b 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -18,7 +18,8 @@ data Mode
 	| ServerMode ServerOpts
 
 data UserOpts = UserOpts
-	{ cmdToRun :: Maybe (String, [String])
+	{ gpgOpts :: [String]
+	, cmdToRun :: Maybe (String, [String])
 	}
 
 type UrlString = String
@@ -62,7 +63,12 @@ parseMode = (UserMode <$> parseuser)
 	<|> (ServerMode <$> parseserver)
   where
 	parseuser = UserOpts
-		<$> optional ((,)
+		<$> many (option str
+			( long "gpg-opt"
+			<> short 'g'
+			<> help "option to pass to gpg"
+			))
+		<*> optional ((,)
 			<$> strArgument (metavar "cmd")
 			<*> many (strArgument (metavar "opts")))
 	parsegraphviz = GraphvizOpts
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"
+	]
diff --git a/Hash.hs b/Hash.hs
index c9b45e0..3bfb5a2 100644
--- a/Hash.hs
+++ b/Hash.hs
@@ -56,12 +56,15 @@ instance Hashable Signature where
 	hash (OtherSignature s) = hash $ Tagged "OtherSignature" s
 
 instance Hashable PublicKey where
-	hash (PublicKey v gpgsig) = hash $ Tagged "PublicKey"
-		[hash v, hash gpgsig]
+	hash (PublicKey v) = hash $ Tagged "PublicKey" v
 
 instance Hashable GpgSig where
 	hash (GpgSig v) = hash $ Tagged "GpgSig" v
 
+instance Hashable a => Hashable (PerhapsSigned a) where
+	hash (GpgSigned a sig) = hash $ Tagged "GpgSigned" [hash a, hash sig]
+	hash (UnSigned a) = hash $ Tagged "UnSigned" a
+
 instance Hashable ElapsedTime where
 	hash (ElapsedTime n) = hash $ Tagged "ElapsedTime" $ C8.pack $ show n
 
diff --git a/Role/Developer.hs b/Role/Developer.hs
index 8e27b30..d5c3463 100644
--- a/Role/Developer.hs
+++ b/Role/Developer.hs
@@ -122,12 +122,14 @@ sendTtyOutput ochan devstate logger = go
 authUser :: TMChan (Message Entered) -> TMChan LogMessage -> TVar DeveloperState -> Logger -> IO Bool
 authUser ichan ochan devstate logger = do
 	ds <- atomically $ readTVar devstate
-	pk <- myPublicKey (developerSessionKey ds)
+	spk <- myPublicKey (developerSessionKey ds) (GpgSign True)
 	let msg = ControlMessage $ mkSigned (developerSessionKey ds) 
-		(Control (SessionKey pk))
+		(Control (SessionKey spk))
 	atomically $ writeTMChan ichan msg
 	logger $ Developer msg
-	waitresp pk
+	waitresp $ case spk of
+		GpgSigned pk _ -> pk
+		UnSigned pk -> pk
   where
 	waitresp pk = do
 		ts <- getPOSIXTime
@@ -180,8 +182,10 @@ getServerMessage ochan devstate ts = do
 					return (Just (o, User msg))
 				else ignore
 		-- When other developers connect, learn their SessionKeys.
-		Just (Developer msg@(ControlMessage (Control (SessionKey pk) _))) -> do
-			let sigverifier = mkSigVerifier pk
+		Just (Developer msg@(ControlMessage (Control (SessionKey spk) _))) -> do
+			let sigverifier = mkSigVerifier $ case spk of
+				GpgSigned pk _ -> pk
+				UnSigned pk -> pk
 			if verifySigned sigverifier msg
 				then do
 					ds <- readTVar devstate
@@ -290,9 +294,12 @@ processSessionStart ochan logger = do
 		<$> atomically (readTMChan ochan)
 	logger sessionmsg
 	sigverifier <- case sessionmsg of
-		User (ControlMessage c@(Control (SessionKey pk) _)) ->
+		User (ControlMessage c@(Control (SessionKey spk) _)) -> do
+			let pk = case spk of
+				GpgSigned k _ -> k
+				UnSigned k -> k
 			let sv = mkSigVerifier pk
-			in if verifySigned sv c
+			if verifySigned sv c
 				then return sv
 				else error "Badly signed session initialization message"
 		_ -> error $ "Unexpected session initialization message: " ++ show sessionmsg
diff --git a/Role/User.hs b/Role/User.hs
index fc6eaea..51688af 100644
--- a/Role/User.hs
+++ b/Role/User.hs
@@ -80,7 +80,7 @@ startProtocol starttxt ochan logger = do
 		atomically $ writeTMChan ochan msg
 		logger $ User msg
 	sk <- genMySessionKey
-	pk <- myPublicKey sk
+	pk <- myPublicKey sk (GpgSign False)
 	let c = mkSigned sk $ Control (SessionKey pk)
 	initialmessage $ ControlMessage c
 	let starttxt' = rawLine starttxt
@@ -209,8 +209,10 @@ getDeveloperMessage' :: Message Entered -> TMChan (Message Seen) -> TVar UserSta
 getDeveloperMessage' msg ochan us now = do
 	st <- readTVar us
 	case msg of
-		ControlMessage (Control (SessionKey pk) _) -> do
-			let sigverifier = mkSigVerifier pk
+		ControlMessage (Control (SessionKey spk) _) -> do
+			let sigverifier = mkSigVerifier $ case spk of
+				GpgSigned pk _ -> pk
+				UnSigned pk -> pk
 			if verifySigned sigverifier msg
 				then return (InputMessage msg)
 				else return (BadlySignedMessage msg)
@@ -236,8 +238,8 @@ getDeveloperMessage' msg ochan us now = do
 
 -- | Check if the public key a developer presented is one we want to use,
 -- and if so, add it to the sigVerifier.
-checkDeveloperPublicKey :: TMChan (Message Seen) -> TVar UserState -> Logger -> PublicKey -> IO ()
-checkDeveloperPublicKey ochan us logger pk = do
+checkDeveloperPublicKey :: TMChan (Message Seen) -> TVar UserState -> Logger -> PerhapsSigned PublicKey -> IO ()
+checkDeveloperPublicKey ochan us logger spk = do
 	now <- getPOSIXTime
 	-- TODO check gpg sig..
 	msg <- atomically $ do
@@ -248,6 +250,10 @@ checkDeveloperPublicKey ochan us logger pk = do
 		writeTVar us st'
 		sendDeveloper ochan us (SessionKeyAccepted pk) now
 	logger $ User msg
+  where
+	pk = case spk of
+		GpgSigned k _ -> k
+		UnSigned k -> k
 
 -- | Truncate the Backlog to remove entries older than the one
 -- that the Activity Entered refers to, but only if the referred
diff --git a/TODO b/TODO
index 30f884c..ed0fc45 100644
--- a/TODO
+++ b/TODO
@@ -35,6 +35,9 @@
   Everything else in debug-me checks a session's proof as it goes.
   And, everything that saves a log file checks the proof as it goes,
   so perhaps this is not actually necessary?
+* Add a mode that, given a log file, displays what developer(s) gpg keys
+  signed activity in the log file. For use when a developer did something
+  wrong, to examine the proof of malfesence.
 * gpg key downloading, web of trust checking, prompting
   Alternatively, let debug-me be started with a gpg key,
   this way a project's website can instruct their users to
diff --git a/Types.hs b/Types.hs
index c202f14..2dc5d28 100644
--- a/Types.hs
+++ b/Types.hs
@@ -85,7 +85,7 @@ instance DataSize Control where
 data ControlAction
 	= Rejected (Activity Entered)
 	-- ^ sent by user to indicate when an Entered value was rejected.
-	| SessionKey PublicKey
+	| SessionKey (PerhapsSigned PublicKey)
 	-- ^ sent by user at start, and later by developer,
 	-- to indicate their session key
 	| SessionKeyAccepted PublicKey
@@ -126,13 +126,22 @@ instance DataSize Signature where
 	dataSize (OtherSignature v) = dataSize v
 
 -- | A public key used for a debug-me session.
--- It may be signed with a gpg key.
-data PublicKey = PublicKey Val (Maybe GpgSig)
+data PublicKey = PublicKey Val
 	deriving (Show, Generic, Eq)
 
 instance DataSize PublicKey where
 	-- ed25519 public keys are 32 bytes
-	dataSize (PublicKey _ ms) = 32 + maybe 0 dataSize ms
+	dataSize (PublicKey _) = 32
+
+-- | A value that may be gpg signed.
+data PerhapsSigned a
+	= GpgSigned a GpgSig
+	| UnSigned a
+	deriving (Show, Generic, Eq)
+
+instance DataSize a => DataSize (PerhapsSigned a) where
+	dataSize (GpgSigned a sig) = dataSize a + dataSize sig
+	dataSize (UnSigned a) = dataSize a
 
 -- | A signature made with a gpg key.
 newtype GpgSig = GpgSig Val
@@ -226,3 +235,10 @@ instance ToJSON ControlAction where
 	toEncoding = genericToEncoding sumOptions
 instance FromJSON ControlAction where
 	parseJSON = genericParseJSON sumOptions
+
+instance Binary (PerhapsSigned PublicKey)
+instance ToJSON (PerhapsSigned PublicKey) where
+	toJSON = genericToJSON sumOptions
+	toEncoding = genericToEncoding sumOptions
+instance FromJSON (PerhapsSigned PublicKey) where
+	parseJSON = genericParseJSON sumOptions
diff --git a/debug-me.1 b/debug-me.1
index 130c90c..ee12326 100644
--- a/debug-me.1
+++ b/debug-me.1
@@ -24,6 +24,12 @@ to adjust their reputation.
 .IP "-- cmd opts"
 Normally debug-me will run your login shell. To run some other command,
 pass the command and any options after "--".
+.PP
+.IP "--gpg-opt=option"
+debug-me runs gpg to verify the GPG key of a developer. To pass options to
+gpg, use --gpg-opt with the option to pass. For example:
+--gpg-opt=--keyserver=pgpkeys.mit.edu
+This can be done multiple times.
 .IP "--debug url"
 Connect to a debug-me session on the specified url. The developer runs
 debug-me with this option to see and interact with the user's bug.