diff --git a/.gitignore b/.gitignore deleted file mode 100644 --- a/.gitignore +++ /dev/null @@ -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 diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -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} diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown deleted file mode 100644 --- a/CHANGELOG.markdown +++ /dev/null @@ -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) diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.markdown b/README.markdown deleted file mode 100644 --- a/README.markdown +++ /dev/null @@ -1,23 +0,0 @@ -[![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) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,100 @@ +[![Hackage](https://img.shields.io/hackage/v/h-gpgme.svg)](https://hackage.haskell.org/package/h-gpgme) +[![CI](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml/badge.svg)](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml) +![MIT License](https://img.shields.io/github/license/rethab/h-gpgme?label=license) + +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) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/h-gpgme.cabal b/h-gpgme.cabal --- a/h-gpgme.cabal +++ b/h-gpgme.cabal @@ -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 diff --git a/src/Crypto/Gpgme.hs b/src/Crypto/Gpgme.hs --- a/src/Crypto/Gpgme.hs +++ b/src/Crypto/Gpgme.hs @@ -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 (..) diff --git a/src/Crypto/Gpgme/Crypto.hs b/src/Crypto/Gpgme/Crypto.hs --- a/src/Crypto/Gpgme/Crypto.hs +++ b/src/Crypto/Gpgme/Crypto.hs @@ -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 diff --git a/src/Crypto/Gpgme/Ctx.hs b/src/Crypto/Gpgme/Ctx.hs --- a/src/Crypto/Gpgme/Ctx.hs +++ b/src/Crypto/Gpgme/Ctx.hs @@ -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 diff --git a/src/Crypto/Gpgme/Internal.hs b/src/Crypto/Gpgme/Internal.hs --- a/src/Crypto/Gpgme/Internal.hs +++ b/src/Crypto/Gpgme/Internal.hs @@ -3,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 diff --git a/src/Crypto/Gpgme/Key.hs b/src/Crypto/Gpgme/Key.hs --- a/src/Crypto/Gpgme/Key.hs +++ b/src/Crypto/Gpgme/Key.hs @@ -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 diff --git a/src/Crypto/Gpgme/Key/Gen.hs b/src/Crypto/Gpgme/Key/Gen.hs --- a/src/Crypto/Gpgme/Key/Gen.hs +++ b/src/Crypto/Gpgme/Key/Gen.hs @@ -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 ("" /=)) [ "" - , "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 diff --git a/src/Crypto/Gpgme/Types.hs b/src/Crypto/Gpgme/Types.hs --- a/src/Crypto/Gpgme/Types.hs +++ b/src/Crypto/Gpgme/Types.hs @@ -2,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) diff --git a/test/CryptoTest.hs b/test/CryptoTest.hs --- a/test/CryptoTest.hs +++ b/test/CryptoTest.hs @@ -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 diff --git a/test/CtxTest.hs b/test/CtxTest.hs --- a/test/CtxTest.hs +++ b/test/CtxTest.hs @@ -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 ) diff --git a/test/InternalTest.hs b/test/InternalTest.hs new file mode 100644 --- /dev/null +++ b/test/InternalTest.hs @@ -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) diff --git a/test/KeyGenTest.hs b/test/KeyGenTest.hs --- a/test/KeyGenTest.hs +++ b/test/KeyGenTest.hs @@ -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 @?= "\n\ \Key-Type: DSA\n\ \Key-Length: 1024\n\ @@ -87,9 +88,9 @@ \Handle: Key handle here\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: 10d\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: 10w\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: 10m\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: 10y\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: seconds=123456\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Creation-Date: seconds=123456\n\ \\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 diff --git a/test/KeyTest.hs b/test/KeyTest.hs --- a/test/KeyTest.hs +++ b/test/KeyTest.hs @@ -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) " - 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) " + 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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ] diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -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