h-gpgme 0.5.1.0 → 0.6.3.1
raw patch · 23 files changed
Files
- .gitignore +0/−11
- .travis.yml +0/−36
- CHANGELOG.markdown +0/−37
- CHANGELOG.md +106/−0
- LICENSE +1/−1
- README.markdown +0/−23
- README.md +100/−0
- Setup.hs +0/−2
- h-gpgme.cabal +55/−53
- src/Crypto/Gpgme.hs +19/−9
- src/Crypto/Gpgme/Crypto.hs +14/−21
- src/Crypto/Gpgme/Ctx.hs +15/−9
- src/Crypto/Gpgme/Internal.hs +63/−19
- src/Crypto/Gpgme/Key.hs +155/−25
- src/Crypto/Gpgme/Key/Gen.hs +13/−14
- src/Crypto/Gpgme/Types.hs +23/−6
- test/CryptoTest.hs +130/−129
- test/CtxTest.hs +28/−28
- test/InternalTest.hs +54/−0
- test/KeyGenTest.hs +48/−47
- test/KeyTest.hs +168/−76
- test/Main.hs +7/−4
- test/TestUtil.hs +45/−10
− .gitignore
@@ -1,11 +0,0 @@-.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
− .travis.yml
@@ -1,36 +0,0 @@-# 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}
− CHANGELOG.markdown
@@ -1,37 +0,0 @@-# 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)
+ CHANGELOG.md view
@@ -0,0 +1,106 @@+# Changelog++## 0.6.3.1++### Bug fixes++- fix: segfault in verify, verifyDetached and verifyPlain when the verify operation fails before gpgme produces a result (e.g. invalid homedir), as gpgme_op_verify_result returns NULL in that case (https://stackoverflow.com/questions/48908274): https://github.com/rethab/h-gpgme/pull/72+- fix: infinite recursion in collectFprs when encrypt or sign reports invalid keys: https://github.com/rethab/h-gpgme/pull/72+- fix: segfault in newCtx when the gpg engine is not installed and its version is NULL: https://github.com/rethab/h-gpgme/pull/72++### Maintenance++- chore: drop the docker-compose test runner, the shell script wrappers and stack.yaml; CI now builds with cabal against the declared bounds, plus a --prefer-oldest job to keep the lower bounds honest: https://github.com/rethab/h-gpgme/pull/71+- chore(test): wire setPassphraseCallback into the tests that unlock a secret key, which unmarks most NoCi tests, and move the alice/bob keyrings to keybox format so gpg stops migrating them on every run: https://github.com/rethab/h-gpgme/pull/71+- docs: document the actual feature surface in the README: https://github.com/rethab/h-gpgme/pull/71++## 0.6.3.0++### New Features++- feat: add importKeyFromBytes function: https://github.com/rethab/h-gpgme/pull/66+- feat: add exportKey, exportSecretKey and exportKeys functions: https://github.com/rethab/h-gpgme/pull/70+- feat: support gpgme 2.x by allowing bindings-gpgme 0.2: https://github.com/rethab/h-gpgme/pull/69++### Bug fixes++- fix: release the gpgme data buffer after import and export operations: https://github.com/rethab/h-gpgme/pull/70+- fix: importKeyFromFile and importKeyFromBytes reported success instead of the actual error when the import operation failed: https://github.com/rethab/h-gpgme/pull/70+- docs: fix reversed doc comments on IncludeSecret: https://github.com/rethab/h-gpgme/pull/68+- fix(test): skip gpg-agent sockets when copying the key fixture, which broke removeAliceKey wherever GnuPG puts its sockets in the homedir: https://github.com/rethab/h-gpgme/pull/69++### Maintenance++- chore(ci): modernize CI with a real multi-GHC matrix, latest actions and hardened permissions: https://github.com/rethab/h-gpgme/pull/67+- chore(ci): release to Hackage from a version tag: https://github.com/rethab/h-gpgme/pull/69+- chore(ci): test against gpgme 1.x and 2.x, both built from source: https://github.com/rethab/h-gpgme/pull/69+- chore: give every dependency a PVP upper bound: https://github.com/rethab/h-gpgme/pull/69++## 0.6.2.0++### New Features++- feat: add searchKeys function: https://github.com/rethab/h-gpgme/pull/52++## 0.6.1.0++### New Features++- feat: performance improvement / copy more than one byte from gpgme_data: https://github.com/rethab/h-gpgme/pull/61++### Maintenance++- chore(ci): Run tests without docker-compose in CI & cross-test with various GHC versions: https://github.com/rethab/h-gpgme/pull/60++## 0.6.0.0++### New Features++- BREAKING: Add force flag to removeKey function: https://github.com/rethab/h-gpgme/pull/57+- Add function to import key from file: https://github.com/rethab/h-gpgme/pull/54 (thanks @chiropical)++### Maintenance++- Migrate to GitHub Actions: https://github.com/rethab/h-gpgme/pull/55, https://github.com/rethab/h-gpgme/pull/58, and https://github.com/rethab/h-gpgme/pull/59++## 0.5.1.0++### New Features++- Add key listing modes (thanks mmhat)++## 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)
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014 Reto Hablützel+Copyright (c) 2014-2026 Reto Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
− README.markdown
@@ -1,23 +0,0 @@-[](https://hackage.haskell.org/package/h-gpgme) [](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)
+ README.md view
@@ -0,0 +1,100 @@+[](https://hackage.haskell.org/package/h-gpgme)+[](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml)+++h-gpgme: High Level Haskell Bindings for GnuPG Made Easy+========================================================++h-gpgme wraps [gpgme](https://www.gnupg.org/software/gpgme/), the library GnuPG+offers to programs that want OpenPGP without shelling out to `gpg`. The API+stays close to the C one, but the memory management, error handling and resource+cleanup a C API leaves to the caller become ordinary Haskell values and+`bracket`-style functions.++The crypto itself comes from the GnuPG installation already on the machine: the+same keyrings, the same `gpg-agent`, the same trust database.++## Features++- **Encryption and decryption** — to one or more recipients (`encrypt`,+ `decrypt`), symmetrically when you name no recipient at all, and on file+ descriptors (`encryptFd`, `decryptFd`) for data you would rather not hold in+ memory.+- **Signing and verification** — normal, detached and cleartext signatures+ (`sign` with `SignMode`), verification of attached and detached signatures+ (`verify`, `verifyDetached`), and the combined `encryptSign` / `decryptVerify`.+- **Key lookup** — by fingerprint (`getKey`), across a keyring (`listKeys`), or+ by user id (`searchKeys`), down to the user ids, subkeys, algorithms and+ validity of what comes back.+- **Key import, export and removal** — `importKeyFromFile`,+ `importKeyFromBytes`; `exportKey`, `exportSecretKey` and `exportKeys` with+ `ExportMode`, armored if the context has `setArmor`; `removeKey`.+- **Key generation** — `Crypto.Gpgme.Key.Gen` builds the parameter list gpgme+ expects (key type, length, usage, expiry, passphrase) out of types rather than+ hand-written strings.+- **Callbacks** — answer a passphrase request from your own code instead of a+ pinentry prompt (`setPassphraseCallback`), and follow slow operations with+ `setProgressCallback`.++Every operation runs in a `Ctx`, a gpgme context bound to a GnuPG home+directory. Use `withCtx` and it is freed for you.++## Requirements++The gpgme C library with its headers, and a GnuPG installation:++```sh+apt install libgpgme-dev # Debian, Ubuntu+brew install gpgme # macOS+```++Both the gpgme 1.x and 2.x series work. gpgme 2.x additionally needs+`bindings-gpgme >= 0.2`, since gpgme 2.0 dropped the trust item API that older+bindings referenced.++## Getting started++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Crypto.Gpgme++main :: IO ()+main = do+ let alicePubFpr = "EAACEB8A"++ -- encrypt for alice, out of bob's keyring+ Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> do+ Just aPubKey <- getKey bCtx alicePubFpr NoSecret+ either (const Nothing) Just <$> encrypt bCtx [aPubKey] NoFlag "hello"++ -- decrypt as alice, answering the passphrase request in-process rather than+ -- at a pinentry prompt (needs allow-loopback-pinentry in gpg-agent.conf)+ dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx -> do+ setPassphraseCallback aCtx (Just (\_ _ _ -> return (Just "alice123")))+ decrypt aCtx enc++ print dec+```++`withCtx` takes the home directory, the locale and the protocol. For one-shot+use there are shorthands that build their own context, like+`encrypt' "test/bob" alicePubFpr "hello"`.++The [test suite](test) doubles as the fullest set of examples: it exercises every+operation above against the keyrings in `test/`.++## Documentation++The API docs live on [Hackage](https://hackage.haskell.org/package/h-gpgme).+For what each underlying call really does, the+[gpgme manual](https://www.gnupg.org/documentation/manuals/gpgme.pdf) is the+authority — h-gpgme's names follow it closely.++## Contributing++Issues and pull requests are welcome. `cabal test` runs the suite; tests+marked `NoCi` are skipped in CI with `--test-options='--pattern=!/NoCi/'`. [test/README.md](test/README.md) describes+the test keyrings, and [RELEASE.md](RELEASE.md) how a release is cut.++[Changelog](CHANGELOG.md) · [License](LICENSE) (MIT)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
h-gpgme.cabal view
@@ -1,33 +1,49 @@-Name: h-gpgme-Version: 0.5.1.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@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-+cabal-version: 2.4+name: h-gpgme+version: 0.6.3.1+synopsis: High Level Binding for GnuPG Made Easy (gpgme)+description: High Level Binding for GnuPG Made Easy (gpgme): A Haskell API for the gpgme C library.+license: MIT+license-file: LICENSE+author: Reto+maintainer: rethab@protonmail.com+copyright: (c) 2014-2026 Reto+homepage: https://github.com/rethab/h-gpgme+bug-reports: https://github.com/rethab/h-gpgme/issues+category: Cryptography+build-type: Simple+tested-with: GHC == 8.10.7+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.4+extra-doc-files: CHANGELOG.md+ , README.md source-repository head type: git location: https://github.com/rethab/h-gpgme +common warnings+ ghc-options: -Wall+ default-language: Haskell2010++common deps+ build-depends: base >= 4.14 && <5+ , bindings-gpgme >= 0.1.8 && <0.3+ , bytestring >= 0.10 && <0.13+ , transformers >= 0.4.1 && <0.7+ , time >= 1.4 && <2+ , unix >= 2.5 && <2.9+ , email-validate >= 2.0 && <2.4+ , data-default >= 0.5 && <0.9+ library+ import: warnings, deps hs-source-dirs: src- ghc-options: -Wall- -fno-warn-orphans+ ghc-options: -fno-warn-orphans exposed-modules: Crypto.Gpgme , Crypto.Gpgme.Key.Gen other-modules: Crypto.Gpgme.Key@@ -35,41 +51,26 @@ , Crypto.Gpgme.Crypto , Crypto.Gpgme.Internal , Crypto.Gpgme.Types- build-depends: base == 4.*- , bindings-gpgme >= 0.1.6 && <0.2- , bytestring >= 0.9- , 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+ import: warnings, deps type: exitcode-stdio-1.0- default-language: Haskell2010- ghc-options: -Wall- hs-source-dirs: src, test main-is: Main.hs- build-depends: base == 4.*- , bindings-gpgme >= 0.1.6 && <0.2- , bytestring >= 0.9- , 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.4- , tasty >= 0.10 && <1.0- , tasty-quickcheck >= 0.8 && <1.0- , tasty-hunit >= 0.9 && <1.0- , QuickCheck + -- The tests reach into modules the library does not expose (Types, Internal),+ -- so they compile the sources rather than depend on the library.+ hs-source-dirs: src, test++ build-depends: directory >= 1.2 && <2+ , filepath >= 1.3 && <2+ , temporary >= 1.2 && <2+ , exceptions >= 0.8 && <0.11++ , HUnit >= 1.3 && <2+ , tasty >= 1.0 && <2+ , tasty-quickcheck >= 0.9 && <0.12+ , tasty-hunit >= 0.10 && <0.11+ , QuickCheck >= 2.10 && <3 other-modules: Crypto.Gpgme , Crypto.Gpgme.Crypto , Crypto.Gpgme.Ctx@@ -79,6 +80,7 @@ , Crypto.Gpgme.Types , CryptoTest , CtxTest+ , InternalTest , KeyTest , KeyGenTest , TestUtil
src/Crypto/Gpgme.hs view
@@ -9,7 +9,7 @@ -- Portability : untested -- -- High Level Binding for GnuPG Made Easy (gpgme)--- +-- -- Most of these functions are a one-to-one translation -- from GnuPG API with some Haskell idiomatics to make -- the API more convenient.@@ -19,16 +19,16 @@ -- -- == Example (from the tests): ----- >let alice_pub_fpr = "EAACEB8A" --- > +-- >let alice_pub_fpr = "EAACEB8A"+-- > -- >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 +-- > 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+-- > -- module Crypto.Gpgme (@@ -49,9 +49,19 @@ -- * Keys , Key+ , importKeyFromFile+ , importKeyFromBytes , getKey , listKeys , removeKey+ , RemoveKeyFlags(..)++ , searchKeys+ -- * Exporting keys+ , exportKey+ , exportSecretKey+ , exportKeys+ , ExportMode(..) -- * Information about keys , Validity (..) , PubKeyAlgo (..)
src/Crypto/Gpgme/Crypto.hs view
@@ -26,7 +26,6 @@ import Bindings.Gpgme import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8-import Control.Monad (liftM) import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, mapExceptT) import Foreign import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)@@ -53,7 +52,7 @@ encryptSign' = encryptIntern' encryptSign orElse :: Monad m => m (Maybe a) -> e -> ExceptT e m a-orElse action err = ExceptT $ maybe (Left err) return `liftM` action+orElse action err = ExceptT $ maybe (Left err) return `fmap` action bimapExceptT :: Functor m => (x -> y) -> (a -> b) -> ExceptT x m a -> ExceptT y m b bimapExceptT f g = mapExceptT (fmap h)@@ -89,7 +88,7 @@ -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) -encryptIntern enc_op (Ctx {_ctx=ctxPtr}) recPtrs flag plain = do+encryptIntern enc_op Ctx {_ctx=ctxPtr} recPtrs flag plain = do -- init buffer with plaintext plainBufPtr <- malloc BS.useAsCString plain $ \bs -> do@@ -145,7 +144,7 @@ -> Fd -- ^ Plaintext data -> Fd -- ^ Ciphertext data -> IO (Either [InvalidKey] ())-encryptFdIntern enc_op (Ctx {_ctx=ctxPtr}) recPtrs flag (Fd plainCInt) (Fd cipherCInt) = do+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@@ -171,7 +170,7 @@ let res = if recPtr /= nullPtr then Left (collectFprs recPtr)- else Right (())+ else Right () free cipherBufPtr @@ -218,7 +217,7 @@ -> Ctx -> Encrypted -> IO (Either DecryptError Plain)-decryptIntern dec_op (Ctx {_ctx=ctxPtr}) cipher = do+decryptIntern dec_op Ctx {_ctx=ctxPtr} cipher = do -- init buffer with cipher cipherBufPtr <- malloc BS.useAsCString cipher $ \bs -> do@@ -263,7 +262,7 @@ -> Fd -> Fd -> IO (Either DecryptError ())-decryptFdIntern dec_op (Ctx {_ctx=ctxPtr}) (Fd cipherCInt) (Fd plainCInt)= do+decryptFdIntern dec_op Ctx {_ctx=ctxPtr} (Fd cipherCInt) (Fd plainCInt)= do -- Initialize ciphertext buffer cipherBufPtr <- malloc _ <- c'gpgme_data_new_from_fd cipherBufPtr cipherCInt@@ -281,7 +280,7 @@ let res = if errcode /= noError then Left (toDecryptError errcode)- else Right (())+ else Right () free cipherBufPtr free plainBufPtr@@ -307,7 +306,7 @@ -> SignMode -> Plain -> IO (Either [InvalidKey] Encrypted)-signIntern sign_op (Ctx {_ctx=ctxPtr}) signPtrs mode plain = do+signIntern sign_op Ctx {_ctx=ctxPtr} signPtrs mode plain = do -- init buffer with plaintext plainBufPtr <- malloc BS.useAsCString plain $ \bs -> do@@ -324,7 +323,7 @@ ctx <- peek ctxPtr -- add signing keys- _ <- mapM ( \kForPtr -> withForeignPtr (unKey kForPtr)+ mapM_ ( \kForPtr -> withForeignPtr (unKey kForPtr) (\kPtr -> do k <- peek kPtr c'gpgme_signers_add ctx k@@ -419,7 +418,7 @@ -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, a))-verifyInternal ver_op (Ctx {_ctx=ctxPtr}) sig dat = do+verifyInternal ver_op Ctx {_ctx=ctxPtr} sig dat = do -- init buffer with signature sigBufPtr <- malloc BS.useAsCString sig $ \bs -> do@@ -443,18 +442,12 @@ -- verify (errcode, res) <- ver_op ctx sigBuf datBuf - sigs <- collectSignatures' ctx- let res' = if errcode /= noError- then Left (GpgmeError errcode)- else Right (sigs, res)+ res' <- if errcode /= noError+ then return (Left (GpgmeError errcode))+ else do sigs <- collectSignatures' ctx+ return (Right (sigs, res)) free sigBufPtr free datBufPtr return res'--newDataBuffer :: IO (Ptr C'gpgme_data_t)-newDataBuffer = do- resultBufPtr <- malloc- checkError "data_new" =<< c'gpgme_data_new resultBufPtr- return resultBufPtr
src/Crypto/Gpgme/Ctx.hs view
@@ -4,6 +4,7 @@ import Control.Monad (when) import Control.Exception (SomeException(SomeException), catch, throwIO, toException) import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe) import Foreign import Foreign.C.String import Foreign.C.Types@@ -30,9 +31,14 @@ ctx <- peek ctxPtr - -- find engine version- engInfo <- c'gpgme_ctx_get_engine_info ctx >>= peek- engVersion <- peekCString $ c'_gpgme_engine_info'version engInfo+ -- the version field is NULL when the engine binary is not installed+ engInfoPtr <- c'gpgme_ctx_get_engine_info ctx+ engVersion <- if engInfoPtr == nullPtr+ then return ""+ else do verPtr <- peek (p'_gpgme_engine_info'version engInfoPtr)+ if verPtr == nullPtr+ then return ""+ else peekCString verPtr -- set locale locale <- newCString localeStr@@ -52,7 +58,7 @@ -- | Free a previously created 'Ctx' freeCtx :: Ctx -> IO ()-freeCtx (Ctx {_ctx=ctxPtr}) =+freeCtx Ctx {_ctx=ctxPtr} = do ctx <- peek ctxPtr c'gpgme_release ctx free ctxPtr@@ -83,13 +89,13 @@ -- | Sets armor output on ctx setArmor :: Bool -> Ctx -> IO ()-setArmor armored (Ctx {_ctx = ctxPtr}) = do+setArmor armored Ctx {_ctx = ctxPtr} = do ctx <- peek ctxPtr c'gpgme_set_armor ctx (if armored then 1 else 0) -- | Sets the key listing mode on ctx setKeyListingMode :: [KeyListingMode] -> Ctx -> IO ()-setKeyListingMode modes (Ctx {_ctx = ctxPtr}) = do+setKeyListingMode modes Ctx {_ctx = ctxPtr} = do let m = foldl (\memo -> (memo .|.) . fromKeyListingMode) 0 modes ctx <- peek ctxPtr checkError "set_keylist_mode" =<< c'gpgme_set_keylist_mode ctx m@@ -126,7 +132,7 @@ hint' <- peekCString hint info' <- peekCString info result <- callback hint' info' (prev_bad /= 0)- let phrase = maybe "" id result+ let phrase = fromMaybe "" result err <- withCStringLen (phrase++"\n") $ \(s,len) -> c'gpgme_io_writen fd (castPtr s) (fromIntegral len) when (err /= 0) $ checkError "passphraseCb" (fromIntegral err)@@ -148,7 +154,7 @@ setPassphraseCallback :: Ctx -- ^ context -> Maybe PassphraseCb -- ^ a callback, or Nothing to disable -> IO ()-setPassphraseCallback (Ctx {_ctx=ctxPtr}) callback = do+setPassphraseCallback Ctx {_ctx=ctxPtr} callback = do ctx <- peek ctxPtr let mode = case callback of Nothing -> c'GPGME_PINENTRY_MODE_DEFAULT@@ -182,7 +188,7 @@ setProgressCallback :: Ctx -- ^ context -> Maybe ProgressCb -> IO ()-setProgressCallback (Ctx {_ctx=ctxPtr}) callback = do+setProgressCallback Ctx {_ctx=ctxPtr} callback = do ctx <- peek ctxPtr cb <- maybe (return nullFunPtr) progressCb callback c'gpgme_set_progress_cb ctx cb nullPtr
src/Crypto/Gpgme/Internal.hs view
@@ -3,36 +3,60 @@ import Bindings.Gpgme import Control.Monad (unless) import qualified Data.ByteString as BS-import Foreign (allocaBytes, castPtr, nullPtr, peek)+import qualified Data.ByteString.Internal as BS (createAndTrim)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Internal as LBS (defaultChunkSize)+import Foreign (castPtr, nullPtr, peek, Ptr, malloc) import Foreign.C.String (peekCString) import Foreign.C.Types (CUInt, CInt) import System.IO.Unsafe (unsafePerformIO) import Crypto.Gpgme.Types +-- Fields are read via the p' accessors: peeking a whole C'_gpgme_invalid_key+-- diverges because its Storable instance recursively peeks the mistyped+-- @next@ field. collectFprs :: C'gpgme_invalid_key_t -> [InvalidKey]-collectFprs result = unsafePerformIO $ peek result >>= go- where go :: C'_gpgme_invalid_key -> IO [InvalidKey]- go invalid = do- fpr <- peekCString (c'_gpgme_invalid_key'fpr invalid)- let reason = fromIntegral (c'_gpgme_invalid_key'reason invalid)- rest <- go (c'_gpgme_invalid_key'next invalid)+collectFprs = unsafePerformIO . go+ where go :: C'gpgme_invalid_key_t -> IO [InvalidKey]+ go ptr | ptr == nullPtr = return []+ go ptr = do+ fprPtr <- peek (p'_gpgme_invalid_key'fpr ptr)+ fpr <- if fprPtr == nullPtr then return "" else peekCString fprPtr+ reason <- fromIntegral `fmap` peek (p'_gpgme_invalid_key'reason ptr)+ next <- peek (castPtr (p'_gpgme_invalid_key'next ptr) :: Ptr C'gpgme_invalid_key_t)+ rest <- go next return ((fpr, reason) : rest) +-- | Read the buffer into a ByteString.+--+-- Chunks of Data.ByteString.Lazy.Internal.defaultChunkSize are allocated and+-- copied, until the gpgme_data_readbuffer read returns less than this.+-- Then the list of chunks are copied into a strict ByteString by way of a lazy+-- ByteString. collectResult :: C'gpgme_data_t -> BS.ByteString collectResult dat' = unsafePerformIO $ do -- make sure we start at the beginning _ <- c'gpgme_data_seek dat' 0 seekSet- go dat'- where go :: C'gpgme_data_t -> IO BS.ByteString- go dat = allocaBytes 1 $ \buf ->- do read_bytes <- c'gpgme_data_read dat buf 1- if read_bytes == 1- then do byte <- peek (castPtr buf)- rest <- go dat- return (byte `BS.cons` rest)- else return BS.empty+ chunks <- go dat'+ pure $ LBS.toStrict (LBS.fromChunks chunks)+ where makeChunk :: C'gpgme_data_t -> IO BS.ByteString+ makeChunk dat = BS.createAndTrim chunkSize $ \buf -> do+ -- createAndTrim gives a Ptr Word8 but the gpgme functions wants a Ptr ()+ read_bytes <- c'gpgme_data_read dat (castPtr buf) (fromIntegral chunkSize)+ pure $ fromIntegral read_bytes++ go :: C'gpgme_data_t -> IO [BS.ByteString]+ go dat = do+ bs <- makeChunk dat+ if BS.length bs < chunkSize+ then pure [bs]+ else do+ bss <- go dat+ pure (bs : bss)+ seekSet = 0+ chunkSize = LBS.defaultChunkSize -- ^ Unsafe IO version of `collectSignatures`. Try to use `collectSignatures'` instead. collectSignatures :: C'gpgme_ctx_t -> VerificationResult@@ -42,14 +66,17 @@ 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+ -- NULL unless the last operation on the context was a successful verify+ if verify_res == nullPtr+ then return []+ else go =<< peek (p'_gpgme_op_verify_result'signatures verify_res) 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+ fprPtr <- peek (p'_gpgme_signature'fpr sig)+ fpr <- if fprPtr == nullPtr then return BS.empty else BS.packCString fprPtr next <- peek $ p'_gpgme_signature'next sig xs <- go next return $ (GpgmeError status, toSignatureSummaries summary, fpr) : xs@@ -76,6 +103,17 @@ fromKeyListingMode KeyListingValidate = c'GPGME_KEYLIST_MODE_VALIDATE +-- The GPGME_EXPORT_MODE_* values are replicated from gpgme.h:+-- bindings-gpgme 0.1 does not bind these constants and 0.2 only+-- binds the ones known to the gpgme version it was built against.+fromExportMode :: ExportMode -> CUInt+fromExportMode ExportMinimal = 4 -- GPGME_EXPORT_MODE_MINIMAL+fromExportMode ExportSecret = 16 -- GPGME_EXPORT_MODE_SECRET+fromExportMode ExportRaw = 32 -- GPGME_EXPORT_MODE_RAW+fromExportMode ExportPKCS12 = 64 -- GPGME_EXPORT_MODE_PKCS12+fromExportMode ExportSSH = 256 -- GPGME_EXPORT_MODE_SSH+fromExportMode ExportSecretSubkey = 512 -- GPGME_EXPORT_MODE_SECRET_SUBKEY+ fromProtocol :: (Num a) => Protocol -> a fromProtocol CMS = c'GPGME_PROTOCOL_CMS fromProtocol GPGCONF = c'GPGME_PROTOCOL_GPGCONF@@ -109,3 +147,9 @@ | n == c'GPGME_PK_DSA = Dsa | n == c'GPGME_PK_ELG = Elg | otherwise = error "toPubKeyAlgo: Unrecognized public key algorithm"++newDataBuffer :: IO (Ptr C'gpgme_data_t)+newDataBuffer = do+ resultBufPtr <- malloc+ checkError "data_new" =<< c'gpgme_data_new resultBufPtr+ return resultBufPtr
src/Crypto/Gpgme/Key.hs view
@@ -1,7 +1,15 @@ module Crypto.Gpgme.Key ( getKey+ , importKeyFromFile+ , importKeyFromBytes , listKeys , removeKey+ , searchKeys+ -- * Exporting keys+ , exportKey+ , exportSecretKey+ , exportKeys+ , ExportMode (..) -- * Information about keys , Validity (..) , PubKeyAlgo (..)@@ -16,7 +24,9 @@ ) where import Bindings.Gpgme+import Control.Monad (when) import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC8 import Data.Time.Clock import Data.Time.Clock.POSIX import Foreign@@ -26,13 +36,29 @@ import Crypto.Gpgme.Types import Crypto.Gpgme.Internal --- | Returns a list of known 'Key's from the @context@.+-- | Returns a list of all known 'Key's from the @context@. listKeys :: Ctx -- ^ context to operate in- -> IncludeSecret -- ^ whether to include the secrets+ -> IncludeSecret -- ^ whether to restrict to secret keys -> IO [Key]-listKeys (Ctx {_ctx=ctxPtr}) secret = do+listKeys ctx secret = listKeys' ctx secret nullPtr++-- | Returns a list of known 'Key's from the @context@ that match a given pattern.+searchKeys :: Ctx -- ^ context to operate in+ -> IncludeSecret -- ^ whether to restrict to secret keys+ -> String -- ^ The pattern to look for; It is typically+ -- matched against the user ids of a key.+ -> IO [Key]+searchKeys ctx secret pat = BS.useAsCString (BSC8.pack pat) (listKeys' ctx secret)++-- | Internal helper function used by both `listKeys` and `searchKeys`.+listKeys' :: Ctx -- ^ context to operate in+ -> IncludeSecret -- ^ whether to restrict to secret keys+ -> CString -- ^ The pattern to look for; It is typically+ -- matched against the user ids of a key.+ -> IO [Key]+listKeys' Ctx {_ctx=ctxPtr} secret pat = do peek ctxPtr >>= \ctx ->- c'gpgme_op_keylist_start ctx nullPtr (fromSecret secret) >>= checkError "listKeys"+ c'gpgme_op_keylist_start ctx pat (fromSecret secret) >>= checkError "listKeys" let eof = 16383 go accum = do key <- allocKey@@ -49,9 +75,9 @@ -- Returns 'Nothing' if no 'Key' with this 'Fpr' exists. getKey :: Ctx -- ^ context to operate in -> Fpr -- ^ fingerprint- -> IncludeSecret -- ^ whether to include secrets when searching for the key+ -> IncludeSecret -- ^ whether to look for a secret key -> IO (Maybe Key)-getKey (Ctx {_ctx=ctxPtr}) fpr secret = do+getKey Ctx {_ctx=ctxPtr} fpr secret = do key <- allocKey ret <- BS.useAsCString fpr $ \cFpr -> peek ctxPtr >>= \ctx ->@@ -61,25 +87,128 @@ then return . Just $ key else return Nothing +-- | Import a key from a file, this happens in two steps: populate a+-- @gpgme_data_t@ with the contents of the file, import the @gpgme_data_t@+importKeyFromFile :: Ctx -- ^ context to operate in+ -> FilePath -- ^ file path to read from+ -> IO (Maybe GpgmeError)+importKeyFromFile ctx fp =+ importData ctx $ \dataPtr ->+ BS.useAsCString (BSC8.pack fp) $ \cFp ->+ c'gpgme_data_new_from_file dataPtr cFp 1++-- | Import a key from a 'BS.ByteString', this happens in two steps: populate a+-- @gpgme_data_t@ with the contents of the buffer, import the @gpgme_data_t@+importKeyFromBytes :: Ctx -- ^ context to operate in+ -> BS.ByteString -- ^ buffer to read the key from+ -> IO (Maybe GpgmeError)+importKeyFromBytes ctx key =+ importData ctx $ \dataPtr ->+ BS.useAsCString key $ \cKey -> do+ -- gpgme must copy the buffer: the import in 'importData' runs after+ -- useAsCString returns, at which point cKey has been freed+ let copyData = 1+ let keylen = fromIntegral (BS.length key)+ c'gpgme_data_new_from_mem dataPtr cKey keylen copyData++-- | Populate a fresh @gpgme_data_t@ using the given action and import it.+-- The action is responsible for filling the buffer and returns the result+-- of doing so.+importData :: Ctx -- ^ context to operate in+ -> (Ptr C'gpgme_data_t -> IO C'gpgme_error_t) -- ^ populate the buffer+ -> IO (Maybe GpgmeError)+importData Ctx {_ctx=ctxPtr} populate = do+ -- the populate action allocates the data object itself, so it only+ -- needs an empty cell; it is initialized to NULL because gpgme+ -- leaves it untouched if populating fails+ dataPtr <- malloc+ poke dataPtr nullData+ ret <- populate dataPtr+ mGpgErr <-+ case ret of+ x | x == noError -> do+ retIn <- do+ ctx <- peek ctxPtr+ dat <- peek dataPtr+ c'gpgme_op_import ctx dat+ pure $ if retIn == noError+ then Nothing+ else Just $ GpgmeError retIn+ err -> pure $ Just $ GpgmeError err+ dat <- peek dataPtr+ when (dat /= nullData) $ c'gpgme_data_release dat+ free dataPtr+ pure mGpgErr+ where+ -- gpgme_data_t is bound as an integral type, so NULL is 0+ nullData = 0 :: C'gpgme_data_t++-- | Export the public key with the given @fingerprint@ from the+-- @context@. Returns an empty 'BS.ByteString' if no key with+-- this 'Fpr' exists.+exportKey :: Ctx -- ^ context to operate in+ -> Fpr -- ^ fingerprint of the key to export+ -> IO (Either GpgmeError BS.ByteString)+exportKey ctx fpr = exportKeys ctx [] [fpr]++-- | Export the secret key with the given @fingerprint@ from the+-- @context@.+--+-- Exporting a protected secret key requires its passphrase, which+-- may be supplied through @setPassphraseCallback@.+exportSecretKey :: Ctx -- ^ context to operate in+ -> Fpr -- ^ fingerprint of the key to export+ -> IO (Either GpgmeError BS.ByteString)+exportSecretKey ctx fpr = exportKeys ctx [ExportSecret] [fpr]++-- | Export all keys matching the given @fingerprints@ from the+-- @context@, or all keys if no fingerprint is given.+--+-- The keys are returned in armored format if armor has been+-- enabled on the @context@ (see @setArmor@) and in binary+-- format otherwise.+exportKeys :: Ctx -- ^ context to operate in+ -> [ExportMode] -- ^ modes for the export+ -> [Fpr] -- ^ fingerprints of the keys to export,+ -- or empty to export all keys+ -> IO (Either GpgmeError BS.ByteString)+exportKeys Ctx {_ctx=ctxPtr} modes fprs = do+ dataPtr <- newDataBuffer+ dat <- peek dataPtr+ ret <- withMany BS.useAsCString fprs $ \cFprs ->+ withArray0 nullPtr cFprs $ \pats -> do+ ctx <- peek ctxPtr+ c'gpgme_op_export_ext ctx pats cMode dat+ result <- if ret == noError+ then do+ -- collectResult is lazy: force the copy while the buffer+ -- it reads from is still alive+ let key = collectResult dat+ key `seq` return (Right key)+ else return (Left (GpgmeError ret))+ c'gpgme_data_release dat+ free dataPtr+ return result+ where+ cMode = foldl (\memo -> (memo .|.) . fromExportMode) 0 modes+ -- | Removes the 'Key' from @context@ removeKey :: Ctx -- ^ context to operate in -> Key -- ^ key to delete- -> IncludeSecret -- ^ include secret keys for deleting+ -> RemoveKeyFlags -- ^ flags for remove operation -> IO (Maybe GpgmeError)-removeKey (Ctx {_ctx=ctxPtr}) key secret = do+removeKey Ctx {_ctx=ctxPtr} key flags = do ctx <- peek ctxPtr ret <- withKeyPtr key (\keyPtr -> do k <- peek keyPtr- c'gpgme_op_delete ctx k s)+ c'gpgme_op_delete_ext ctx k cFlags) if ret == 0 then return Nothing else return $ Just $ GpgmeError ret where- s = secretToCInt secret- secretToCInt :: IncludeSecret -> CInt- secretToCInt WithSecret = 1- secretToCInt NoSecret = 0+ cFlags = (if allowSecret flags then 1 else 0) .|. (if force flags then 2 else 0) + -- | A key signature data KeySignature = KeySig { keysigAlgorithm :: PubKeyAlgo , keysigKeyId :: String@@ -98,8 +227,8 @@ readKeySignatures p0 = peekList c'_gpgme_key_sig'next p0 >>= mapM readSig where readSig sig =- KeySig <$> pure (toPubKeyAlgo $ c'_gpgme_key_sig'pubkey_algo sig)- <*> peekCString (c'_gpgme_key_sig'keyid sig)+ (KeySig (toPubKeyAlgo $ c'_gpgme_key_sig'pubkey_algo sig)+ <$> peekCString (c'_gpgme_key_sig'keyid sig)) <*> pure (readTime $ c'_gpgme_key_sig'timestamp sig) <*> pure (readTime $ c'_gpgme_key_sig'expires sig) <*> signerId@@ -141,9 +270,9 @@ where readKeyUserId :: C'_gpgme_user_id -> IO KeyUserId readKeyUserId uid =- KeyUserId <$> pure (toValidity $ c'_gpgme_user_id'validity uid)- <*> userId'- <*> readKeySignatures (c'_gpgme_user_id'signatures uid)+ (KeyUserId (toValidity $ c'_gpgme_user_id'validity uid)+ <$> userId')+ <*> readKeySignatures (c'_gpgme_user_id'signatures uid) where userId' :: IO UserId userId' =@@ -174,13 +303,14 @@ where readSubKey :: C'_gpgme_subkey -> IO SubKey readSubKey sub =- 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'fpr sub)- <*> pure (readTime $ c'_gpgme_subkey'timestamp sub)- <*> pure (readTime $ c'_gpgme_subkey'expires sub)- <*> orNull peekCString (c'_gpgme_subkey'card_number sub)+ (SubKey+ (toPubKeyAlgo $ c'_gpgme_subkey'pubkey_algo sub)+ (fromIntegral $ c'_gpgme_subkey'length sub)+ <$> peekCString (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) orNull :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) orNull f ptr
src/Crypto/Gpgme/Key/Gen.hs view
@@ -45,7 +45,6 @@ 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@@ -88,7 +87,7 @@ Nothing Nothing Nothing "" "" "" "" "" -- | Key-Length parameter-data BitSize = BitSize Int+newtype BitSize = BitSize Int -- | Bit size constrained to 1024-4096 bits bitSize :: Int -> Either String BitSize@@ -132,16 +131,16 @@ | CreationS Positive -- ^ Seconds since epoch -- | Only a positive Int-data Positive = Positive { unPositive :: Int }+newtype 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)+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+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@@ -158,9 +157,9 @@ -- | Used by 'genKey' generate a XML string for GPG toParamsString :: GenKeyParams -> BS.ByteString-toParamsString params = (BSC8.unlines . filter ((/=)""))+toParamsString params = (BSC8.unlines . filter ("" /=)) [ "<GnupgKeyParms format=\"internal\">"- , "Key-Type: " <> (maybe "default" keyTypeToString $ keyType params)+ , "Key-Type: " <> maybe "default" keyTypeToString (keyType params) , maybeLine "Key-Length: " keyLengthToString $ keyLength params , addLabel "Key-Grip: " $ keyGrip params , maybeLine "Key-Usage: " keyUsageListToString $ keyUsage params@@ -201,18 +200,18 @@ 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]+ 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 (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))+ 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))+ BSC8.pack ("seconds=" ++ show (unPositive p)) creationDateToString (CreationT t) = BSC8.pack $ formatTime defaultTimeLocale "%Y%m%dT%H%M%S" t
src/Crypto/Gpgme/Types.hs view
@@ -2,7 +2,7 @@ import Bindings.Gpgme import qualified Data.ByteString as BS-import Data.Maybe(catMaybes)+import Data.Maybe (mapMaybe) import Foreign import qualified Foreign.Concurrent as FC import Foreign.C.String (peekCString)@@ -34,6 +34,17 @@ | KeyListingSigNotations | KeyListingValidate +-- | Modes for exporting keys. Multiple modes can be combined,+-- e.g. @[ExportSecret, ExportPKCS12]@.+data ExportMode+ = ExportMinimal -- ^ Strip all signatures except the most recent self-signatures+ | ExportSecret -- ^ Export the secret keys instead of the public keys+ | ExportRaw -- ^ Only with 'ExportSecret' and 'CMS': export in raw format+ | ExportPKCS12 -- ^ Only with 'ExportSecret' and 'CMS': export in PKCS#12 format+ | ExportSSH -- ^ Export the public key in SSH format+ | ExportSecretSubkey -- ^ Export the secret subkeys instead of the public keys+ deriving (Show, Eq, Ord)+ -- | Modes for signing with GPG data SignMode = Normal | Detach | Clear deriving Show @@ -67,7 +78,7 @@ -- | 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)+toSignatureSummaries x = mapMaybe (\(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)@@ -101,12 +112,12 @@ -- | Perform an action with the pointer to a 'Key' withKeyPtr :: Key -> (Ptr C'gpgme_key_t -> IO a) -> IO a-withKeyPtr (Key fPtr) f = withForeignPtr fPtr f+withKeyPtr (Key fPtr) = withForeignPtr fPtr --- | Whether to include secret keys when searching+-- | Whether to restrict an operation to secret keys data IncludeSecret =- WithSecret -- ^ do not include secret keys- | NoSecret -- ^ include secret keys+ WithSecret -- ^ only consider secret keys+ | NoSecret -- ^ do not consider secret keys deriving (Show, Eq, Ord) data Flag =@@ -170,3 +181,9 @@ -- | h-gpgme exception for wrapping exception which occur outside of the control of h-gpgme newtype HgpgmeException = HgpgmeException SomeException deriving (Show) instance Exception HgpgmeException++-- | Flags for removeKey function+data RemoveKeyFlags = RemoveKeyFlags {+ allowSecret :: Bool -- ^ if False, only public keys are removed, otherwise secret keys are removed as well+ , force :: Bool -- ^ if True, don't ask for confirmation+ } deriving (Show, Eq, Ord)
test/CryptoTest.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}-module CryptoTest (tests, cbTests) where+module CryptoTest (tests) where import System.IO import System.IO.Temp import System.Posix.IO-import Control.Monad (liftM, when)+import Control.Monad (when) import Control.Monad.Trans.Maybe import Control.Monad.IO.Class import Control.Monad.Catch@@ -20,50 +20,55 @@ import Test.QuickCheck.Monadic import Crypto.Gpgme-import Crypto.Gpgme.Types ( GpgmeError (GpgmeError)- , SignMode ( Clear, Detach, Normal )- )+import Crypto.Gpgme.Types ( GpgmeError (GpgmeError) ) 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+-- | Anything that unlocks Alice's or Bob's secret key needs their passphrase.+-- The tests supply it through a passphrase callback, which puts gpgme into+-- loopback pinentry mode, so no test asks a human for anything.+--+-- The exception is 'bobEncryptForAliceDecrypt' @False@: it is deliberately+-- callback-free, to cover the path where the passphrase comes from the+-- gpg-agent's own pinentry. It carries a @NoCi@ marker because it wants a+-- human.+tests :: IO TestTree+tests = do+ cbSupported <- withCtx "test/bob" "C" OpenPGP $ \ctx ->+ return $ isPassphraseCbSupported ctx+ return $ testGroup "crypto" $+ [ testProperty "carolEncryptForCarolDecryptShort"+ carolEncryptForCarolDecryptShort+ , testProperty "carolEncryptSignForCarolDecryptVerifyShort"+ carolEncryptSignForCarolDecryptVerifyShort - , 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 "decryptGarbage" decryptGarbage+ , testCase "encryptWrongKey" encryptWrongKey - , 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- ]+ , testProperty "bobEncryptForAliceDecryptPromptNoCi"+ $ bobEncryptForAliceDecrypt False+ ] ++ if cbSupported then passphraseCbTests else [] -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" []+-- | Tests that can only run where gpgme supports passphrase callbacks, which+-- rules out the gpg 1.x and 2.0 engines (see 'isPassphraseCbSupported').+passphraseCbTests :: [TestTree]+passphraseCbTests =+ [ testProperty "bobEncryptForAliceDecrypt"+ $ bobEncryptForAliceDecrypt True+ , testProperty "bobEncryptSignForAliceDecryptVerify"+ $ bobEncryptSignForAliceDecryptVerify True + , testCase "bobEncryptSymmetricallyNoCi" bobEncryptSymmetrically+ , testCase "bobDetachSignAndVerifySpecifyKey" bobDetachSignAndVerifySpecifyKey+ , testCase "bobClearSignAndVerifySpecifyKey" bobClearSignAndVerifySpecifyKey+ , testCase "bobClearSignAndVerifyDefaultKey" bobClearSignAndVerifyDefaultKey+ , testCase "bobNormalSignAndVerifySpecifyKey" bobNormalSignAndVerifySpecifyKey+ , testCase "bobNormalSignAndVerifyDefaultKey" bobNormalSignAndVerifyDefaultKey+ , testCase "encryptFile" encryptFile+ , testCase "encryptStream" encryptStream+ ]+ hush :: Monad m => m (Either e a) -> MaybeT m a-hush = MaybeT . liftM (either (const Nothing) Just)+hush = MaybeT . fmap (either (const Nothing) Just) withPassphraseCb :: String -> Ctx -> IO () withPassphraseCb passphrase ctx = do@@ -71,140 +76,149 @@ where callback _ _ _ = return (Just passphrase) -bob_encrypt_for_alice_decrypt :: Bool -> Plain -> Property-bob_encrypt_for_alice_decrypt passphrCb plain =+bobEncryptForAliceDecrypt :: Bool -> Plain -> Property+bobEncryptForAliceDecrypt passphrCb plain = not (BS.null plain) ==> monadicIO $ do- dec <- run encr_and_decr+ dec <- run encrAndDecr assert $ dec == plain- where encr_and_decr =- do -- encrypt+ where encrAndDecr =+ do Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr 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 =+carolEncryptForCarolDecryptShort :: Plain -> Property+carolEncryptForCarolDecryptShort plain = not (BS.null plain) ==> monadicIO $ do- dec <- run encr_and_decr+ dec <- run encrAndDecr assert $ dec == plain- where encr_and_decr =- do -- encrypt- enc <- encrypt' "test/bob" alice_pub_fpr plain+ where encrAndDecr =+ do+ enc <- encrypt' "test/carol" carolPubFpr plain - -- decrypt- dec <- decrypt' "test/alice" (fromRight enc)+ dec <- decrypt' "test/carol" (fromRight enc) return $ fromRight dec -bob_encrypt_sign_for_alice_decrypt_verify :: Bool -> Plain -> Property-bob_encrypt_sign_for_alice_decrypt_verify passphrCb plain =+bobEncryptSignForAliceDecryptVerify :: Bool -> Plain -> Property+bobEncryptSignForAliceDecryptVerify passphrCb plain = not (BS.null plain) ==> monadicIO $ do- dec <- run encr_and_decr+ dec <- run encrAndDecr 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+ where encrAndDecr =+ do+ Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> do+ -- signing unlocks Bob's secret key, so this side needs the+ -- passphrase as well+ when passphrCb $ withPassphraseCb "bob123" bCtx+ runMaybeT $ do+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr 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 =+carolEncryptSignForCarolDecryptVerifyShort :: Plain -> Property+carolEncryptSignForCarolDecryptVerifyShort plain = not (BS.null plain) ==> monadicIO $ do- dec <- run encr_and_decr+ dec <- run encrAndDecr assert $ dec == plain- where encr_and_decr =- do -- encrypt- enc <- encryptSign' "test/bob" alice_pub_fpr plain+ where encrAndDecr =+ do+ enc <- encryptSign' "test/carol" carolPubFpr plain - -- decrypt- dec <- decryptVerify' "test/alice" (fromRight enc)+ dec <- decryptVerify' "test/carol" (fromRight enc) return $ fromRight dec -encrypt_wrong_key :: Assertion-encrypt_wrong_key = do+encryptWrongKey :: Assertion+encryptWrongKey = 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+decryptGarbage :: Assertion+decryptGarbage = 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+bobEncryptSymmetrically :: Assertion+bobEncryptSymmetrically = do - -- encrypt cipher <- fmap fromRight $- withCtx "test/bob" "C" OpenPGP $ \ctx ->+ withCtx "test/bob" "C" OpenPGP $ \ctx -> do+ withPassphraseCb symmetricPassphrase ctx encrypt ctx [] NoFlag "plaintext" assertBool "must not be plain" (cipher /= "plaintext") - -- decrypt plain <- fmap fromRight $- withCtx "test/alice" "C" OpenPGP $ \ctx ->+ withCtx "test/alice" "C" OpenPGP $ \ctx -> do+ withPassphraseCb symmetricPassphrase ctx decrypt ctx cipher assertEqual "should decrypt to same" "plaintext" plain+ where+ -- symmetric encryption is not tied to a key, so any passphrase will do as+ -- long as both sides agree on it+ symmetricPassphrase = "symmetric123" -bob_detach_sign_and_verify_specify_key_prompt :: Assertion-bob_detach_sign_and_verify_specify_key_prompt = do+bobDetachSignAndVerifySpecifyKey :: Assertion+bobDetachSignAndVerifySpecifyKey = do resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do- key <- getKey ctx bob_pub_fpr NoSecret+ withPassphraseCb "bob123" ctx+ key <- getKey ctx bobPubFpr NoSecret let msgToSign = "Clear text message from bob!!"- resSign <-sign ctx [(fromJust key)] Detach msgToSign+ 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+bobClearSignAndVerifySpecifyKey :: Assertion+bobClearSignAndVerifySpecifyKey = 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) ""+ withPassphraseCb "bob123" ctx+ key <- getKey ctx bobPubFpr NoSecret+ resSign <- sign ctx [fromJust key] Clear "Clear text message from bob specifying signing key"+ verify 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+bobClearSignAndVerifyDefaultKey :: Assertion+bobClearSignAndVerifyDefaultKey = do resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+ withPassphraseCb "bob123" ctx resSign <- sign ctx [] Clear "Clear text message from bob with default key"- verifyPlain ctx (fromRight resSign) ""+ verify 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+bobNormalSignAndVerifySpecifyKey :: Assertion+bobNormalSignAndVerifySpecifyKey = 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"+ withPassphraseCb "bob123" ctx+ key <- getKey ctx bobPubFpr 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+bobNormalSignAndVerifyDefaultKey :: Assertion+bobNormalSignAndVerifyDefaultKey = do resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+ withPassphraseCb "bob123" ctx 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 =+encryptFile :: Assertion+encryptFile = withCtx "test/bob/" "C" OpenPGP $ \ctx -> do withPassphraseCb "bob123" ctx withTestTmpFiles $ \pp ph cp ch dp dh -> do@@ -212,14 +226,12 @@ cipherFd <- handleToFd ch decryptedFd <- handleToFd dh - key <- getKey ctx bob_pub_fpr NoSecret+ key <- getKey ctx bobPubFpr NoSecret - -- Add plaintext content writeFile pp "Plaintext contents. 1234go!" - -- Encrypt plaintext- resEnc <- encryptFd ctx [(fromJust key)] NoFlag plainFd cipherFd- if (resEnc == Right ())+ resEnc <- encryptFd ctx [fromJust key] NoFlag plainFd cipherFd+ if resEnc == Right () then return () else assertFailure $ show resEnc @@ -227,20 +239,18 @@ cipherHandle' <- openFile cp ReadWriteMode cipherFd' <- handleToFd cipherHandle' - -- Decrypt ciphertext resDec <- decryptFd ctx cipherFd' decryptedFd- if (resDec == Right ())+ 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 =+encryptStream :: Assertion+encryptStream = withCtx "test/bob/" "C" OpenPGP $ \ctx -> do withPassphraseCb "bob123" ctx withTestTmpFiles $ \_ _ cp ch dp dh -> do@@ -248,42 +258,33 @@ cipherFd <- handleToFd ch decryptedFd <- handleToFd dh - -- Use bob's key- key <- getKey ctx bob_pub_fpr NoSecret+ key <- getKey ctx bobPubFpr NoSecret - -- Create pipe (pipeRead, pipeWrite) <- createPipe - -- Write to pipe- -- Add plaintext content- let testString = take (1000) $ repeat '.'+ let testString = replicate 1000 '.' _ <- forkIO $ do threadWaitWrite pipeWrite _ <- fdWrite pipeWrite testString closeFd pipeWrite - -- Start encrypting in thread _ <- forkIO $ do threadWaitRead pipeRead- _ <- encryptFd ctx [(fromJust key)] NoFlag pipeRead cipherFd+ _ <- encryptFd ctx [fromJust key] NoFlag pipeRead cipherFd closeFd pipeRead - -- Wait a second for threads to finish- threadDelay (1000 * 1000 * 1)+ threadDelay (1000 * 1000) - -- 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 ())+ if resDec == Right () then return () else assertFailure $ show resDec - -- Compare plaintext and decrypted text decryptedtext <-readFile dp testString @=? decryptedtext @@ -302,8 +303,8 @@ -- 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 (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@@ -311,8 +312,8 @@ -- 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 (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
test/CtxTest.hs view
@@ -6,7 +6,7 @@ import qualified Data.ByteString as BS import Data.Maybe (fromMaybe) import Control.Exception (catch, fromException)-import System.IO.Error (IOError, isUserError)+import System.IO.Error (isUserError) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase)@@ -16,67 +16,67 @@ 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 "no_set_listing_mode" no_set_listing_mode- , testCase "set_listing_mode" set_listing_mode- , testCase "exception_safe" exception_safe+tests = [ testCase "runActionWithCtx" runActionWithCtx+ , testCase "setArmor" setArmor'+ , testCase "unsetArmor" unsetArmor+ , testCase "noSetListingMode" noSetListingMode+ , testCase "setListingMode" setListingMode+ , testCase "exceptionSafe" exceptionSafe ] -run_action_with_ctx :: Assertion-run_action_with_ctx = do+runActionWithCtx :: Assertion+runActionWithCtx = do res <- withCtx "test/alice" "C" OpenPGP $ \_ -> return "foo" :: IO BS.ByteString res @?= "foo" -set_armor :: Assertion-set_armor = do+setArmor' :: Assertion+setArmor' = do let armorPrefix = "-----BEGIN PGP MESSAGE-----" enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr 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+unsetArmor :: Assertion+unsetArmor = do let armorPrefix = "-----BEGIN PGP MESSAGE-----" enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret lift $ setArmor False bCtx lift $ encrypt bCtx [aPubKey] NoFlag "plaintext"- (not $ armorPrefix `BS.isPrefixOf` fromJustAndRight enc) @? ("Binary must not start with " ++ show armorPrefix)+ not (armorPrefix `BS.isPrefixOf` fromJustAndRight enc) @? ("Binary must not start with " ++ show armorPrefix) -no_set_listing_mode :: Assertion-no_set_listing_mode = do+noSetListingMode :: Assertion+noSetListingMode = do sigs <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret kuids <- lift $ keyUserIds' aPubKey return $ concatMap keyuserSignatures kuids let sigs' = fromMaybe [] sigs- (length sigs' == 0) @? ("There should be no signatures, but there are some")+ null sigs' @? "There should be no signatures, but there are some" -set_listing_mode :: Assertion-set_listing_mode = do+setListingMode :: Assertion+setListingMode = do sigs <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do lift $ setKeyListingMode [KeyListingLocal, KeyListingSigs] bCtx- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret kuids <- lift $ keyUserIds' aPubKey return $ concatMap keyuserSignatures kuids let sigs' = fromMaybe [] sigs- (length sigs' > 0) @? ("There should be some signatures, but there are non")+ not (null sigs') @? "There should be some signatures, but there are non" -- 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+exceptionSafe :: Assertion+exceptionSafe = catch ( do res <- withCtx "test/alice" "C" OpenPGP $ \_ ->- (ioError $ userError "Busted") >>+ ioError (userError "Busted") >> return "foo" :: IO BS.ByteString res @?= "foo") ( \(HgpgmeException e) -> do- let mioe = (fromException e) :: Maybe IOError+ let mioe = fromException e :: Maybe IOError maybe (assertFailure $ show mioe) (\ioe -> isUserError ioe @?= True) mioe )
+ test/InternalTest.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+module InternalTest (tests) where++import Bindings.Gpgme+import Foreign+import Foreign.C.String (newCString)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit++import Crypto.Gpgme+import Crypto.Gpgme.Internal++tests :: [TestTree]+tests =+ [ testCase "collectSignaturesWithoutVerify" collectSignaturesWithoutVerify+ , testCase "collectFprsWalksList" collectFprsWalksList+ , testCase "verifyGarbageDoesNotCrash" verifyGarbageDoesNotCrash+ ]++-- gpgme_op_verify_result returns NULL when no successful verify ran on the+-- context, which used to segfault (stackoverflow.com/questions/48908274)+collectSignaturesWithoutVerify :: Assertion+collectSignaturesWithoutVerify = do+ _ <- c'gpgme_check_version nullPtr+ ctxPtr <- malloc+ checkError "gpgme_new" =<< c'gpgme_new ctxPtr+ ctx <- peek ctxPtr+ sigs <- collectSignatures' ctx+ c'gpgme_release ctx+ free ctxPtr+ assertEqual "expected no signatures" [] sigs++-- collectFprs used to diverge on any non-empty list because peeking a+-- whole C'_gpgme_invalid_key recurses via its mistyped next field+collectFprsWalksList :: Assertion+collectFprsWalksList = do+ second <- newInvalidKey "BBBB" 2 nullPtr+ first <- newInvalidKey "AAAA" 1 second+ assertEqual "expected both invalid keys" [("AAAA", 1), ("BBBB", 2)] (collectFprs first)+ where+ newInvalidKey fpr reason next = do+ ptr <- mallocBytes (sizeOf (undefined :: C'_gpgme_invalid_key))+ poke (castPtr (p'_gpgme_invalid_key'next ptr)) next+ poke (p'_gpgme_invalid_key'fpr ptr) =<< newCString fpr+ poke (p'_gpgme_invalid_key'reason ptr) reason+ return ptr++verifyGarbageDoesNotCrash :: Assertion+verifyGarbageDoesNotCrash = do+ res <- verify' "test/bob" "this is not a signature"+ case res of+ Left _ -> return ()+ Right r -> assertFailure ("expected verification error, got: " ++ show r)
test/KeyGenTest.hs view
@@ -18,6 +18,7 @@ import Data.Time.Clock import Data.Default import Data.List ( isPrefixOf )+import Data.Maybe ( fromJust ) import Data.ByteString.Char8 ( unpack ) import Crypto.Gpgme@@ -25,15 +26,15 @@ 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+tests = [ testCase "allGenKeyParameters" allGenKeyParameters+ , testCase "expireDateDays" expireDateDays+ , testCase "expireDateWeeks" expireDateWeeks+ , testCase "expireDateMonths" expireDateMonths+ , testCase "expireDateYears" expireDateYears+ , testCase "expireDateSeconds" expireDateSeconds+ , testCase "creationDateSeconds" creationDateSeconds+ , testCase "genKey" genKey+ , testCase "progressCallback" progressCallback ] -- For getting values from Either@@ -42,8 +43,8 @@ errorOnLeft (Left s) = error s -- Test parameter list generation for generating keys-all_gen_key_parameters :: Assertion-all_gen_key_parameters =+allGenKeyParameters :: Assertion+allGenKeyParameters = let params = (def :: G.GenKeyParams) -- G.defaultGenKeyParams { G.keyType = Just Dsa , G.keyLength = Just $ errorOnLeft $ G.bitSize 1024@@ -67,7 +68,7 @@ , G.keyserver = "https://keyserver.com/" , G.handle = "Key handle here" }- in (G.toParamsString params) @?=+ in G.toParamsString params @?= "<GnupgKeyParms format=\"internal\">\n\ \Key-Type: DSA\n\ \Key-Length: 1024\n\@@ -87,9 +88,9 @@ \Handle: Key handle here\n\ \</GnupgKeyParms>\n" -gen_key :: Assertion-gen_key = do- tmpDir <- createTemporaryTestDir "gen_key"+genKey :: Assertion+genKey = do+ tmpDir <- createTemporaryTestDir "genKey" ret <- withCtx tmpDir "C" OpenPGP $ \ctx -> do let params = (def :: G.GenKeyParams)@@ -109,87 +110,87 @@ -- Cleanup temporary directory removeDirectoryRecursive tmpDir either- (\(l) -> assertFailure $ "Left was return value " ++ (show l))- (\(r) -> assertBool ("Fingerprint ("- ++ (unpack r)+ (\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+expireDateDays :: Assertion+expireDateDays =+ let p = fromJust $ G.toPositive 10 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireD p }- in (G.toParamsString params) @?=+ 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+expireDateWeeks :: Assertion+expireDateWeeks =+ let p = fromJust $ G.toPositive 10 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireW p }- in (G.toParamsString params) @?=+ 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+expireDateMonths :: Assertion+expireDateMonths =+ let p = fromJust $ G.toPositive 10 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireM p }- in (G.toParamsString params) @?=+ 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+expireDateYears :: Assertion+expireDateYears =+ let p = fromJust $ G.toPositive 10 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireY p }- in (G.toParamsString params) @?=+ 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+expireDateSeconds :: Assertion+expireDateSeconds =+ let p = fromJust $ G.toPositive 123456 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireS p }- in (G.toParamsString params) @?=+ 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+creationDateSeconds :: Assertion+creationDateSeconds =+ let p = fromJust $ G.toPositive 123456 params = (def :: G.GenKeyParams) { G.creationDate = Just $ G.CreationS p }- in (G.toParamsString params) @?=+ 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+progressCallback :: Assertion+progressCallback = do tmpDir <- createTemporaryTestDir "progress_callback" -- Setup context@@ -220,9 +221,9 @@ -- 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")+ not (null (lines contents)) @? "No lines in progress file") -- Cleanup test removeDirectoryRecursive tmpDir- assertBool ("Left was return value: " ++ show ret) (either (\_ -> False) (\_ -> True) genRet)- return $ ret+ assertBool ("Left was return value: " ++ show ret) (either (const False) (const True) genRet)+ return ret
test/KeyTest.hs view
@@ -1,47 +1,61 @@ {-# LANGUAGE OverloadedStrings #-}-module KeyTest (tests) where+module KeyTest (tests, cbTests) where +import qualified Data.ByteString as BS import Data.Maybe-import Data.List-import Test.Tasty (TestTree)+import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Test.HUnit import System.FilePath ((</>))-import System.Directory ( removeDirectoryRecursive- , createDirectory- , listDirectory- , copyFile- )+import System.Directory (removeDirectoryRecursive) 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+tests = [ testCase "getAlicePubFromAlice" getAlicePubFromAlice+ , testCase "getBobPubFromAlice" getBobPubFromAlice+ , testCase "aliceListPubKeys" aliceListPubKeys+ , testCase "aliceListSecretKeys" aliceListSecretKeys+ , testCase "aliceSearchPubKeys" aliceSearchPubKeys+ , testCase "getInexistentFromAlice" getInexistentPubFromAlice+ , testCase "checkAlicePubUserIds" checkAlicePubUserIds+ , testCase "checkAlicePubSubkeys" checkAlicePubSubkeys+ , testCase "removeAliceKey" removeAliceKey+ , testCase "readFromFileWorks" readFromFileWorks+ , testCase "readFromFileDoesn'tExist" readFromFileDoesn'tExist+ , testCase "readFromBytesWorks" readFromBytesWorks+ , testCase "exportAlicePubArmored" exportAlicePubArmored+ , testCase "exportImportRoundtrip" exportImportRoundtrip+ , testCase "exportInexistentIsEmpty" exportInexistentIsEmpty+ , testCase "exportAllKeys" exportAllKeys+ , testCase "exportMinimal" exportMinimal ] -get_alice_pub_from_alice :: Assertion-get_alice_pub_from_alice = do+cbTests :: IO TestTree+cbTests = do+ supported <- withCtx "test/alice" "C" OpenPGP $ \ctx ->+ return $ isPassphraseCbSupported ctx+ if supported+ then return $ testGroup "key-passphrase-cb"+ [ testCase "exportAliceSecretArmored" exportAliceSecretArmored ]+ else return $ testGroup "key-passphrase-cb" []++getAlicePubFromAlice :: Assertion+getAlicePubFromAlice = do withCtx "test/alice" "C" OpenPGP $ \ctx ->- do key <- getKey ctx alice_pub_fpr NoSecret- isJust key @? "missing " ++ show alice_pub_fpr+ do key <- getKey ctx alicePubFpr NoSecret+ isJust key @? "missing " ++ show alicePubFpr -get_bob_pub_from_alice :: Assertion-get_bob_pub_from_alice = do+getBobPubFromAlice :: Assertion+getBobPubFromAlice = do withCtx "test/alice/" "C" OpenPGP $ \ctx ->- do key <- getKey ctx bob_pub_fpr NoSecret- isJust key @? "missing " ++ show bob_pub_fpr+ do key <- getKey ctx bobPubFpr NoSecret+ isJust key @? "missing " ++ show bobPubFpr -alice_list_pub_keys :: Assertion-alice_list_pub_keys = do+aliceListPubKeys :: Assertion+aliceListPubKeys = do withCtx "test/alice" "C" OpenPGP $ \ctx -> do keys <- listKeys ctx NoSecret length keys @?= 2@@ -49,68 +63,146 @@ ["6B9809775CF91391","3BA69AA2EAACEB8A"]] map (map subkeyKeyId . keySubKeys) keys @?= keyIds -alice_list_secret_keys :: Assertion-alice_list_secret_keys = do+aliceListSecretKeys :: Assertion+aliceListSecretKeys = 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"+aliceSearchPubKeys :: Assertion+aliceSearchPubKeys = do+ withCtx "test/alice" "C" OpenPGP $ \ctx ->+ do keys <- searchKeys ctx NoSecret "alice@email.com"+ length keys @?= 1+ let keyIds = [["6B9809775CF91391","3BA69AA2EAACEB8A"]]+ map (map subkeyKeyId . keySubKeys) keys @?= keyIds++getInexistentPubFromAlice :: Assertion+getInexistentPubFromAlice = do+ let inexistentFpr = "ABCDEF" withCtx "test/alice/" "C" OpenPGP $ \ctx ->- do key <- getKey ctx inexistent_fpr NoSecret- isNothing key @? "existing " ++ show inexistent_fpr+ do key <- getKey ctx inexistentFpr NoSecret+ isNothing key @? "existing " ++ show inexistentFpr -check_alice_pub_user_ids :: Assertion-check_alice_pub_user_ids = do+checkAlicePubUserIds :: Assertion+checkAlicePubUserIds = 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"+ do Just key <- getKey ctx alicePubFpr NoSecret+ case keyUserIds key of+ [kuid] -> do+ let 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"+ uids -> assertFailure $+ "expected exactly one user id, got " ++ show (length uids) -check_alice_pub_subkeys :: Assertion-check_alice_pub_subkeys = do+checkAlicePubSubkeys :: Assertion+checkAlicePubSubkeys = 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"+ do Just key <- getKey ctx alicePubFpr NoSecret+ case keySubKeys key of+ [sub, _] -> do+ subkeyAlgorithm sub @?= Rsa+ subkeyLength sub @?= 2048+ subkeyKeyId sub @?= "6B9809775CF91391"+ subkeyFpr sub @?= "3F10159E56ECB494ED42EFA36B9809775CF91391"+ subs -> assertFailure $+ "expected exactly two subkeys, got " ++ show (length subs) -remove_alice_key :: Assertion-remove_alice_key = do- tmpDir <- createTemporaryTestDir "remove_alice_key"+removeAliceKey :: Assertion+removeAliceKey = do+ tmpDir <- createTemporaryTestDir "removeAliceKey" - -- 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+ let aliceTmpDir = tmpDir </> "alice"+ copyGpgHomedir "test/alice" aliceTmpDir - 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+ withCtx aliceTmpDir "C" OpenPGP $ \ctx ->+ do key <- getKey ctx alicePubFpr WithSecret+ startNum <- listKeys ctx WithSecret >>= \l -> return $ length l+ startNum @?= 1+ ret <- removeKey ctx (fromJust key) (RemoveKeyFlags True True)+ endNum <- listKeys ctx WithSecret >>= \l -> return $ length l+ endNum @?= 0 ret @?= Nothing - -- Cleanup test removeDirectoryRecursive tmpDir++readFromFileWorks :: Assertion+readFromFileWorks = do+ withCtx "test/real-person" "C" OpenPGP $ \ctx -> do+ mRet <- importKeyFromFile ctx "test/real-person/real-person.key"+ mRet @?= Nothing++readFromFileDoesn'tExist :: Assertion+readFromFileDoesn'tExist = do+ withCtx "test/real-person" "C" OpenPGP $ \ctx -> do+ mRet <- importKeyFromFile ctx "this-file-doesn't-exist"+ isJust mRet @? "shouldn't be able to read this file"++exportAlicePubArmored :: Assertion+exportAlicePubArmored =+ withCtx "test/alice" "C" OpenPGP $ \ctx -> do+ setArmor True ctx+ key <- fromRight <$> exportKey ctx alicePubFpr+ ("-----BEGIN PGP PUBLIC KEY BLOCK-----" `BS.isPrefixOf` key)+ @? "exported key must be armored"++exportImportRoundtrip :: Assertion+exportImportRoundtrip = do+ key <- withCtx "test/alice" "C" OpenPGP $ \ctx ->+ fromRight <$> exportKey ctx alicePubFpr+ tmpDir <- createTemporaryTestDir "exportImportRoundtrip"+ withCtx tmpDir "C" OpenPGP $ \ctx -> do+ mErr <- importKeyFromBytes ctx key+ mErr @?= Nothing+ imported <- getKey ctx alicePubFpr NoSecret+ isJust imported @? "imported key should be present"+ removeDirectoryRecursive tmpDir++exportInexistentIsEmpty :: Assertion+exportInexistentIsEmpty =+ withCtx "test/alice" "C" OpenPGP $ \ctx -> do+ key <- fromRight <$> exportKey ctx "ABCDEF"+ key @?= BS.empty++exportAllKeys :: Assertion+exportAllKeys =+ withCtx "test/alice" "C" OpenPGP $ \ctx -> do+ single <- fromRight <$> exportKeys ctx [] [alicePubFpr]+ all' <- fromRight <$> exportKeys ctx [] []+ (BS.length all' > BS.length single)+ @? "exporting all keys must yield more than a single key"++exportMinimal :: Assertion+exportMinimal =+ withCtx "test/bob" "C" OpenPGP $ \ctx -> do+ full <- fromRight <$> exportKeys ctx [] [alicePubFpr]+ minimal <- fromRight <$> exportKeys ctx [ExportMinimal] [alicePubFpr]+ not (BS.null minimal) @? "minimal export must not be empty"+ (BS.length minimal <= BS.length full)+ @? "minimal export must not be larger than the full export"++exportAliceSecretArmored :: Assertion+exportAliceSecretArmored =+ withCtx "test/alice" "C" OpenPGP $ \ctx -> do+ setPassphraseCallback ctx (Just (\_ _ _ -> return (Just "alice123")))+ setArmor True ctx+ key <- fromRight <$> exportSecretKey ctx alicePubFpr+ ("-----BEGIN PGP PRIVATE KEY BLOCK-----" `BS.isPrefixOf` key)+ @? "exported secret key must be armored"++readFromBytesWorks :: Assertion+readFromBytesWorks = do+ key <- BS.readFile "test/real-person/real-person.key"+ tmpDir <- createTemporaryTestDir "readFromBytesWorks"+ withCtx tmpDir "C" OpenPGP $ \ctx -> do+ before <- getKey ctx realPersonPubFpr NoSecret+ isNothing before @? "key shouldn't be present before import"+ mRet <- importKeyFromBytes ctx key+ mRet @?= Nothing+ after <- getKey ctx realPersonPubFpr NoSecret+ isJust after @? "key should be present after import"+ removeDirectoryRecursive tmpDir
test/Main.hs view
@@ -6,14 +6,17 @@ import KeyGenTest import CtxTest import CryptoTest+import InternalTest main :: IO () main = do- passphraseCbTests <- CryptoTest.cbTests+ keyCbTests <- KeyTest.cbTests+ cryptoTests <- CryptoTest.tests defaultMain $ testGroup "tests"- [ testGroup "key" KeyTest.tests+ [ testGroup "internal" InternalTest.tests+ , testGroup "key" KeyTest.tests+ , keyCbTests , testGroup "keyGen" KeyGenTest.tests , testGroup "ctx" CtxTest.tests- , CryptoTest.tests- , passphraseCbTests+ , cryptoTests ]
test/TestUtil.hs view
@@ -3,29 +3,47 @@ module TestUtil where import qualified Data.ByteString as BS-import Data.Maybe (fromJust)+import Control.Monad (forM_, when)+import Data.Maybe (fromJust, fromMaybe) import Test.QuickCheck import System.FilePath ((</>)) import System.Directory ( getTemporaryDirectory , createDirectoryIfMissing , removeDirectoryRecursive , doesDirectoryExist+ , listDirectory+ , copyFile )+import System.Posix.Files ( getFileStatus+ , isDirectory+ , isRegularFile+ , setFileMode+ ) -alice_pub_fpr :: BS.ByteString-alice_pub_fpr = "EAACEB8A"+alicePubFpr :: BS.ByteString+alicePubFpr = "EAACEB8A" -bob_pub_fpr :: BS.ByteString-bob_pub_fpr = "6C4FB8F2"+bobPubFpr :: BS.ByteString+bobPubFpr = "6C4FB8F2" +-- | Alice and Bob protect their secret keys with a passphrase, which can only+-- be supplied through a 'Ctx'. Carol's secret key is unprotected, so she is the+-- one to use for the @encrypt'@ \/ @decrypt'@ shorthands, which build their own+-- context and therefore cannot be given a passphrase callback.+carolPubFpr :: BS.ByteString+carolPubFpr = "D66FC19F59A5C554"++realPersonPubFpr :: BS.ByteString+realPersonPubFpr = "2DA4C89E28F515B4"+ -- 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+justAndRight = either (const False) (const True) . fromMaybe (Left undefined) fromJustAndRight :: (Show a) => Maybe (Either a b) -> b fromJustAndRight = fromRight . fromJust@@ -41,14 +59,31 @@ isLeft (Right _) = False isLeft (Left _) = True +-- | Copy a gpg homedir, secret keys and all, so that a test can modify it+-- without touching the fixture.+copyGpgHomedir :: FilePath -> FilePath -> IO ()+copyGpgHomedir src dst = do+ createDirectoryIfMissing True dst+ -- gpg refuses to use a homedir that others can read+ setFileMode dst 0o700+ entries <- listDirectory src+ forM_ entries $ \entry -> do+ let from = src </> entry+ to = dst </> entry+ status <- getFileStatus from+ if isDirectory status+ then copyGpgHomedir from to+ -- Where GnuPG has no /run/user to fall back on (macOS, some+ -- containers) it puts its agent sockets straight into the homedir.+ -- Those are not part of the fixture, and cannot be copied anyway.+ else when (isRegularFile status) $ copyFile from to+ 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 ()+ tmpCheck <- doesDirectoryExist tmpDir+ when tmpCheck $ removeDirectoryRecursive tmpDir -- Create temporary directory createDirectoryIfMissing True tmpDir return tmpDir