diff --git a/.gitignore b/.gitignore deleted file mode 100644 --- a/.gitignore +++ /dev/null @@ -1,18 +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 -h-gpgme-*.tar.gz -src/*.js -src/*.css -.idea -h-gpgme.iml -dist-newstyle/ -dist-docs.*/ diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown deleted file mode 100644 --- a/CHANGELOG.markdown +++ /dev/null @@ -1,92 +0,0 @@ -# Changelog - -## 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/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) 2022 Reto +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,26 +0,0 @@ -[![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 -======================================================== - -## 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,44 +1,36 @@ -Name: h-gpgme -Version: 0.6.3.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 -Maintainer: rethab@protonmail.com -Copyright: (c) Reto 2022 -Homepage: https://github.com/rethab/h-gpgme -Bug-reports: https://github.com/rethab/h-gpgme/issues -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 -Category: Cryptography -Build-Type: Simple -Cabal-Version: >=1.10 -Extra-Source-Files: - CHANGELOG.markdown - README.markdown - .gitignore - +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 -library - hs-source-dirs: src +common warnings ghc-options: -Wall - -fno-warn-orphans - exposed-modules: Crypto.Gpgme - , Crypto.Gpgme.Key.Gen - other-modules: Crypto.Gpgme.Key - , Crypto.Gpgme.Ctx - , Crypto.Gpgme.Crypto - , Crypto.Gpgme.Internal - , Crypto.Gpgme.Types + default-language: Haskell2010 + +common deps build-depends: base >= 4.14 && <5 , bindings-gpgme >= 0.1.8 && <0.3 , bytestring >= 0.10 && <0.13 @@ -47,23 +39,29 @@ , unix >= 2.5 && <2.9 , email-validate >= 2.0 && <2.4 , data-default >= 0.5 && <0.9 - default-language: Haskell2010 +library + import: warnings, deps + hs-source-dirs: src + ghc-options: -fno-warn-orphans + exposed-modules: Crypto.Gpgme + , Crypto.Gpgme.Key.Gen + other-modules: Crypto.Gpgme.Key + , Crypto.Gpgme.Ctx + , Crypto.Gpgme.Crypto + , Crypto.Gpgme.Internal + , Crypto.Gpgme.Types + 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.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 - , directory >= 1.2 && <2 + + -- 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 @@ -82,6 +80,7 @@ , Crypto.Gpgme.Types , CryptoTest , CtxTest + , InternalTest , KeyTest , KeyGenTest , TestUtil 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 @@ -442,10 +442,10 @@ -- 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 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 @@ -31,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 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 @@ -13,13 +13,19 @@ 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. @@ -60,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 diff --git a/test/CryptoTest.hs b/test/CryptoTest.hs --- a/test/CryptoTest.hs +++ b/test/CryptoTest.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module CryptoTest (tests, cbTests) where +module CryptoTest (tests) where import System.IO import System.IO.Temp @@ -23,43 +23,50 @@ import Crypto.Gpgme.Types ( GpgmeError (GpgmeError) ) import TestUtil -tests :: TestTree -tests = testGroup "crypto" - [ testProperty "bobEncryptForAliceDecryptPromptNoCi" - $ bobEncryptForAliceDecrypt False - , testProperty "bobEncryptSignForAliceDecryptVerifyPromptNoCi" - $ bobEncryptSignForAliceDecryptVerify 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 "bobEncryptForAliceDecryptShortPromptNoCi" - bobEncryptForAliceDecryptShort - , testProperty "bobEncryptSignForAliceDecryptVerifyShortPromptNoCi" - bobEncryptSignForAliceDecryptVerifyShort + , testCase "decryptGarbage" decryptGarbage + , testCase "encryptWrongKey" encryptWrongKey - , testCase "decryptGarbage" decryptGarbage - , testCase "encryptWrongKey" encryptWrongKey - , testCase "bobEncryptSymmetricallyPromptNoCi" bobEncryptSymmetrically - , testCase "bobDetachSignAndVerifySpecifyKeyPromptNoCi" bobDetachSignAndVerifySpecifyKeyPrompt - , testCase "bobClearSignAndVerifySpecifyKeyPromptNoCi" bobClearSignAndVerifySpecifyKeyPrompt - , testCase "bobClearSignAndVerifyDefaultKeyPromptNoCi" bobClearSignAndVerifyDefaultKeyPrompt - , testCase "bobNormalSignAndVerifySpecifyKeyPromptNoCi" bobNormalSignAndVerifySpecifyKeyPrompt - , testCase "bobNormalSignAndVerifyDefaultKeyPromptNoCi" bobNormalSignAndVerifyDefaultKeyPrompt - , testCase "encryptFileNoCi" encryptFile - , testCase "encryptStreamNoCi" encryptStream - ] + , 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 "bobEncryptForAliceDecrypt" - $ bobEncryptForAliceDecrypt True - , testProperty "bobEncryptSignForAliceDecryptVerifyWithPassphraseCbPromptNoCi" - $ bobEncryptSignForAliceDecryptVerify 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 . fmap (either (const Nothing) Just) @@ -75,29 +82,27 @@ dec <- run encrAndDecr assert $ dec == plain where encrAndDecr = - do -- encrypt + do Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do 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 -bobEncryptForAliceDecryptShort :: Plain -> Property -bobEncryptForAliceDecryptShort plain = +carolEncryptForCarolDecryptShort :: Plain -> Property +carolEncryptForCarolDecryptShort plain = not (BS.null plain) ==> monadicIO $ do dec <- run encrAndDecr assert $ dec == plain where encrAndDecr = - do -- encrypt - enc <- encrypt' "test/bob" alicePubFpr plain + do + enc <- encrypt' "test/carol" carolPubFpr plain - -- decrypt - dec <- decrypt' "test/alice" (fromRight enc) + dec <- decrypt' "test/carol" (fromRight enc) return $ fromRight dec @@ -107,29 +112,31 @@ dec <- run encrAndDecr assert $ dec == plain where encrAndDecr = - do -- encrypt - Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do - aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret - hush $ encryptSign bCtx [aPubKey] NoFlag plain + 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 -bobEncryptSignForAliceDecryptVerifyShort :: Plain -> Property -bobEncryptSignForAliceDecryptVerifyShort plain = +carolEncryptSignForCarolDecryptVerifyShort :: Plain -> Property +carolEncryptSignForCarolDecryptVerifyShort plain = not (BS.null plain) ==> monadicIO $ do dec <- run encrAndDecr assert $ dec == plain where encrAndDecr = - do -- encrypt - enc <- encryptSign' "test/bob" alicePubFpr plain + do + enc <- encryptSign' "test/carol" carolPubFpr plain - -- decrypt - dec <- decryptVerify' "test/alice" (fromRight enc) + dec <- decryptVerify' "test/carol" (fromRight enc) return $ fromRight dec @@ -149,54 +156,63 @@ 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" -bobDetachSignAndVerifySpecifyKeyPrompt :: Assertion -bobDetachSignAndVerifySpecifyKeyPrompt = do +bobDetachSignAndVerifySpecifyKey :: Assertion +bobDetachSignAndVerifySpecifyKey = do resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do + withPassphraseCb "bob123" ctx key <- getKey ctx bobPubFpr NoSecret let msgToSign = "Clear text message from bob!!" resSign <-sign ctx [fromJust key] Detach msgToSign verifyDetached ctx (fromRight resSign) msgToSign assertBool "Could not verify bob's signature was correct" $ isVerifyDetachValid resVerify -bobClearSignAndVerifySpecifyKeyPrompt :: Assertion -bobClearSignAndVerifySpecifyKeyPrompt = do +bobClearSignAndVerifySpecifyKey :: Assertion +bobClearSignAndVerifySpecifyKey = do resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do + 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 -bobClearSignAndVerifyDefaultKeyPrompt :: Assertion -bobClearSignAndVerifyDefaultKeyPrompt = 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" verify ctx (fromRight resSign) assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify -bobNormalSignAndVerifySpecifyKeyPrompt :: Assertion -bobNormalSignAndVerifySpecifyKeyPrompt = do +bobNormalSignAndVerifySpecifyKey :: Assertion +bobNormalSignAndVerifySpecifyKey = do resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do + 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 -bobNormalSignAndVerifyDefaultKeyPrompt :: Assertion -bobNormalSignAndVerifyDefaultKeyPrompt = 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 @@ -212,10 +228,8 @@ 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 () then return () @@ -225,13 +239,11 @@ cipherHandle' <- openFile cp ReadWriteMode cipherFd' <- handleToFd cipherHandle' - -- Decrypt ciphertext resDec <- decryptFd ctx cipherFd' decryptedFd if resDec == Right () then return () else assertFailure $ show resDec - -- Compare plaintext and decrypted text plaintext <- readFile pp decryptedtext <- readFile dp plaintext @=? decryptedtext @@ -246,42 +258,33 @@ cipherFd <- handleToFd ch decryptedFd <- handleToFd dh - -- Use bob's key key <- getKey ctx bobPubFpr NoSecret - -- Create pipe (pipeRead, pipeWrite) <- createPipe - -- Write to pipe - -- Add plaintext content 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 closeFd pipeRead - -- Wait a second for threads to finish 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 () then return () else assertFailure $ show resDec - -- Compare plaintext and decrypted text decryptedtext <-readFile dp testString @=? decryptedtext 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 @@ -33,8 +33,8 @@ , testCase "expireDateYears" expireDateYears , testCase "expireDateSeconds" expireDateSeconds , testCase "creationDateSeconds" creationDateSeconds - , testCase "genKeyNoCi" genKey - , testCase "progressCallbackNoCi" progressCallback + , testCase "genKey" genKey + , testCase "progressCallback" progressCallback ] -- For getting values from Either diff --git a/test/KeyTest.hs b/test/KeyTest.hs --- a/test/KeyTest.hs +++ b/test/KeyTest.hs @@ -7,14 +7,8 @@ import Test.Tasty.HUnit (testCase) import Test.HUnit -import Control.Monad (filterM) import System.FilePath (()) -import System.Directory ( removeDirectoryRecursive - , createDirectory - , listDirectory - , copyFile - ) -import System.Posix.Files (getFileStatus, isRegularFile) +import System.Directory (removeDirectoryRecursive) import Crypto.Gpgme import TestUtil @@ -122,20 +116,10 @@ removeAliceKey = do tmpDir <- createTemporaryTestDir "removeAliceKey" - -- Copy alice's key into temporary directory so we can safely remove it let aliceTmpDir = tmpDir "alice" - createDirectory aliceTmpDir - -- Where GnuPG has no /run/user to fall back on (macOS, some containers) it - -- puts its agent sockets straight into the homedir, so skip anything that is - -- not a regular file rather than listing socket names one by one. - aliceFiles <- listDirectory "test/alice" - >>= filterM (fmap isRegularFile . getFileStatus . ("test/alice" )) - mapM_ (\f -> copyFile ("test/alice" f) (tmpDir "alice" f)) - $ filter (\f -> f /= ".gpg-v21-migrated" - && f /= "randomSeed" - ) aliceFiles + copyGpgHomedir "test/alice" aliceTmpDir - withCtx (tmpDir "alice") "C" OpenPGP $ \ctx -> + withCtx aliceTmpDir "C" OpenPGP $ \ctx -> do key <- getKey ctx alicePubFpr WithSecret startNum <- listKeys ctx WithSecret >>= \l -> return $ length l startNum @?= 1 @@ -144,7 +128,6 @@ endNum @?= 0 ret @?= Nothing - -- Cleanup test removeDirectoryRecursive tmpDir readFromFileWorks :: Assertion diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,16 +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,7 +3,7 @@ module TestUtil where import qualified Data.ByteString as BS -import Control.Monad (when) +import Control.Monad (forM_, when) import Data.Maybe (fromJust, fromMaybe) import Test.QuickCheck import System.FilePath (()) @@ -11,7 +11,14 @@ , createDirectoryIfMissing , removeDirectoryRecursive , doesDirectoryExist + , listDirectory + , copyFile ) +import System.Posix.Files ( getFileStatus + , isDirectory + , isRegularFile + , setFileMode + ) alicePubFpr :: BS.ByteString @@ -20,6 +27,13 @@ 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" @@ -44,6 +58,25 @@ isLeft :: Either a b -> Bool 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