h-gpgme 0.4.0.0 → 0.5.0.0

raw patch · 18 files changed

+1457/−36 lines, 18 filesdep +data-defaultdep +directorydep +email-validatedep −eitherdep ~HUnitdep ~timedep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default, directory, email-validate, exceptions, filepath, temporary

Dependencies removed: either

Dependency ranges changed: HUnit, time, transformers

API changes (from Hackage documentation)

Files

• .gitignore +11/−0
• .travis.yml +36/−0
• CHANGELOG.markdown +37/−0
• README.markdown +23/−0
• h-gpgme.cabal +35/−10
• src/Crypto/Gpgme.hs +17/−0
• src/Crypto/Gpgme/Crypto.hs +214/−17
• src/Crypto/Gpgme/Ctx.hs +41/−3
• src/Crypto/Gpgme/Internal.hs +6/−1
• src/Crypto/Gpgme/Key.hs +29/−2
• src/Crypto/Gpgme/Key/Gen.hs +218/−0
• src/Crypto/Gpgme/Types.hs +8/−0
• test/CryptoTest.hs +319/−0
• test/CtxTest.hs +60/−0
• test/KeyGenTest.hs +228/−0
• test/KeyTest.hs +116/−0
• test/Main.hs +5/−3
• test/TestUtil.hs +54/−0

@@ -0,0 +1,11 @@+.cabal-sandbox/+cabal.sandbox.config+dist/+.hpc/+test/alice/random_seed+test/alice/.gpg-v21-migrated+test/alice/private-keys-v1.d/+test/bob/random_seed+test/bob/.gpg-v21-migrated+test/bob/private-keys-v1.d/+/.stack-work

@@ -0,0 +1,36 @@+# Used as reference in building this Travis-CI configuration+# https://github.com/simonmichael/hledger/blob/master/.travis.yml+language: bash++# Trusty required for Docker+# https://github.com/travis-ci/travis-ci/issues/5448#issuecomment-171420138+dist: trusty++branches:+  only:+    - master++sudo: required++services:+  - docker++# Test all +matrix:+  include:+    - env:+      - STACK_YAML: stack.yaml++install:+  # Docker build+  - docker-compose build --pull+  # Stack setup+  - docker-compose run --rm tests stack --stack-yaml ${STACK_YAML} setup+  # Stack clean (Remove any old builds)+  - docker-compose run --rm tests stack --stack-yaml ${STACK_YAML} clean++script:+  # Stack build+  - docker-compose run --rm tests stack --stack-yaml ${STACK_YAML} build --haddock --no-haddock-deps+  # Stack test (Only non-interactive tests)+  - ./runtests-travis ${STACK_YAML}

@@ -0,0 +1,37 @@+# Changelog++## 0.5.0.0++### New Features++- Add Stack support+- Add key generation functionality+- Add remove key functionality+- Add clear sign functionality+- Add progress callback functionality+- Add file encryption and decryption+- Add safe `collectSignatures'` function++### Bug fixes++- Prevent potential memory leak in `withCtx`+- Return full fingerprint for `keySubKeys`+- Fix crash bug in `verifyInternal` involving a call to `performUnsafeIO`++### Maintenance+- Replace dependency on `either` with `transfers` (thanks hvr)++## 0.4.0.0+- verifyDetached and verifyDetached' Verify a payload using a detached signature. (thanks mmhat)+- verifyPlain and verifyPlain' Verify a payload using a plain signature. (thanks mmhat)++## 0.3.0.0+- Added listKeys (thanks bgamari)+- Replaced withArmor with setArmor+- Removed withKey, manual freeing is no longer required so you can use getKey (thanks bgamari)+- Support for passphrase callbacks (thanks bgamari)+ - Note that the operation of this feature is a bit inconsistent between GPG versions. GPG 1.4 using the use-agent option and GPG >= 2.1 require that the gpg-agent for the session has the allow-loopback-pinentry option enabled (this can be achieved by adding allow-loopback-pinentry to gpg-agent.conf. GPG versions between 2.0 and 2.1 do not support the --pinentry-mode option necessary for this support.+ - See http://lists.gnupg.org/pipermail/gnupg-devel/2013-February/027345.html and the gpgme-tool example included in the gpgme tree for details.++## 0.2.0.0+- Added withArmor for ASCII-armored output (thanks yaccz)

