debug-me-1.20170505: Gpg.hs

{- Copyright 2017 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

module Gpg where

import Val
import Hash
import Types
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
import System.Exit
import Control.Exception
import System.Directory
import Control.Concurrent.Async

newtype GpgKeyId = GpgKeyId String
	deriving (Show)

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)

-- | Sign a debug-me session PublicKey with gpg.
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 -> do
			-- Verify the just signed data to determine
			-- the gpg public key used to sign it. The gpg 
			-- public key is included in the GpgSigned data.
			v <- fst <$> gpgVerifyClearSigned sig
			case v of
				Just (gpgkeyid, _) -> do
					pubkey <- gpgExportPublicKey gpgkeyid
					return $ GpgSigned pk sig pubkey
				Nothing -> error "gpg sign verification failed"
		ExitFailure _ -> error "gpg sign failed"

-- | Export gpg public key in minimal form.
gpgExportPublicKey :: GpgKeyId -> IO GpgKeyExport
gpgExportPublicKey (GpgKeyId gpgkeyid) = do
	(_, Just hout, _, pid) <- createProcess $
		(proc "gpg" opts)
			{ std_out = CreatePipe
			}
	hSetBinaryMode hout True
	b <- B.hGetContents hout
	st <- waitForProcess pid
	if st == ExitSuccess
		then return $ GpgKeyExport $ Val b
		else error "gpg --export failed"
  where
	opts =
		[ "-a"
		, "--export-options", "no-export-attributes,export-minimal"
		, "--export", gpgkeyid
		]

gpgImportPublicKey :: GpgKeyExport -> IO ()
gpgImportPublicKey (GpgKeyExport (Val b)) = do
	(Just hin, Just hout, Just herr, pid) <- createProcess $
		(proc "gpg" [ "--import"] )
			{ std_in = CreatePipe
			, std_out = CreatePipe
			, std_err = CreatePipe
			}
	hSetBinaryMode hin True
	B.hPut hin b
	hClose hin
	_ <- B.hGetContents hout
		`concurrently` B.hGetContents herr
	_ <- waitForProcess pid
	return ()

-- | 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.
gpgVerify :: PerhapsSigned PublicKey -> IO (Maybe GpgKeyId, SignInfoDesc)
gpgVerify (UnSigned _) = return (Nothing, mempty)
gpgVerify (GpgSigned pk gpgsig keyexport) = do
	gpgImportPublicKey keyexport
	go =<< gpgVerifyClearSigned gpgsig
  where
	go (Nothing, s) = return (Nothing, s)
	go (Just (gpgkeyid, signeddata), s) = do
		let norm = filter (not . B.null) . B8.lines
		let pkissigned = norm signeddata == norm (val (hashValue (hash pk)))
		return $ if pkissigned
			then (Just gpgkeyid, s)
			else (Nothing, s)

type SignInfoDesc = B.ByteString

-- | Verify a clearsigned GpgSig, returning the key id used to sign it,
-- and the data that was signed.
--
-- Gpg outputs to stderr information about who signed the
-- data, and that is returned also.
gpgVerifyClearSigned :: GpgSig -> IO (Maybe (GpgKeyId, B.ByteString), SignInfoDesc)
gpgVerifyClearSigned (GpgSig (Val sig)) = do
	(statusreadh, statuswriteh) <- createPipe
	statuswritefd <- handleToFd statuswriteh
	(Just hin, Just hout, Just herr, pid) <- createProcess $
		(proc "gpg" (verifyopts statuswritefd))
			{ std_in = CreatePipe
			, std_out = CreatePipe
			, std_err = CreatePipe
			}
	closeFd statuswritefd
	B.hPut hin sig
	hClose hin
	hSetBinaryMode hout True
	((signeddata, sigdesc), mgpgkeyid) <- B.hGetContents hout
		`concurrently` B.hGetContents herr
		`concurrently` (parseStatusFd <$> hGetContents statusreadh)
	st <- waitForProcess pid
	let siginfo = if st == ExitSuccess
		then case mgpgkeyid of
			Just gpgkeyid -> Just (gpgkeyid, signeddata)
			Nothing -> Nothing
		else Nothing
	return (siginfo, sigdesc)
  where
	verifyopts statuswritefd =
		[ "--status-fd", show statuswritefd
		, "--verify"
		, "--output", "-"
		]

parseStatusFd :: String -> Maybe GpgKeyId
parseStatusFd = go . map words . lines
  where
	go [] = Nothing
	go ((_:"VALIDSIG":_:_:_:_:_:_:_:_:_:keyid:_):_) = Just (GpgKeyId keyid)
	go (_:rest) = go rest