{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.Sig.GPG (fullFingerprint, signPackage, verifyFile)
where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.ByteString.Char8 as C
import Data.Char (isSpace)
import Data.List (find)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Path
import Stack.Types
import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode)
fullFingerprint
:: (Monad m, MonadIO m, MonadThrow m)
=> Fingerprint -> m Fingerprint
fullFingerprint (Fingerprint fp) = do
(code,out,err) <-
liftIO
(readProcessWithExitCode "gpg" ["--fingerprint", T.unpack fp] [])
if code /= ExitSuccess
then throwM (GPGFingerprintException (out ++ "\n" ++ err))
else maybe
(throwM
(GPGFingerprintException
("unable to extract full fingerprint from output:\n " <>
out)))
return
(let hasFingerprint =
(==) ["Key", "fingerprint", "="] . take 3
fingerprint =
T.filter (not . isSpace) . T.pack . unwords . drop 3
in Fingerprint . fingerprint <$>
find hasFingerprint (map words (lines out)))
signPackage
:: (Monad m, MonadIO m, MonadThrow m)
=> Path Abs File -> m Signature
signPackage path = do
(code,out,err) <-
liftIO
(readProcessWithExitCode
"gpg"
[ "--output"
, "-"
, "--use-agent"
, "--detach-sig"
, "--armor"
, toFilePath path]
[])
if code /= ExitSuccess
then throwM (GPGSignException (out ++ "\n" ++ err))
else return (Signature (C.pack out))
verifyFile
:: (Monad m, MonadIO m, MonadThrow m)
=> Signature -> Path Abs File -> m Fingerprint
verifyFile (Signature signature) path = do
let process =
readProcessWithExitCode
"gpg"
["--verify", "-", toFilePath path]
(C.unpack signature)
(code,out,err) <- liftIO process
if code /= ExitSuccess
then throwM (GPGVerifyException (out ++ "\n" ++ err))
else maybe
(throwM
(GPGFingerprintException
("unable to extract short fingerprint from output\n: " <>
out)))
return
(let hasFingerprint =
(==) ["gpg:", "Signature", "made"] . take 3
fingerprint = T.pack . last
in Fingerprint . fingerprint <$>
find hasFingerprint (map words (lines err)))