@@ -0,0 +1,23 @@+[![Hackage](https://img.shields.io/hackage/v/h-gpgme.svg)](https://hackage.haskell.org/package/h-gpgme) [![Build Status](https://travis-ci.org/rethab/h-gpgme.svg?branch=master)](https://travis-ci.org/rethab/h-gpgme)++h-gpgme: High Level Haskell Bindings for GnuPG Made Easy+========================================================++## Examples++```haskell+let alice_pub_fpr = "EAACEB8A"++-- encrypt+Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do+        aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+        fromRight $ encrypt bCtx [aPubKey] NoFlag plain++-- decrypt+dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx ->+        decrypt aCtx enc+```++See the test folder for more examples++[Changelog](CHANGELOG.markdown)

@@ -1,20 +1,25 @@ Name:                h-gpgme-Version:             0.4.0.0-Description:         High Level Binding for GnuPG Made Easy (gpgme)+Version:             0.5.0.0+Description:         High Level Binding for GnuPG Made Easy (gpgme): A Haskell API for the gpgme C library. 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 2016-Author:              Reto Habluetzel 2016+Maintainer:          rethab@protonmail.ch+Copyright:           (c) Reto Habluetzel 2018 Homepage:            https://github.com/rethab/h-gpgme Bug-reports:         https://github.com/rethab/h-gpgme/issues Tested-With:         GHC==7.10.3 Category:            Cryptography Build-Type:          Simple Cabal-Version:       >=1.10+Extra-Source-Files:+  CHANGELOG.markdown+  README.markdown+  .gitignore+  .travis.yml + source-repository head   type:     git   location: https://github.com/rethab/h-gpgme@@ -24,6 +29,7 @@   ghc-options:         -Wall                        -fno-warn-orphans   exposed-modules:     Crypto.Gpgme+                     , Crypto.Gpgme.Key.Gen   other-modules:       Crypto.Gpgme.Key                      , Crypto.Gpgme.Ctx                      , Crypto.Gpgme.Crypto@@ -32,28 +38,47 @@   build-depends:       base           == 4.*                      , bindings-gpgme >= 0.1.6 && <0.2                      , bytestring     >= 0.9-                     , either         >= 4.3 && <5.0+                     , transformers   >= 0.4.1 && <0.6                      , time           >= 1.4 && <2.0                      , unix           >= 2.5+                     , email-validate+                     , time+                     , data-default   default-language:    Haskell2010  test-suite tests   type:                exitcode-stdio-1.0   default-language:    Haskell2010   ghc-options:         -Wall-                       -fhpc   hs-source-dirs:      src, test   main-is:             Main.hs   build-depends:       base           == 4.*                      , bindings-gpgme >= 0.1.6 && <0.2                      , bytestring     >= 0.9-                     , either         >= 4.3 && <5.0-                     , transformers   >= 0.3 && <0.5+                     , transformers   >= 0.4.1 && <0.6                      , time           >= 1.4 && <2.0                      , unix           >= 2.5+                     , directory+                     , filepath+                     , email-validate+                     , data-default+                     , temporary+                     , exceptions -                     , HUnit                      >= 1.2  && <1.3+                     , HUnit                      >= 1.2  && <1.4                      , tasty                      >= 0.10 && <1.0                      , tasty-quickcheck           >= 0.8  && <1.0                      , tasty-hunit                >= 0.9  && <1.0                      , QuickCheck                 +  other-modules:       Crypto.Gpgme+                     , Crypto.Gpgme.Crypto+                     , Crypto.Gpgme.Ctx+                     , Crypto.Gpgme.Internal+                     , Crypto.Gpgme.Key+                     , Crypto.Gpgme.Key.Gen+                     , Crypto.Gpgme.Types+                     , CryptoTest+                     , CtxTest+                     , KeyTest+                     , KeyGenTest+                     , TestUtil

@@ -42,11 +42,15 @@     , isPassphraseCbSupported     , PassphraseCb     , setPassphraseCallback+      -- ** Progress callbacks+    , progressCb+    , setProgressCallback      -- * Keys     , Key     , getKey     , listKeys+    , removeKey     -- * Information about keys     , Validity (..)     , PubKeyAlgo (..)@@ -54,8 +58,10 @@     , UserId (..)     , KeyUserId (..)     , keyUserIds+    , keyUserIds'     , SubKey (..)     , keySubKeys+    , keySubKeys'      -- * Encryption     , Signature@@ -63,16 +69,23 @@     , VerificationResult     , encrypt     , encryptSign+    , encryptFd+    , encryptSignFd     , encrypt'     , encryptSign'     , decrypt+    , decryptFd+    , decryptVerifyFd     , decrypt'     , decryptVerify     , decryptVerify'+    , verify+    , verify'     , verifyDetached     , verifyDetached'     , verifyPlain     , verifyPlain'+    , sign      -- * Error handling     , GpgmeError@@ -80,6 +93,8 @@     , sourceString      -- * Other Types+    , SignMode(..)+     , Fpr     , Encrypted     , Plain@@ -93,6 +108,8 @@     , Flag(..)      , DecryptError(..)++    , HgpgmeException(..)  ) where 

@@ -2,23 +2,32 @@        encrypt     , encryptSign+    , encryptFd+    , encryptSignFd     , encrypt'     , encryptSign'     , decrypt+    , decryptFd+    , decryptVerifyFd     , decrypt'     , decryptVerify     , decryptVerify'+    , verify+    , verify'     , verifyDetached     , verifyDetached'     , verifyPlain     , verifyPlain'+    , sign  ) where +import System.Posix.Types (Fd(Fd)) import Bindings.Gpgme import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8 import Control.Monad (liftM)-import Control.Monad.Trans.Either+import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, mapExceptT) import Foreign import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import GHC.Ptr@@ -43,16 +52,22 @@ encryptSign' :: String -> Fpr -> Plain -> IO (Either String Encrypted) encryptSign' = encryptIntern' encryptSign -orElse :: Monad m => m (Maybe a) -> e -> EitherT e m a-orElse action err = EitherT $ maybe (Left err) return `liftM` action+orElse :: Monad m => m (Maybe a) -> e -> ExceptT e m a+orElse action err = ExceptT $ maybe (Left err) return `liftM` action +bimapExceptT :: Functor m => (x -> y) -> (a -> b) -> ExceptT x m a -> ExceptT y m b+bimapExceptT f g = mapExceptT (fmap h)+  where+    h (Left  e) = Left  (f e)+    h (Right a) = Right (g a)+ encryptIntern' :: (Ctx -> [Key] -> Flag -> Plain                         -> IO (Either [InvalidKey] Encrypted)                     ) -> String -> Fpr -> Plain -> IO (Either String Encrypted) encryptIntern' encrFun gpgDir recFpr plain =-    withCtx gpgDir locale OpenPGP $ \ctx -> runEitherT $+    withCtx gpgDir locale OpenPGP $ \ctx -> runExceptT $         do pubKey <- getKey ctx recFpr NoSecret `orElse` ("no such key: " ++ show recFpr)-           bimapEitherT show id $ EitherT $ encrFun ctx [pubKey] NoFlag plain+           bimapExceptT show id $ ExceptT $ encrFun ctx [pubKey] NoFlag plain  -- | encrypt for a list of recipients encrypt :: Ctx -> [Key] -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted)@@ -109,6 +124,59 @@      return res +-- | Encrypt plaintext+encryptFd :: Ctx -> [Key] -> Flag -> Fd -> Fd -> IO (Either [InvalidKey] ())+encryptFd = encryptFdIntern c'gpgme_op_encrypt++-- | Encrypt and sign plaintext+encryptSignFd :: Ctx -> [Key] -> Flag -> Fd -> Fd -> IO (Either [InvalidKey] ())+encryptSignFd = encryptFdIntern c'gpgme_op_encrypt_sign++encryptFdIntern :: (C'gpgme_ctx_t+                 -> GHC.Ptr.Ptr C'gpgme_key_t+                 -> C'gpgme_encrypt_flags_t+                 -> C'gpgme_data_t+                 -> C'gpgme_data_t+                 -> IO C'gpgme_error_t+               )+               -> Ctx+               -> [Key]+               -> Flag+               -> Fd  -- ^ Plaintext data+               -> Fd  -- ^ Ciphertext data+               -> IO (Either [InvalidKey] ())+encryptFdIntern enc_op (Ctx {_ctx=ctxPtr}) recPtrs flag (Fd plainCInt) (Fd cipherCInt) = do+  -- Initialize plaintext buffer+  plainBufPtr <- malloc+  _ <- c'gpgme_data_new_from_fd plainBufPtr plainCInt+  plainBuf <- peek plainBufPtr++  -- Initialize ciphertext buffer+  cipherBufPtr <- malloc+  _ <- c'gpgme_data_new_from_fd cipherBufPtr cipherCInt+  cipherBuf <- peek cipherBufPtr++  ctx <- peek ctxPtr++  -- encrypt+  withKeyPtrArray recPtrs $ \recArray ->+      checkError "op_encrypt" =<< enc_op ctx recArray (fromFlag flag)+                                      plainBuf cipherBuf+  free plainBufPtr++  -- check whether all keys could be used for encryption+  encResPtr <- c'gpgme_op_encrypt_result ctx+  encRes <- peek encResPtr+  let recPtr = c'_gpgme_op_encrypt_result'invalid_recipients encRes++  let res = if recPtr /= nullPtr+              then Left (collectFprs recPtr)+              else Right (())++  free cipherBufPtr++  return res+ -- | Build a null-terminated array of pointers from a list of 'Key's withKeyPtrArray :: [Key] -> (Ptr C'gpgme_key_t -> IO a) -> IO a withKeyPtrArray [] f   = f nullPtr@@ -142,7 +210,6 @@ decryptVerify :: Ctx -> Encrypted -> IO (Either DecryptError Plain) decryptVerify = decryptIntern c'gpgme_op_decrypt_verify - decryptIntern :: (C'gpgme_ctx_t                     -> C'gpgme_data_t                     -> C'gpgme_data_t@@ -179,8 +246,119 @@      return res +-- | Decrypt a ciphertext+decryptFd :: Ctx -> Fd -> Fd -> IO (Either DecryptError ())+decryptFd = decryptFdIntern c'gpgme_op_decrypt++-- | Decrypt and verify ciphertext+decryptVerifyFd :: Ctx -> Fd -> Fd -> IO (Either DecryptError ())+decryptVerifyFd = decryptFdIntern c'gpgme_op_decrypt_verify++decryptFdIntern :: (C'gpgme_ctx_t+                    -> C'gpgme_data_t+                    -> C'gpgme_data_t+                    -> IO C'gpgme_error_t+                  )+                  -> Ctx+                  -> Fd+                  -> Fd+                  -> IO (Either DecryptError ())+decryptFdIntern dec_op (Ctx {_ctx=ctxPtr}) (Fd cipherCInt) (Fd plainCInt)= do+  -- Initialize ciphertext buffer+  cipherBufPtr <- malloc+  _ <- c'gpgme_data_new_from_fd cipherBufPtr cipherCInt+  cipherBuf <- peek cipherBufPtr++  -- Initialize plaintext buffer+  plainBufPtr <- malloc+  _ <- c'gpgme_data_new_from_fd plainBufPtr plainCInt+  plainBuf <- peek plainBufPtr++  ctx <- peek ctxPtr++  -- decrypt+  errcode <- dec_op ctx cipherBuf plainBuf++  let res = if errcode /= noError+              then Left  (toDecryptError errcode)+              else Right (())++  free cipherBufPtr+  free plainBufPtr++  return res++-- | Sign plaintext for a list of signers+sign :: Ctx      -- ^ Context to sign+     -> [Key]    -- ^ Keys to used for signing. An empty list will use context's default key.+     -> SignMode -- ^ Signing mode+     -> Plain    -- ^ Plain text to sign+     -> IO (Either [InvalidKey] Plain)+sign = signIntern c'gpgme_op_sign++signIntern :: (    C'gpgme_ctx_t+                -> C'gpgme_data_t+                -> C'gpgme_data_t+                -> C'gpgme_sig_mode_t+                -> IO C'gpgme_error_t+              ) -- ^ c'gpgme_op_sign type signature+              -> Ctx+              -> [Key]+              -> SignMode+              -> Plain+              -> IO (Either [InvalidKey] Encrypted)+signIntern sign_op (Ctx {_ctx=ctxPtr}) signPtrs mode plain = do+    -- init buffer with plaintext+    plainBufPtr <- malloc+    BS.useAsCString plain $ \bs -> do+        let copyData = 1 -- gpgme shall copy data, as bytestring will free it+        let plainlen = fromIntegral (BS.length plain)+        ret <- c'gpgme_data_new_from_mem plainBufPtr bs plainlen copyData+        checkError "data_new_from_mem" ret+    plainBuf <- peek plainBufPtr++    -- init buffer for result+    resultBufPtr <- newDataBuffer+    resultBuf <- peek resultBufPtr++    ctx <- peek ctxPtr++    -- add signing keys+    _ <- mapM ( \kForPtr -> withForeignPtr (unKey kForPtr)+           (\kPtr -> do+             k <- peek kPtr+             c'gpgme_signers_add ctx k+           )+         ) signPtrs++    -- sign+    let modeCode = case mode of+                     Normal -> c'GPGME_SIG_MODE_NORMAL+                     Detach -> c'GPGME_SIG_MODE_DETACH+                     Clear  -> c'GPGME_SIG_MODE_CLEAR++    checkError "op_sign" =<< sign_op ctx plainBuf resultBuf modeCode+    free plainBufPtr++    -- check whether all keys could be used for signingi+    signResPtr <- c'gpgme_op_sign_result ctx+    signRes <- peek signResPtr+    let recPtr = c'_gpgme_op_sign_result'invalid_signers signRes++    let res = if recPtr /= nullPtr+                then Left (collectFprs recPtr)+                else Right (collectResult resultBuf)++    free resultBufPtr++    return res++ -- | Verify a payload with a detached signature-verifyDetached :: Ctx -> Signature -> BS.ByteString -> IO (Either GpgmeError VerificationResult)+verifyDetached :: Ctx           -- ^ GPG context+               -> Signature     -- ^ Detached signature+               -> BS.ByteString -- ^ Signed text+               -> IO (Either GpgmeError VerificationResult) verifyDetached ctx sig dat = do     res <- verifyInternal go ctx sig dat     return $ fmap fst res@@ -191,21 +369,31 @@  -- | Convenience wrapper around 'withCtx' to --   verify a single detached signature with its homedirectory.-verifyDetached' :: String -> Signature -> BS.ByteString -> IO (Either GpgmeError VerificationResult)+verifyDetached' :: String        -- ^ GPG context home directory+                -> Signature     -- ^ Detached signature+                -> BS.ByteString -- ^ Signed text+                -> IO (Either GpgmeError VerificationResult) verifyDetached' gpgDir sig dat =     withCtx gpgDir locale OpenPGP $ \ctx ->         verifyDetached ctx sig dat --- | Verify a payload with a plain signature+{-# DEPRECATED verifyPlain "Use verify" #-} verifyPlain :: Ctx -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, BS.ByteString))-verifyPlain = verifyInternal go+verifyPlain c s _ = verify c s+{-# DEPRECATED verifyPlain' "Use verify'" #-}+verifyPlain' :: String -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, BS.ByteString))+verifyPlain' str sig _ = verify' str sig++-- | Verify a payload with a plain signature+verify :: Ctx -> Signature -> IO (Either GpgmeError (VerificationResult, BS.ByteString))+verify c s = verifyInternal go c s (C8.pack "")     where-        go ctx sig dat = do+        go ctx sig _ = do             -- init buffer for result             resultBufPtr <- newDataBuffer             resultBuf <- peek resultBufPtr -            errcode <- c'gpgme_op_verify ctx sig dat resultBuf+            errcode <- c'gpgme_op_verify ctx sig 0 resultBuf              let res = if errcode /= noError                         then mempty@@ -217,12 +405,20 @@  -- | 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 =+verify' :: String -> Signature -> IO (Either GpgmeError (VerificationResult, BS.ByteString))+verify' gpgDir sig =     withCtx gpgDir locale OpenPGP $ \ctx ->-        verifyPlain ctx sig dat+        verify ctx sig -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 :: (    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@@ -247,9 +443,10 @@     -- verify     (errcode, res) <- ver_op ctx sigBuf datBuf +    sigs <- collectSignatures' ctx     let res' = if errcode /= noError                 then Left  (GpgmeError errcode)-                else Right (collectSignatures ctx, res)+                else Right (sigs, res)      free sigBufPtr     free datBufPtr

