diff --git a/h-gpgme.cabal b/h-gpgme.cabal --- a/h-gpgme.cabal +++ b/h-gpgme.cabal @@ -1,15 +1,16 @@ Name: h-gpgme -Version: 0.3.0.0 +Version: 0.4.0.0 Description: High Level Binding for GnuPG Made Easy (gpgme) +Synopsis: High Level Binding for GnuPG Made Easy (gpgme) License: MIT License-file: LICENSE Author: Reto Habluetzel Maintainer: rethab@rethab.ch -Copyright: (c) Reto Habluetzel 2015 -Author: Reto Habluetzel 2015 +Copyright: (c) Reto Habluetzel 2016 +Author: Reto Habluetzel 2016 Homepage: https://github.com/rethab/h-gpgme Bug-reports: https://github.com/rethab/h-gpgme/issues -Tested-With: GHC==7.8.3 +Tested-With: GHC==7.10.3 Category: Cryptography Build-Type: Simple Cabal-Version: >=1.10 @@ -21,7 +22,6 @@ library hs-source-dirs: src ghc-options: -Wall - -O2 -fno-warn-orphans exposed-modules: Crypto.Gpgme other-modules: Crypto.Gpgme.Key diff --git a/src/Crypto/Gpgme.hs b/src/Crypto/Gpgme.hs --- a/src/Crypto/Gpgme.hs +++ b/src/Crypto/Gpgme.hs @@ -43,9 +43,6 @@ , PassphraseCb , setPassphraseCallback - -- currently not exported as it does not work as expected: - -- , withPWCtx - -- * Keys , Key , getKey @@ -61,6 +58,9 @@ , keySubKeys -- * Encryption + , Signature + , SignatureSummary(..) + , VerificationResult , encrypt , encryptSign , encrypt' @@ -69,6 +69,10 @@ , decrypt' , decryptVerify , decryptVerify' + , verifyDetached + , verifyDetached' + , verifyPlain + , verifyPlain' -- * Error handling , GpgmeError diff --git a/src/Crypto/Gpgme/Crypto.hs b/src/Crypto/Gpgme/Crypto.hs --- a/src/Crypto/Gpgme/Crypto.hs +++ b/src/Crypto/Gpgme/Crypto.hs @@ -8,6 +8,10 @@ , decrypt' , decryptVerify , decryptVerify' + , verifyDetached + , verifyDetached' + , verifyPlain + , verifyPlain' ) where @@ -174,6 +178,83 @@ free resultBufPtr return res + +-- | Verify a payload with a detached signature +verifyDetached :: Ctx -> Signature -> BS.ByteString -> IO (Either GpgmeError VerificationResult) +verifyDetached ctx sig dat = do + res <- verifyInternal go ctx sig dat + return $ fmap fst res + where + go ctx' sig' dat' = do + errcode <- c'gpgme_op_verify ctx' sig' dat' 0 + return (errcode, ()) + +-- | Convenience wrapper around 'withCtx' to +-- verify a single detached signature with its homedirectory. +verifyDetached' :: String -> Signature -> BS.ByteString -> IO (Either GpgmeError VerificationResult) +verifyDetached' gpgDir sig dat = + withCtx gpgDir locale OpenPGP $ \ctx -> + verifyDetached ctx sig dat + +-- | Verify a payload with a plain signature +verifyPlain :: Ctx -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, BS.ByteString)) +verifyPlain = verifyInternal go + where + go ctx sig dat = do + -- init buffer for result + resultBufPtr <- newDataBuffer + resultBuf <- peek resultBufPtr + + errcode <- c'gpgme_op_verify ctx sig dat resultBuf + + let res = if errcode /= noError + then mempty + else collectResult resultBuf + + free resultBufPtr + + return (errcode, res) + +-- | Convenience wrapper around 'withCtx' to +-- verify a single plain signature with its homedirectory. +verifyPlain' :: String -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, BS.ByteString)) +verifyPlain' gpgDir sig dat = + withCtx gpgDir locale OpenPGP $ \ctx -> + verifyPlain ctx sig dat + +verifyInternal :: (C'gpgme_ctx_t -> C'gpgme_data_t -> C'gpgme_data_t -> IO (C'gpgme_error_t, a))-> Ctx -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, a)) +verifyInternal ver_op (Ctx {_ctx=ctxPtr}) sig dat = do + -- init buffer with signature + sigBufPtr <- malloc + BS.useAsCString sig $ \bs -> do + let copyData = 1 -- gpgme shall copy data, as bytestring will free it + let siglen = fromIntegral (BS.length sig) + ret <- c'gpgme_data_new_from_mem sigBufPtr bs siglen copyData + checkError "data_new_from_mem" ret + sigBuf <- peek sigBufPtr + + -- init buffer with data + datBufPtr <- malloc + BS.useAsCString dat $ \bs -> do + let copyData = 1 -- gpgme shall copy data, as bytestring will free it + let datlen = fromIntegral (BS.length dat) + ret <- c'gpgme_data_new_from_mem datBufPtr bs datlen copyData + checkError "data_new_from_mem" ret + datBuf <- peek datBufPtr + + ctx <- peek ctxPtr + + -- verify + (errcode, res) <- ver_op ctx sigBuf datBuf + + let res' = if errcode /= noError + then Left (GpgmeError errcode) + else Right (collectSignatures ctx, res) + + free sigBufPtr + free datBufPtr + + return res' newDataBuffer :: IO (Ptr C'gpgme_data_t) newDataBuffer = do diff --git a/src/Crypto/Gpgme/Internal.hs b/src/Crypto/Gpgme/Internal.hs --- a/src/Crypto/Gpgme/Internal.hs +++ b/src/Crypto/Gpgme/Internal.hs @@ -3,7 +3,7 @@ import Bindings.Gpgme import Control.Monad (unless) import qualified Data.ByteString as BS -import Foreign (allocaBytes, castPtr, peek) +import Foreign (allocaBytes, castPtr, nullPtr, peek) import Foreign.C.String (peekCString) import Foreign.C.Types (CUInt, CInt) import System.IO.Unsafe (unsafePerformIO) @@ -33,6 +33,21 @@ return (byte `BS.cons` rest) else return BS.empty seekSet = 0 + +collectSignatures :: C'gpgme_ctx_t -> VerificationResult +collectSignatures ctx = unsafePerformIO $ do + verify_res <- c'gpgme_op_verify_result ctx + sigs <- peek $ p'_gpgme_op_verify_result'signatures verify_res + go sigs + where + go sig | sig == nullPtr = return [] + go sig = do + status <- peek $ p'_gpgme_signature'status sig + summary <- peek $ p'_gpgme_signature'summary sig + fpr <- peek (p'_gpgme_signature'fpr sig) >>= BS.packCString + next <- peek $ p'_gpgme_signature'next sig + xs <- go next + return $ (GpgmeError status, toSignatureSummaries summary, fpr) : xs checkError :: String -> C'gpgme_error_t -> IO () checkError fun gpgme_err = diff --git a/src/Crypto/Gpgme/Types.hs b/src/Crypto/Gpgme/Types.hs --- a/src/Crypto/Gpgme/Types.hs +++ b/src/Crypto/Gpgme/Types.hs @@ -2,6 +2,7 @@ import Bindings.Gpgme import qualified Data.ByteString as BS +import Data.Maybe(catMaybes) import Foreign import qualified Foreign.Concurrent as FC import Foreign.C.String (peekCString) @@ -32,6 +33,43 @@ -- | an ciphertext type Encrypted = BS.ByteString + +-- | a signature +type Signature = BS.ByteString + +-- | the summary of a signature status +data SignatureSummary = + BadPolicy -- ^ A policy requirement was not met + | CrlMissing -- ^ The CRL is not available + | CrlTooOld -- ^ Available CRL is too old + | Green -- ^ The signature is good but one might want to display some extra information + | KeyExpired -- ^ The key or one of the certificates has expired + | KeyMissing -- ^ Can’t verify due to a missing key or certificate + | KeyRevoked -- ^ The key or at least one certificate has been revoked + | Red -- ^ The signature is bad + | SigExpired -- ^ The signature has expired + | SysError -- ^ A system error occured + | UnknownSummary C'gpgme_sigsum_t -- ^ The summary is something else + | Valid -- ^ The signature is fully valid + deriving (Show, Eq, Ord) + +-- | Translate the gpgme_sigsum_t bit vector to a list of SignatureSummary +toSignatureSummaries :: C'gpgme_sigsum_t -> [SignatureSummary] +toSignatureSummaries x = catMaybes $ map (\(mask, val) -> if mask .&. x == 0 then Nothing else Just val) + [ (c'GPGME_SIGSUM_BAD_POLICY , BadPolicy) + , (c'GPGME_SIGSUM_CRL_MISSING, CrlMissing) + , (c'GPGME_SIGSUM_CRL_TOO_OLD, CrlTooOld) + , (c'GPGME_SIGSUM_GREEN , Green) + , (c'GPGME_SIGSUM_KEY_EXPIRED, KeyExpired) + , (c'GPGME_SIGSUM_KEY_MISSING, KeyMissing) + , (c'GPGME_SIGSUM_KEY_REVOKED, KeyRevoked) + , (c'GPGME_SIGSUM_RED , Red) + , (c'GPGME_SIGSUM_SIG_EXPIRED, SigExpired) + , (c'GPGME_SIGSUM_SYS_ERROR , SysError) + , (c'GPGME_SIGSUM_VALID , Valid) + ] + +type VerificationResult = [(GpgmeError, [SignatureSummary], Fpr)] -- | The fingerprint and an error code type InvalidKey = (String, Int)