{- Copyright 2017 Joey Hess - - 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