@@ -2,6 +2,7 @@  import Bindings.Gpgme import Control.Monad (when)+import Control.Exception (SomeException(SomeException), catch, throwIO, toException) import Data.List (isPrefixOf) import Foreign import Foreign.C.String@@ -66,9 +67,19 @@         -> IO a withCtx homedir localeStr prot f = do     ctx <- newCtx homedir localeStr prot-    res <- f ctx-    freeCtx ctx-    return res+    catch+      ( do+        res <- f ctx+        freeCtx ctx+        return res+      )+      -- If an exception occurs, first free the GPG context+      -- and then throw our own exception to signal that+      -- the exception was caught and accounted for.+      ( \(SomeException e) -> do+        freeCtx ctx+        throwIO $ HgpgmeException (toException e)+      )  -- | Sets armor output on ctx setArmor :: Bool -> Ctx -> IO ()@@ -141,3 +152,30 @@     c'gpgme_set_pinentry_mode ctx mode >>= checkError "setPassphraseCallback"     cb <- maybe (return nullFunPtr) passphraseCb callback     c'gpgme_set_passphrase_cb ctx cb nullPtr++-- | A callback invoked when the engine uses a progress notification.+-- See the PROGRESS section of docs/DETAILS in gnupg repository.+type ProgressCb =+       String     -- ^ WHAT type of progress+    -> Char       -- ^ CHAR is the character displayed with no --status-fd enabled, with the linefeed replaced by an 'X'+    -> Integer    -- ^ CUR is the current progress+    -> Integer    -- ^ TOTAL is the total possible progress+    -> IO ()++-- | Construct a progress callback+progressCb :: ProgressCb -> IO C'gpgme_progress_cb_t+progressCb callback = do+  let go _ what char cur total = do+        what' <- peekCString what+        let charChar = toEnum (fromEnum $ toInteger char)::Char+        callback what' charChar (toInteger cur) (toInteger total)+  mk'gpgme_progress_cb_t go++-- | Set the callback invoked when a progress feedback is available.+setProgressCallback :: Ctx        -- ^ context+                    -> Maybe ProgressCb+                    -> IO ()+setProgressCallback (Ctx {_ctx=ctxPtr}) callback = do+  ctx <- peek ctxPtr+  cb <- maybe (return nullFunPtr) progressCb callback+  c'gpgme_set_progress_cb ctx cb nullPtr

@@ -34,8 +34,13 @@                           else return BS.empty         seekSet = 0 +-- ^ Unsafe IO version of `collectSignatures`. Try to use `collectSignatures'` instead. collectSignatures :: C'gpgme_ctx_t -> VerificationResult-collectSignatures ctx = unsafePerformIO $ do+collectSignatures ctx = unsafePerformIO $ collectSignatures' ctx++-- ^ Return signatures a GPG verify action.+collectSignatures' :: C'gpgme_ctx_t -> IO VerificationResult+collectSignatures' ctx = do     verify_res <- c'gpgme_op_verify_result ctx     sigs <- peek $ p'_gpgme_op_verify_result'signatures verify_res     go sigs

@@ -1,6 +1,7 @@ module Crypto.Gpgme.Key (       getKey     , listKeys+    , removeKey       -- * Information about keys     , Validity (..)     , PubKeyAlgo (..)@@ -8,12 +9,13 @@     , UserId (..)     , KeyUserId (..)     , keyUserIds+    , keyUserIds'     , SubKey (..)     , keySubKeys+    , keySubKeys'     ) where  import Bindings.Gpgme-import Control.Applicative import qualified Data.ByteString as BS import Data.Time.Clock import Data.Time.Clock.POSIX@@ -59,6 +61,25 @@         then return . Just $ key         else return Nothing +-- | Removes the 'Key' from @context@+removeKey :: Ctx                    -- ^ context to operate in+          -> Key                    -- ^ key to delete+          -> IncludeSecret          -- ^ include secret keys for deleting+          -> IO (Maybe GpgmeError)+removeKey (Ctx {_ctx=ctxPtr}) key secret = do+  ctx <- peek ctxPtr+  ret <- withKeyPtr key (\keyPtr -> do+    k <- peek keyPtr+    c'gpgme_op_delete ctx k s)+  if ret == 0+    then return Nothing+    else return $ Just $ GpgmeError ret+  where+    s = secretToCInt secret+    secretToCInt :: IncludeSecret -> CInt+    secretToCInt WithSecret = 1+    secretToCInt NoSecret   = 0+ -- | A key signature data KeySignature = KeySig { keysigAlgorithm :: PubKeyAlgo                            , keysigKeyId     :: String@@ -112,6 +133,7 @@       | otherwise     = do v <- peek p                            go (v : accum) (nextFunc v) +-- | Extract 'KeyUserId's from 'Key'. keyUserIds' :: Key -> IO [KeyUserId] keyUserIds' key = withForeignPtr (unKey key) $ \keyPtr -> do     key' <- peek keyPtr >>= peek@@ -130,6 +152,8 @@                    <*> peekCString (c'_gpgme_user_id'email uid)                    <*> peekCString (c'_gpgme_user_id'comment uid) +-- | Extract 'KeyUserId's from 'Key'. Uses 'unsafePerformIO' to bypass @IO@ monad!+-- Use 'keyUserIds' instead if possible. keyUserIds :: Key -> [KeyUserId] keyUserIds = unsafePerformIO . keyUserIds' @@ -142,6 +166,7 @@                      , subkeyCardNumber   :: Maybe String                      } +-- | Extract 'SubKey's from 'Key'. keySubKeys' :: Key -> IO [SubKey] keySubKeys' key = withForeignPtr (unKey key) $ \keyPtr -> do     key' <- peek keyPtr >>= peek@@ -152,7 +177,7 @@         SubKey <$> pure (toPubKeyAlgo $ c'_gpgme_subkey'pubkey_algo sub)                <*> pure (fromIntegral $ c'_gpgme_subkey'length sub)                <*> peekCString (c'_gpgme_subkey'keyid sub)-               <*> BS.packCString (c'_gpgme_subkey'keyid sub)+               <*> BS.packCString (c'_gpgme_subkey'fpr sub)                <*> pure (readTime $ c'_gpgme_subkey'timestamp sub)                <*> pure (readTime $ c'_gpgme_subkey'expires sub)                <*> orNull peekCString (c'_gpgme_subkey'card_number sub)@@ -162,5 +187,7 @@   | ptr == nullPtr = return Nothing   | otherwise      = Just <$> f ptr +-- | Extract 'SubKey's from 'Key'. Uses 'unsafePerformIO' to bypass @IO@ monad!+-- Use 'keySubKeys' instead if possible. keySubKeys :: Key -> [SubKey] keySubKeys = unsafePerformIO . keySubKeys'

@@ -0,0 +1,218 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module      : Crypto.Gpgme.Key.Gen+License     : Public Domain++Maintainer  : daveparrish@tutanota.com+Stability   : experimental+Portability : untested++Key generation for h-gpgme.++It is suggested to import as qualified. For example:++> import qualified  Crypto.Gpgme.Key.Gen as G+-}++module Crypto.Gpgme.Key.Gen (+    -- * Usage+      genKey++    -- * Parameters+    , GenKeyParams (..)+    -- ** BitSize+    , BitSize+    , Crypto.Gpgme.Key.Gen.bitSize+    -- ** UsageList+    , UsageList (..)+    , Encrypt (..)+    , Sign (..)+    , Auth (..)+    -- ** ExpireDate+    , ExpireDate (..)+    -- ** CreationDate+    , CreationDate (..)+    -- * Other+    , Positive (unPositive)+    , toPositive+    , toParamsString+    ) where++import            Crypto.Gpgme.Types+import            Crypto.Gpgme.Internal++import qualified  Data.ByteString        as BS+import qualified  Data.ByteString.Char8  as BSC8+import            Text.Email.Validate+import            Data.Monoid ((<>))+import            Foreign                as F+import            Foreign.C.String       as FCS+import            Bindings.Gpgme+import            Data.Time.Clock+import            Data.Time.Format+import            Data.Default++-- | Key generation parameters.+--+-- See: https://www.gnupg.org/documentation/manuals/gnupg/Unattended-GPG-key-generation.html+data GenKeyParams = GenKeyParams {+      keyType       :: Maybe PubKeyAlgo+    , keyLength     :: Maybe BitSize+    , keyGrip       :: BS.ByteString+    , keyUsage      :: Maybe UsageList+    , subkeyType    :: Maybe PubKeyAlgo+    , subkeyLength  :: Maybe BitSize+    , passphrase    :: BS.ByteString+    , nameReal      :: BS.ByteString+    , nameComment   :: BS.ByteString+    , nameEmail     :: Maybe EmailAddress+    , expireDate    :: Maybe ExpireDate+    , creationDate  :: Maybe CreationDate+    , preferences   :: BS.ByteString+    , revoker       :: BS.ByteString+    , keyserver     :: BS.ByteString+    , handle        :: BS.ByteString+    , rawParams     :: BS.ByteString  -- ^ Add custom XML+    }++-- | Default parameters+--+-- Intended to be used to build custom paramemters.+--+-- > params = (def :: GenKeyParams) { keyType = Just Dsa }+--+-- See tests for working example of all parameters in use.+instance Default GenKeyParams where+  def = GenKeyParams Nothing Nothing "" Nothing Nothing Nothing "" "" ""+    Nothing Nothing Nothing "" "" "" "" ""++-- | Key-Length parameter+data BitSize = BitSize Int++-- | Bit size constrained to 1024-4096 bits+bitSize :: Int -> Either String BitSize+bitSize x+  | x < 1024  = Left "BitSize must be greater than 1024"+  | x > 4096  = Left "BitSize must be less than 4096"+  | otherwise = Right $ BitSize x++-- Key-Usage types+data Encrypt = Encrypt+data Sign    = Sign+data Auth    = Auth+data UsageList = UsageList {+      encrypt  :: Maybe Encrypt+    , sign     :: Maybe Sign+    , auth     :: Maybe Auth+    }++-- | Default UsageList+--+-- Intended to be used to build custom UsageList parameter+--+-- > usageListParam = (def :: UsageList) (Just Encrypt)+--+-- See tests for working example of all parameters in use.+instance Default UsageList where+  def = UsageList Nothing Nothing Nothing++-- | Expire-Date parameter+--+-- Beware, 'genKey' will not check that ExpireDate is after+-- CreationDate of generated key.+data ExpireDate =+  ExpireT UTCTime | ExpireD Positive | ExpireW Positive |+  ExpireM Positive | ExpireY Positive | ExpireS Positive+-- TODO: Constrain ExpireDate to something that is valid.+--       No ISODate before today or creation date.++-- | Creation-Date parameter+data CreationDate = CreationT UTCTime+                  | CreationS Positive  -- ^ Seconds since epoch++-- | Only a positive Int+data Positive = Positive { unPositive :: Int }+-- | Create a Positive type as long as the Int is greater than @-1@+toPositive :: Int -> Maybe Positive+toPositive n = if (n < 0) then Nothing else Just (Positive n)++-- | Generate a GPG key+genKey :: Ctx           -- ^ context to operate in+       -> GenKeyParams  -- ^ parameters to use for generating key+       -> IO (Either GpgmeError Fpr)+genKey (Ctx {_ctx=ctxPtr}) params = do+  ctx <- F.peek ctxPtr+  ret <- BS.useAsCString (toParamsString params) $ \p -> do+    let nullGpgmeData = 0  -- Using 0 as NULL for gpgme_data_t+    c'gpgme_op_genkey ctx p nullGpgmeData nullGpgmeData+  if ret == noError+    then do+      rPtr <- c'gpgme_op_genkey_result ctx+      r <- F.peek rPtr+      let fprPtr = c'_gpgme_op_genkey_result'fpr r+      fpr <- FCS.peekCString fprPtr++      return . Right $ BSC8.pack fpr+    else return . Left $ GpgmeError ret++-- | Used by 'genKey' generate a XML string for GPG+toParamsString :: GenKeyParams -> BS.ByteString+toParamsString params = (BSC8.unlines . filter ((/=)""))+    [ "<GnupgKeyParms format=\"internal\">"+    , "Key-Type: " <> (maybe "default" keyTypeToString $ keyType params)+    , maybeLine "Key-Length: " keyLengthToString $ keyLength params+    , addLabel "Key-Grip: " $ keyGrip params+    , maybeLine "Key-Usage: " keyUsageListToString $ keyUsage params+    , maybeLine "Subkey-Type: " keyTypeToString $ subkeyType params+    , maybeLine "Subkey-Length: " keyLengthToString $ subkeyLength params+    , addLabel "Passphrase: " $ passphrase params+    , addLabel "Name-Real: " $ nameReal params+    , addLabel "Name-Comment: " $ nameComment params+    , maybeLine "Name-Email: " toByteString $ nameEmail params+    , maybeLine "Expire-Date: " expireDateToString $ expireDate params+    , maybeLine "Creation-Date: " creationDateToString $ creationDate params+    , addLabel "Preferences: " $ preferences params+    , addLabel "Revoker: " $ revoker params+    , addLabel "Keyserver: " $ keyserver params+    , addLabel "Handle: " $ handle params+    -- Allow for additional parameters as a raw ByteString+    , rawParams params+    , "</GnupgKeyParms>"+    ]+  where+    maybeLine :: BS.ByteString -> (a -> BS.ByteString) -> Maybe a -> BS.ByteString+    maybeLine h f p = addLabel h $ maybe "" f p+    -- Add label if not an empty string+    addLabel :: BS.ByteString -> BS.ByteString -> BS.ByteString+    addLabel _ "" = ""+    addLabel h s  = h <> s+    keyTypeToString :: PubKeyAlgo -> BS.ByteString+    keyTypeToString Rsa   = "RSA"+    keyTypeToString RsaE  = "RSA-E"+    keyTypeToString RsaS  = "RSA-S"+    keyTypeToString ElgE  = "ELG-E"+    keyTypeToString Dsa   = "DSA"+    keyTypeToString Elg   = "ELG"+    keyLengthToString :: BitSize -> BS.ByteString+    keyLengthToString (BitSize i) = BSC8.pack $ show i+    keyUsageListToString :: UsageList -> BS.ByteString+    keyUsageListToString (UsageList e s a) =+      let eStr = maybe (""::BS.ByteString) (const "encrypt") e+          sStr = maybe (""::BS.ByteString) (const "sign") s+          aStr = maybe (""::BS.ByteString) (const "auth") a+      in (BSC8.intercalate "," . filter ((/=) "" )) [eStr, sStr, aStr]+    expireDateToString :: ExpireDate -> BS.ByteString+    expireDateToString (ExpireD p) = BSC8.pack $ ((show $ unPositive p) ++ "d")+    expireDateToString (ExpireW p) = BSC8.pack $ ((show $ unPositive p) ++ "w")+    expireDateToString (ExpireM p) = BSC8.pack $ ((show $ unPositive p) ++ "m")+    expireDateToString (ExpireY p) = BSC8.pack $ ((show $ unPositive p) ++ "y")+    expireDateToString (ExpireS p) =+      BSC8.pack $ ("seconds=" ++ (show $ unPositive p))+    expireDateToString (ExpireT t) =+      BSC8.pack $ formatTime defaultTimeLocale "%Y%m%dT%H%M%S" t+    creationDateToString :: CreationDate -> BS.ByteString+    creationDateToString (CreationS p) =+      BSC8.pack $ ("seconds=" ++ (show $ unPositive p))+    creationDateToString (CreationT t) =+      BSC8.pack $ formatTime defaultTimeLocale "%Y%m%dT%H%M%S" t

@@ -7,6 +7,7 @@ import qualified Foreign.Concurrent as FC import Foreign.C.String (peekCString) import System.IO.Unsafe (unsafePerformIO)+import Control.Exception (SomeException, Exception)  -- | the protocol to be used in the crypto engine data Protocol =@@ -25,6 +26,9 @@     , _engineVersion   :: String            -- ^ engine version } +-- | Modes for signing with GPG+data SignMode = Normal | Detach | Clear deriving Show+ -- | a fingerprint type Fpr = BS.ByteString @@ -154,3 +158,7 @@     | Dsa     | Elg     deriving (Show, Ord, Eq)++-- | h-gpgme exception for wrapping exception which occur outside of the control of h-gpgme+newtype HgpgmeException = HgpgmeException SomeException deriving (Show)+instance Exception HgpgmeException

@@ -0,0 +1,319 @@+{-# LANGUAGE OverloadedStrings #-}+module CryptoTest (tests, cbTests) where++import System.IO+import System.IO.Temp+import System.Posix.IO+import Control.Monad (liftM, when)+import Control.Monad.Trans.Maybe+import Control.Monad.IO.Class+import Control.Monad.Catch+import Control.Concurrent+import Data.List (isInfixOf)+import Data.ByteString.Char8 ()+import Data.Maybe ( fromJust )+import qualified Data.ByteString as BS+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck+import Test.HUnit hiding (assert)+import Test.QuickCheck.Monadic++import Crypto.Gpgme+import Crypto.Gpgme.Types ( GpgmeError (GpgmeError)+                          , SignMode ( Clear, Detach, Normal )+                          )+import TestUtil++tests :: TestTree+tests = testGroup "crypto"+    [ testProperty "bob_encrypt_for_alice_decrypt_prompt_no_travis"+                   $ bob_encrypt_for_alice_decrypt False+    , testProperty "bob_encrypt_sign_for_alice_decrypt_verify_prompt_no_travis"+                   $ bob_encrypt_sign_for_alice_decrypt_verify False++    , testProperty "bob_encrypt_for_alice_decrypt_short_prompt_no_travis"+                   bob_encrypt_for_alice_decrypt_short+    , testProperty "bob_encrypt_sign_for_alice_decrypt_verify_short_prompt_no_travis"+                   bob_encrypt_sign_for_alice_decrypt_verify_short++    , testCase "decrypt_garbage" decrypt_garbage+    , testCase "encrypt_wrong_key" encrypt_wrong_key+    , testCase "bob_encrypt_symmetrically_prompt_no_travis" bob_encrypt_symmetrically+    , testCase "bob_detach_sign_and_verify_specify_key_prompt_no_travis" bob_detach_sign_and_verify_specify_key_prompt+    , testCase "bob_clear_sign_and_verify_specify_key_prompt_no_travis" bob_clear_sign_and_verify_specify_key_prompt+    , testCase "bob_clear_sign_and_verify_default_key_prompt_no_travis" bob_clear_sign_and_verify_default_key_prompt+    , testCase "bob_normal_sign_and_verify_specify_key_prompt_no_travis" bob_normal_sign_and_verify_specify_key_prompt+    , testCase "bob_normal_sign_and_verify_default_key_prompt_no_travis" bob_normal_sign_and_verify_default_key_prompt+    , testCase "encrypt_file_no_travis" encrypt_file+    , testCase "encrypt_stream_no_travis" encrypt_stream+    ]++cbTests :: IO TestTree+cbTests = do+    supported <- withCtx "test/bob" "C" OpenPGP $ \ctx ->+        return $ isPassphraseCbSupported ctx+    if supported+       then return $ testGroup "passphrase-cb"+                [ testProperty "bob_encrypt_for_alice_decrypt"+                               $ bob_encrypt_for_alice_decrypt True+                , testProperty "bob_encrypt_sign_for_alice_decrypt_verify_with_passphrase_cb_prompt_no_travis"+                               $ bob_encrypt_sign_for_alice_decrypt_verify True+                ]+       else return $ testGroup "passphrase-cb" []++hush :: Monad m => m (Either e a) -> MaybeT m a+hush = MaybeT . liftM (either (const Nothing) Just)++withPassphraseCb :: String -> Ctx -> IO ()+withPassphraseCb passphrase ctx = do+    setPassphraseCallback ctx (Just callback)+  where+    callback _ _ _ = return (Just passphrase)++bob_encrypt_for_alice_decrypt :: Bool -> Plain -> Property+bob_encrypt_for_alice_decrypt passphrCb plain =+    not (BS.null plain) ==> monadicIO $ do+        dec <- run encr_and_decr+        assert $ dec == plain+  where encr_and_decr =+            do -- encrypt+               Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do+                   aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+                   hush $ encrypt bCtx [aPubKey] NoFlag plain++               -- decrypt+               dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx -> do+                   when passphrCb $ withPassphraseCb "alice123" aCtx+                   decrypt aCtx enc++               return $ fromRight dec++bob_encrypt_for_alice_decrypt_short :: Plain -> Property+bob_encrypt_for_alice_decrypt_short plain =+    not (BS.null plain) ==> monadicIO $ do+        dec <- run encr_and_decr+        assert $ dec == plain+  where encr_and_decr =+            do -- encrypt+               enc <- encrypt' "test/bob" alice_pub_fpr plain++               -- decrypt+               dec <- decrypt' "test/alice" (fromRight enc)++               return $ fromRight dec++bob_encrypt_sign_for_alice_decrypt_verify :: Bool -> Plain -> Property+bob_encrypt_sign_for_alice_decrypt_verify passphrCb plain =+    not (BS.null plain) ==> monadicIO $ do+        dec <- run encr_and_decr+        assert $ dec == plain+  where encr_and_decr =+            do -- encrypt+               Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do+                   aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+                   hush $ encryptSign bCtx [aPubKey] NoFlag plain++               -- decrypt+               dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx -> do+                   when passphrCb $ withPassphraseCb "alice123" aCtx+                   decryptVerify aCtx enc++               return $ fromRight dec++bob_encrypt_sign_for_alice_decrypt_verify_short :: Plain -> Property+bob_encrypt_sign_for_alice_decrypt_verify_short plain =+    not (BS.null plain) ==> monadicIO $ do+        dec <- run encr_and_decr+        assert $ dec == plain+  where encr_and_decr =+            do -- encrypt+               enc <- encryptSign' "test/bob" alice_pub_fpr plain++               -- decrypt+               dec <- decryptVerify' "test/alice" (fromRight enc)++               return $ fromRight dec++encrypt_wrong_key :: Assertion+encrypt_wrong_key = do+    res <- encrypt' "test/bob" "INEXISTENT" "plaintext"+    assertBool "should fail" (isLeft res)+    let err = fromLeft res+    assertBool "should contain key" ("INEXISTENT" `isInfixOf` err)++decrypt_garbage :: Assertion+decrypt_garbage = do+    val <- withCtx "test/bob" "C" OpenPGP $ \bCtx ->+              decrypt bCtx (BS.pack [1,2,3,4,5,6])+    isLeft val @? "should be left " ++ show val++bob_encrypt_symmetrically :: Assertion+bob_encrypt_symmetrically = do++        -- encrypt+        cipher <- fmap fromRight $+                    withCtx "test/bob" "C" OpenPGP $ \ctx ->+                        encrypt ctx [] NoFlag "plaintext"+        assertBool "must not be plain" (cipher /= "plaintext")++        -- decrypt+        plain <- fmap fromRight $+                    withCtx "test/alice" "C" OpenPGP $ \ctx ->+                        decrypt ctx cipher++        assertEqual "should decrypt to same" "plaintext" plain++bob_detach_sign_and_verify_specify_key_prompt :: Assertion+bob_detach_sign_and_verify_specify_key_prompt = do+  resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+    key <- getKey ctx bob_pub_fpr NoSecret+    let msgToSign = "Clear text message from bob!!"+    resSign <-sign ctx [(fromJust key)] Detach msgToSign+    verifyDetached ctx (fromRight resSign) msgToSign+  assertBool "Could not verify bob's signature was correct" $ isVerifyDetachValid resVerify++bob_clear_sign_and_verify_specify_key_prompt :: Assertion+bob_clear_sign_and_verify_specify_key_prompt = do+  resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+    key <- getKey ctx bob_pub_fpr NoSecret+    resSign <- sign ctx [(fromJust key)] Clear "Clear text message from bob specifying signing key"+    verifyPlain ctx (fromRight resSign) ""+  assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify++bob_clear_sign_and_verify_default_key_prompt :: Assertion+bob_clear_sign_and_verify_default_key_prompt = do+  resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+    resSign <- sign ctx [] Clear "Clear text message from bob with default key"+    verifyPlain ctx (fromRight resSign) ""+  assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify++bob_normal_sign_and_verify_specify_key_prompt :: Assertion+bob_normal_sign_and_verify_specify_key_prompt = do+  resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+    key <- getKey ctx bob_pub_fpr NoSecret+    resSign <- sign ctx [(fromJust key)] Normal "Normal text message from bob specifying signing key"+    verify ctx (fromRight resSign)+  assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify++bob_normal_sign_and_verify_default_key_prompt :: Assertion+bob_normal_sign_and_verify_default_key_prompt = do+  resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+    resSign <- sign ctx [] Normal "Normal text message from bob with default key"+    verify ctx (fromRight resSign)+  assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify++encrypt_file :: Assertion+encrypt_file =+  withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+    withPassphraseCb "bob123" ctx+    withTestTmpFiles $ \pp ph cp ch dp dh -> do+      plainFd <- handleToFd ph+      cipherFd <- handleToFd ch+      decryptedFd <- handleToFd dh++      key <- getKey ctx bob_pub_fpr NoSecret++      -- Add plaintext content+      writeFile pp "Plaintext contents. 1234go!"++      -- Encrypt plaintext+      resEnc <- encryptFd ctx [(fromJust key)] NoFlag plainFd cipherFd+      if (resEnc == Right ())+      then return ()+      else assertFailure $ show resEnc++      -- Recreate the cipher FD because it is closed (or something) from the encrypt command+      cipherHandle' <- openFile cp ReadWriteMode+      cipherFd' <- handleToFd cipherHandle'++      -- Decrypt ciphertext+      resDec <- decryptFd ctx cipherFd' decryptedFd+      if (resDec == Right ())+      then return ()+      else assertFailure $ show resDec++      -- Compare plaintext and decrypted text+      plaintext <- readFile pp+      decryptedtext <- readFile dp+      plaintext @=? decryptedtext++-- Encrypt from FD pipe into a FD file+encrypt_stream :: Assertion+encrypt_stream =+  withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+    withPassphraseCb "bob123" ctx+    withTestTmpFiles $ \_ _ cp ch dp dh -> do++      cipherFd <- handleToFd ch+      decryptedFd <- handleToFd dh++      -- Use bob's key+      key <- getKey ctx bob_pub_fpr NoSecret++      -- Create pipe+      (pipeRead, pipeWrite) <- createPipe++      -- Write to pipe+      -- Add plaintext content+      let testString = take (1000) $ repeat '.'+      _ <- forkIO $ do+        threadWaitWrite pipeWrite+        _ <- fdWrite pipeWrite testString+        closeFd pipeWrite++      -- Start encrypting in thread+      _ <- forkIO $ do+        threadWaitRead pipeRead+        _ <- encryptFd ctx [(fromJust key)] NoFlag pipeRead cipherFd+        closeFd pipeRead++      -- Wait a second for threads to finish+      threadDelay (1000 * 1000 * 1)++      -- Check result+      -- Recreate the cipher FD because it is closed (or something) from the encrypt command+      threadWaitRead cipherFd+      ch' <- openFile cp ReadWriteMode+      cipherFd' <- handleToFd ch'++      -- Decrypt ciphertext+      resDec <- decryptFd ctx cipherFd' decryptedFd+      if (resDec == Right ())+      then return ()+      else assertFailure $ show resDec++      -- Compare plaintext and decrypted text+      decryptedtext <-readFile dp+      testString @=? decryptedtext++withTestTmpFiles :: (MonadIO m, MonadMask m)+                 => ( FilePath -> Handle -- Plaintext+                 ->   FilePath -> Handle -- Ciphertext+                 ->   FilePath -> Handle -- Decrypted text+                 ->   m a)+                 -> m a+withTestTmpFiles f =+  withSystemTempFile "plain" $ \pp ph ->+    withSystemTempFile "cipher" $ \cp ch ->+      withSystemTempFile "decrypt" $ \dp dh ->+        f pp ph cp ch dp dh+++-- Verify that the signature verification is successful+isVerifyValid :: Either t ([(GpgmeError, [SignatureSummary], t1)], t2) -> Bool+isVerifyValid (Right ((v:[]), _)) = (isVerifyValid' v)+isVerifyValid (Right ((v:vs), t)) = (isVerifyValid' v) && isVerifyValid (Right (vs,t))+isVerifyValid _  = False+isVerifyValid' :: (GpgmeError, [SignatureSummary], t) -> Bool+isVerifyValid' (GpgmeError 0, [Green,Valid], _) = True+isVerifyValid' _ = False++-- Verify that the signature verification is successful for verifyDetach+isVerifyDetachValid :: Either t [(GpgmeError, [SignatureSummary], t1)] -> Bool+isVerifyDetachValid (Right ((v:[]))) = (isVerifyDetachValid' v)+isVerifyDetachValid (Right ((v:vs))) = (isVerifyDetachValid' v) && isVerifyDetachValid (Right vs)+isVerifyDetachValid _  = False+isVerifyDetachValid' :: (GpgmeError, [SignatureSummary], t) -> Bool+isVerifyDetachValid' (GpgmeError 0, [Green,Valid], _) = True+isVerifyDetachValid' _ = False

@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+module CtxTest (tests) where++import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class (lift)+import qualified Data.ByteString as BS+import Control.Exception (catch, fromException)+import System.IO.Error (IOError, isUserError)++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit++import Crypto.Gpgme+import TestUtil++tests :: [TestTree]+tests = [ testCase "run_action_with_ctx" run_action_with_ctx+        , testCase "set_armor" set_armor+        , testCase "unset_armor" unset_armor+        , testCase "exception_safe" exception_safe+        ]++run_action_with_ctx :: Assertion+run_action_with_ctx = do+    res <- withCtx "test/alice" "C" OpenPGP $ \_ ->+              return "foo" :: IO BS.ByteString+    res @?= "foo"++set_armor :: Assertion+set_armor = do+    let armorPrefix = "-----BEGIN PGP MESSAGE-----"+    enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do+              aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+              lift $ setArmor True bCtx+              lift $ encrypt bCtx [aPubKey] NoFlag "plaintext"+    (armorPrefix `BS.isPrefixOf` fromJustAndRight enc) @? ("Armored must start with " ++ show armorPrefix)++unset_armor :: Assertion+unset_armor = do+    let armorPrefix = "-----BEGIN PGP MESSAGE-----"+    enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do+              aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+              lift $ setArmor False bCtx+              lift $ encrypt bCtx [aPubKey] NoFlag "plaintext"+    (not $ armorPrefix `BS.isPrefixOf` fromJustAndRight enc) @? ("Binary must not start with " ++ show armorPrefix)++-- Ensure that if an exception occurs then the expected exception type is returned so that we know+-- the context was freed+exception_safe :: Assertion+exception_safe = catch+  ( do+    res <- withCtx "test/alice" "C" OpenPGP $ \_ ->+      (ioError $ userError "Busted") >>+      return "foo" :: IO BS.ByteString+    res @?= "foo")+  ( \(HgpgmeException e) -> do+    let mioe = (fromException e) :: Maybe IOError+    maybe (assertFailure $ show mioe) (\ioe -> isUserError ioe @?= True) mioe+  )

@@ -0,0 +1,228 @@+{-# LANGUAGE OverloadedStrings #-}+module KeyGenTest (tests) where++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit++import Text.Email.Validate+import System.FilePath    ((</>))+import System.Directory   ( removeDirectoryRecursive )+import System.IO          ( hPutStr+                          , hPutStrLn+                          , IOMode (..)+                          , withFile+                          , hGetContents+                          )+import Data.Time.Calendar+import Data.Time.Clock+import Data.Default+import Data.List          ( isPrefixOf )+import Data.ByteString.Char8    ( unpack )++import            Crypto.Gpgme+import qualified  Crypto.Gpgme.Key.Gen as G+import TestUtil++tests :: [TestTree]+tests = [ testCase "all_gen_key_parameters" all_gen_key_parameters+        , testCase "expire_date_days" expire_date_days+        , testCase "expire_date_weeks" expire_date_weeks+        , testCase "expire_date_months" expire_date_months+        , testCase "expire_date_years" expire_date_years+        , testCase "expire_date_seconds" expire_date_seconds+        , testCase "creation_date_seconds" creation_date_seconds+        , testCase "gen_key_no_travis" gen_key+        , testCase "progress_callback_no_travis" progress_callback+        ]++-- For getting values from Either+errorOnLeft :: Either String a -> a+errorOnLeft (Right x) = x+errorOnLeft (Left s)  = error s++-- Test parameter list generation for generating keys+all_gen_key_parameters :: Assertion+all_gen_key_parameters =+  let params = (def :: G.GenKeyParams) -- G.defaultGenKeyParams+        { G.keyType = Just Dsa+        , G.keyLength = Just $ errorOnLeft $ G.bitSize 1024+        , G.keyGrip = "123abc"+        , G.keyUsage = Just $ (def :: G.UsageList) {+            G.encrypt = Just G.Encrypt+          , G.sign = Just G.Sign+          , G.auth = Just G.Auth+          }+        , G.subkeyType = Just ElgE+        , G.subkeyLength = Just $ errorOnLeft $ G.bitSize 1024+        , G.passphrase = "easy to guess"+        , G.nameReal = "Foo Bar"+        , G.nameComment = "A great comment"+        , G.nameEmail = Just $ errorOnLeft $ validate "foo@example.com"+        , G.expireDate = Just $ G.ExpireT $ UTCTime (fromGregorian 2050 8 15) 52812+        , G.creationDate = Just $ G.CreationT $+            UTCTime (fromGregorian 2040 8 16) 52813+        , G.preferences = "Some preference"+        , G.revoker = "RSA:fpr sensitive"+        , G.keyserver = "https://keyserver.com/"+        , G.handle = "Key handle here"+        }+  in (G.toParamsString params) @?=+      "<GnupgKeyParms format=\"internal\">\n\+      \Key-Type: DSA\n\+      \Key-Length: 1024\n\+      \Key-Grip: 123abc\n\+      \Key-Usage: encrypt,sign,auth\n\+      \Subkey-Type: ELG-E\n\+      \Subkey-Length: 1024\n\+      \Passphrase: easy to guess\n\+      \Name-Real: Foo Bar\n\+      \Name-Comment: A great comment\n\+      \Name-Email: foo@example.com\n\+      \Expire-Date: 20500815T144012\n\+      \Creation-Date: 20400816T144013\n\+      \Preferences: Some preference\n\+      \Revoker: RSA:fpr sensitive\n\+      \Keyserver: https://keyserver.com/\n\+      \Handle: Key handle here\n\+      \</GnupgKeyParms>\n"++gen_key :: Assertion+gen_key = do+  tmpDir <- createTemporaryTestDir "gen_key"++  ret <- withCtx tmpDir "C" OpenPGP $ \ctx -> do+    let params = (def :: G.GenKeyParams)+                { G.keyType = Just Dsa+                , G.keyLength = Just $ errorOnLeft $ G.bitSize 1024+                , G.rawParams =+                  "Subkey-Type: ELG-E\n\+                  \Subkey-Length: 1024\n\+                  \Name-Real: Joe Tester\n\+                  \Name-Comment: (pp=abc)\n\+                  \Name-Email: joe@foo.bar\n\+                  \Expire-Date: 0\n\+                  \Passphrase: abc\n"+                }++    G.genKey ctx params+  -- Cleanup temporary directory+  removeDirectoryRecursive tmpDir+  either+    (\(l) -> assertFailure $ "Left was return value " ++ (show l))+    (\(r) -> assertBool ("Fingerprint ("+                        ++ (unpack r)+                        ++ ") starts with '0x' indicating it is actually a pointer.")+      (not $ isPrefixOf "0x" (unpack r))) ret++-- Other ExpireDate to string possibilities+expire_date_days :: Assertion+expire_date_days =+  let (Just p) = G.toPositive 10+      params = (def :: G.GenKeyParams) {+          G.expireDate = Just $ G.ExpireD p+        }+  in (G.toParamsString params) @?=+      "<GnupgKeyParms format=\"internal\">\n\+      \Key-Type: default\n\+      \Expire-Date: 10d\n\+      \</GnupgKeyParms>\n"++expire_date_weeks :: Assertion+expire_date_weeks =+  let (Just p) = G.toPositive 10+      params = (def :: G.GenKeyParams) {+          G.expireDate = Just $ G.ExpireW p+        }+  in (G.toParamsString params) @?=+      "<GnupgKeyParms format=\"internal\">\n\+      \Key-Type: default\n\+      \Expire-Date: 10w\n\+      \</GnupgKeyParms>\n"++expire_date_months :: Assertion+expire_date_months =+  let (Just p) = G.toPositive 10+      params = (def :: G.GenKeyParams) {+          G.expireDate = Just $ G.ExpireM p+        }+  in (G.toParamsString params) @?=+      "<GnupgKeyParms format=\"internal\">\n\+      \Key-Type: default\n\+      \Expire-Date: 10m\n\+      \</GnupgKeyParms>\n"++expire_date_years :: Assertion+expire_date_years =+  let (Just p) = G.toPositive 10+      params = (def :: G.GenKeyParams) {+          G.expireDate = Just $ G.ExpireY p+        }+  in (G.toParamsString params) @?=+      "<GnupgKeyParms format=\"internal\">\n\+      \Key-Type: default\n\+      \Expire-Date: 10y\n\+      \</GnupgKeyParms>\n"++expire_date_seconds :: Assertion+expire_date_seconds =+  let (Just p) = G.toPositive 123456+      params = (def :: G.GenKeyParams) {+          G.expireDate = Just $ G.ExpireS p+        }+  in (G.toParamsString params) @?=+      "<GnupgKeyParms format=\"internal\">\n\+      \Key-Type: default\n\+      \Expire-Date: seconds=123456\n\+      \</GnupgKeyParms>\n"++creation_date_seconds :: Assertion+creation_date_seconds =+  let (Just p) = G.toPositive 123456+      params = (def :: G.GenKeyParams) {+          G.creationDate = Just $ G.CreationS p+        }+  in (G.toParamsString params) @?=+      "<GnupgKeyParms format=\"internal\">\n\+      \Key-Type: default\n\+      \Creation-Date: seconds=123456\n\+      \</GnupgKeyParms>\n"++progress_callback :: Assertion+progress_callback = do+  tmpDir <- createTemporaryTestDir "progress_callback"++  -- Setup context+  genRet <- withCtx tmpDir "C" OpenPGP $ \ctx -> do+    -- Setup generation parameters+    let params = (def :: G.GenKeyParams)+                { G.keyType   = Just Rsa+                , G.keyLength = Just $ errorOnLeft $ G.bitSize 2048+                , G.nameReal  = "Joe Tester"+                , G.nameEmail = Just $ errorOnLeft $ validate "joe@foo.bar"+                , G.passphrase  = "abc"+                }++        -- Setup callback which writes to temporary file.+        testProgressCb what char cur total =+          withFile (tmpDir </> "testProgress.log") AppendMode (\h -> do+            hPutStr h ("what: " ++ what)+            hPutStr h (" char: " ++ show char)+            hPutStr h (" cur: " ++ show cur)+            hPutStr h (" total: " ++ show total)+            hPutStrLn h "")++    setProgressCallback ctx (Just testProgressCb)++    -- Run key generation+    G.genKey ctx params++  -- Make sure the file has some evidence of progress notifications+  ret <- withFile (tmpDir </> "testProgress.log") ReadMode (\h -> do+    contents <- hGetContents h+    ((length $ lines contents) > 0) @? "No lines in progress file")++  -- Cleanup test+  removeDirectoryRecursive tmpDir+  assertBool ("Left was return value: " ++ show ret) (either (\_ -> False) (\_ -> True) genRet)+  return $ ret

@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}+module KeyTest (tests) where++import Data.Maybe+import Data.List+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit++import System.FilePath    ((</>))+import System.Directory   ( removeDirectoryRecursive+                          , createDirectory+                          , listDirectory+                          , copyFile+                          )++import Crypto.Gpgme+import TestUtil++tests :: [TestTree]+tests = [ testCase "get_alice_pub_from_alice" get_alice_pub_from_alice+        , testCase "get_bob_pub_from_alice" get_bob_pub_from_alice+        , testCase "alice_list_pub_keys" alice_list_pub_keys+        , testCase "alice_list_secret_keys" alice_list_secret_keys+        , testCase "get_inexistent_from_alice" get_inexistent_pub_from_alice+        , testCase "check_alice_pub_user_ids" check_alice_pub_user_ids+        , testCase "check_alice_pub_subkeys" check_alice_pub_subkeys+        , testCase "remove_alice_key_prompt" remove_alice_key+        ]++get_alice_pub_from_alice :: Assertion+get_alice_pub_from_alice = do+    withCtx "test/alice" "C" OpenPGP $ \ctx ->+        do key <- getKey ctx alice_pub_fpr NoSecret+           isJust key @? "missing " ++ show alice_pub_fpr++get_bob_pub_from_alice :: Assertion+get_bob_pub_from_alice = do+    withCtx "test/alice/" "C" OpenPGP $ \ctx ->+        do key <- getKey ctx bob_pub_fpr NoSecret+           isJust key @? "missing " ++ show bob_pub_fpr++alice_list_pub_keys :: Assertion+alice_list_pub_keys = do+    withCtx "test/alice" "C" OpenPGP $ \ctx ->+        do keys <- listKeys ctx NoSecret+           length keys @?= 2+           let keyIds = [["163EC68CCF3FBF8E","DD2469546C4FB8F2"],+                         ["6B9809775CF91391","3BA69AA2EAACEB8A"]]+           map (map subkeyKeyId . keySubKeys) keys @?= keyIds++alice_list_secret_keys :: Assertion+alice_list_secret_keys = do+    withCtx "test/alice" "C" OpenPGP $ \ctx ->+        do keys <- listKeys ctx WithSecret+           length keys @?= 1++get_inexistent_pub_from_alice :: Assertion+get_inexistent_pub_from_alice = do+    let inexistent_fpr = "ABCDEF"+    withCtx "test/alice/" "C" OpenPGP $ \ctx ->+        do key <- getKey ctx inexistent_fpr NoSecret+           isNothing key @? "existing " ++ show inexistent_fpr++check_alice_pub_user_ids :: Assertion+check_alice_pub_user_ids = do+    withCtx "test/alice" "C" OpenPGP $ \ctx ->+        do Just key <- getKey ctx alice_pub_fpr NoSecret+           let uids = keyUserIds key+           length uids @?= 1+           let kuid = head uids+               uid = keyuserId kuid+           keyuserValidity kuid @?= ValidityUltimate+           userId uid @?= "Alice (Test User A) <alice@email.com>"+           userName uid @?= "Alice"+           userEmail uid @?= "alice@email.com"+           userComment uid @?= "Test User A"++check_alice_pub_subkeys :: Assertion+check_alice_pub_subkeys = do+    withCtx "test/alice" "C" OpenPGP $ \ctx ->+        do Just key <- getKey ctx alice_pub_fpr NoSecret+           let subs = keySubKeys key+           length subs @?= 2+           let sub = head subs+           subkeyAlgorithm sub @?= Rsa+           subkeyLength sub @?= 2048+           subkeyKeyId sub @?= "6B9809775CF91391"+           subkeyFpr sub @?= "3F10159E56ECB494ED42EFA36B9809775CF91391"++remove_alice_key :: Assertion+remove_alice_key = do+  tmpDir <- createTemporaryTestDir "remove_alice_key"++  -- Copy alice's key into temporary directory so we can safely remove it+  let alice_tmpDir = tmpDir </> "alice"+  createDirectory $ alice_tmpDir+  alice_files <- listDirectory "test/alice"+  mapM_ (\f -> copyFile ("test/alice" </> f) (tmpDir </> "alice" </> f))+    $ filter (\f -> (not $ isPrefixOf "S.gpg-agent" f)+                 && f /= "private-keys-v1.d"+                 && f /= ".gpg-v21-migrated"+                 && f /= "random_seed"+             ) alice_files++  withCtx (tmpDir </> "alice") "C" OpenPGP $ \ctx ->+    do key <- getKey ctx alice_pub_fpr WithSecret+       start_num <- listKeys ctx WithSecret >>= \l -> return $ length l+       start_num @?= 1+       ret <- removeKey ctx (fromJust key) WithSecret+       end_num <- listKeys ctx WithSecret >>= \l -> return $ length l+       end_num @?= 0+       ret @?= Nothing++  -- Cleanup test+  removeDirectoryRecursive tmpDir

@@ -2,15 +2,17 @@  import Test.Tasty (defaultMain, testGroup) -import KeyTest -import CtxTest -import CryptoTest +import KeyTest+import KeyGenTest+import CtxTest+import CryptoTest  main :: IO () main = do     passphraseCbTests <- CryptoTest.cbTests     defaultMain $ testGroup "tests"         [ testGroup "key"    KeyTest.tests+        , testGroup "keyGen" KeyGenTest.tests         , testGroup "ctx"    CtxTest.tests         , CryptoTest.tests         , passphraseCbTests

@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module TestUtil where++import qualified Data.ByteString as BS+import Data.Maybe (fromJust)+import Test.QuickCheck+import System.FilePath    ((</>))+import System.Directory   ( getTemporaryDirectory+                          , createDirectoryIfMissing+                          , removeDirectoryRecursive+                          , doesDirectoryExist+                          )+++alice_pub_fpr :: BS.ByteString+alice_pub_fpr = "EAACEB8A"++bob_pub_fpr :: BS.ByteString+bob_pub_fpr = "6C4FB8F2"++-- Orphan instance here! Because this is only a test, orphans are probably OK.+-- http://stackoverflow.com/a/3081367/350221+instance Arbitrary BS.ByteString where+    arbitrary = fmap BS.pack arbitrary++justAndRight :: Maybe (Either a b) -> Bool+justAndRight = either (const False) (const True) . maybe (Left undefined) id++fromJustAndRight :: (Show a) => Maybe (Either a b) -> b+fromJustAndRight = fromRight . fromJust++fromRight :: (Show a) => Either a b -> b+fromRight = either (\e -> error $ "not right: " ++ show e) id++fromLeft :: Either e a -> e+fromLeft (Left e) = e+fromLeft _        = error "is not left"++isLeft :: Either a b -> Bool+isLeft (Right _) = False+isLeft (Left _)  = True++createTemporaryTestDir :: String -> IO FilePath+createTemporaryTestDir s = do+  tmpDir <- getTemporaryDirectory >>= \x -> pure $ x </> s+  -- Cleanup tests that failed the last time+  tmp_check <- doesDirectoryExist tmpDir+  if tmp_check+    then removeDirectoryRecursive tmpDir+    else return ()+  -- Create temporary directory+  createDirectoryIfMissing True tmpDir+  return tmpDir