h-gpgme 0.6.3.0 → 0.6.3.1
raw patch · 17 files changed
+465/−310 lines, 17 filessetup-changed
Files
- .gitignore +0/−18
- CHANGELOG.markdown +0/−92
- CHANGELOG.md +106/−0
- LICENSE +1/−1
- README.markdown +0/−26
- README.md +100/−0
- Setup.hs +0/−2
- h-gpgme.cabal +47/−48
- src/Crypto/Gpgme/Crypto.hs +4/−4
- src/Crypto/Gpgme/Ctx.hs +8/−3
- src/Crypto/Gpgme/Internal.hs +18/−9
- test/CryptoTest.hs +83/−80
- test/InternalTest.hs +54/−0
- test/KeyGenTest.hs +2/−2
- test/KeyTest.hs +3/−20
- test/Main.hs +5/−4
- test/TestUtil.hs +34/−1
− .gitignore
@@ -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.*/
− CHANGELOG.markdown
@@ -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)
+ CHANGELOG.md view
@@ -0,0 +1,106 @@+# Changelog++## 0.6.3.1++### Bug fixes++- fix: segfault in verify, verifyDetached and verifyPlain when the verify operation fails before gpgme produces a result (e.g. invalid homedir), as gpgme_op_verify_result returns NULL in that case (https://stackoverflow.com/questions/48908274): https://github.com/rethab/h-gpgme/pull/72+- fix: infinite recursion in collectFprs when encrypt or sign reports invalid keys: https://github.com/rethab/h-gpgme/pull/72+- fix: segfault in newCtx when the gpg engine is not installed and its version is NULL: https://github.com/rethab/h-gpgme/pull/72++### Maintenance++- chore: drop the docker-compose test runner, the shell script wrappers and stack.yaml; CI now builds with cabal against the declared bounds, plus a --prefer-oldest job to keep the lower bounds honest: https://github.com/rethab/h-gpgme/pull/71+- chore(test): wire setPassphraseCallback into the tests that unlock a secret key, which unmarks most NoCi tests, and move the alice/bob keyrings to keybox format so gpg stops migrating them on every run: https://github.com/rethab/h-gpgme/pull/71+- docs: document the actual feature surface in the README: https://github.com/rethab/h-gpgme/pull/71++## 0.6.3.0++### New Features++- feat: add importKeyFromBytes function: https://github.com/rethab/h-gpgme/pull/66+- feat: add exportKey, exportSecretKey and exportKeys functions: https://github.com/rethab/h-gpgme/pull/70+- feat: support gpgme 2.x by allowing bindings-gpgme 0.2: https://github.com/rethab/h-gpgme/pull/69++### Bug fixes++- fix: release the gpgme data buffer after import and export operations: https://github.com/rethab/h-gpgme/pull/70+- fix: importKeyFromFile and importKeyFromBytes reported success instead of the actual error when the import operation failed: https://github.com/rethab/h-gpgme/pull/70+- docs: fix reversed doc comments on IncludeSecret: https://github.com/rethab/h-gpgme/pull/68+- fix(test): skip gpg-agent sockets when copying the key fixture, which broke removeAliceKey wherever GnuPG puts its sockets in the homedir: https://github.com/rethab/h-gpgme/pull/69++### Maintenance++- chore(ci): modernize CI with a real multi-GHC matrix, latest actions and hardened permissions: https://github.com/rethab/h-gpgme/pull/67+- chore(ci): release to Hackage from a version tag: https://github.com/rethab/h-gpgme/pull/69+- chore(ci): test against gpgme 1.x and 2.x, both built from source: https://github.com/rethab/h-gpgme/pull/69+- chore: give every dependency a PVP upper bound: https://github.com/rethab/h-gpgme/pull/69++## 0.6.2.0++### New Features++- feat: add searchKeys function: https://github.com/rethab/h-gpgme/pull/52++## 0.6.1.0++### New Features++- feat: performance improvement / copy more than one byte from gpgme_data: https://github.com/rethab/h-gpgme/pull/61++### Maintenance++- chore(ci): Run tests without docker-compose in CI & cross-test with various GHC versions: https://github.com/rethab/h-gpgme/pull/60++## 0.6.0.0++### New Features++- BREAKING: Add force flag to removeKey function: https://github.com/rethab/h-gpgme/pull/57+- Add function to import key from file: https://github.com/rethab/h-gpgme/pull/54 (thanks @chiropical)++### Maintenance++- Migrate to GitHub Actions: https://github.com/rethab/h-gpgme/pull/55, https://github.com/rethab/h-gpgme/pull/58, and https://github.com/rethab/h-gpgme/pull/59++## 0.5.1.0++### New Features++- Add key listing modes (thanks mmhat)++## 0.5.0.0++### New Features++- Add Stack support+- Add key generation functionality+- Add remove key functionality+- Add clear sign functionality+- Add progress callback functionality+- Add file encryption and decryption+- Add safe `collectSignatures'` function++### Bug fixes++- Prevent potential memory leak in `withCtx`+- Return full fingerprint for `keySubKeys`+- Fix crash bug in `verifyInternal` involving a call to `performUnsafeIO`++### Maintenance+- Replace dependency on `either` with `transfers` (thanks hvr)++## 0.4.0.0+- verifyDetached and verifyDetached' Verify a payload using a detached signature. (thanks mmhat)+- verifyPlain and verifyPlain' Verify a payload using a plain signature. (thanks mmhat)++## 0.3.0.0+- Added listKeys (thanks bgamari)+- Replaced withArmor with setArmor+- Removed withKey, manual freeing is no longer required so you can use getKey (thanks bgamari)+- Support for passphrase callbacks (thanks bgamari)+ - Note that the operation of this feature is a bit inconsistent between GPG versions. GPG 1.4 using the use-agent option and GPG >= 2.1 require that the gpg-agent for the session has the allow-loopback-pinentry option enabled (this can be achieved by adding allow-loopback-pinentry to gpg-agent.conf. GPG versions between 2.0 and 2.1 do not support the --pinentry-mode option necessary for this support.+ - See http://lists.gnupg.org/pipermail/gnupg-devel/2013-February/027345.html and the gpgme-tool example included in the gpgme tree for details.++## 0.2.0.0+- Added withArmor for ASCII-armored output (thanks yaccz)
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 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
− README.markdown
@@ -1,26 +0,0 @@-[](https://hackage.haskell.org/package/h-gpgme) -[](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml)----h-gpgme: High Level Haskell Bindings for GnuPG Made Easy-========================================================--## Examples--```haskell-let alice_pub_fpr = "EAACEB8A"---- encrypt-Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret- fromRight $ encrypt bCtx [aPubKey] NoFlag plain---- decrypt-dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx ->- decrypt aCtx enc-```--See the test folder for more examples--[Changelog](CHANGELOG.markdown)
+ README.md view
@@ -0,0 +1,100 @@+[](https://hackage.haskell.org/package/h-gpgme)+[](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml)+++h-gpgme: High Level Haskell Bindings for GnuPG Made Easy+========================================================++h-gpgme wraps [gpgme](https://www.gnupg.org/software/gpgme/), the library GnuPG+offers to programs that want OpenPGP without shelling out to `gpg`. The API+stays close to the C one, but the memory management, error handling and resource+cleanup a C API leaves to the caller become ordinary Haskell values and+`bracket`-style functions.++The crypto itself comes from the GnuPG installation already on the machine: the+same keyrings, the same `gpg-agent`, the same trust database.++## Features++- **Encryption and decryption** — to one or more recipients (`encrypt`,+ `decrypt`), symmetrically when you name no recipient at all, and on file+ descriptors (`encryptFd`, `decryptFd`) for data you would rather not hold in+ memory.+- **Signing and verification** — normal, detached and cleartext signatures+ (`sign` with `SignMode`), verification of attached and detached signatures+ (`verify`, `verifyDetached`), and the combined `encryptSign` / `decryptVerify`.+- **Key lookup** — by fingerprint (`getKey`), across a keyring (`listKeys`), or+ by user id (`searchKeys`), down to the user ids, subkeys, algorithms and+ validity of what comes back.+- **Key import, export and removal** — `importKeyFromFile`,+ `importKeyFromBytes`; `exportKey`, `exportSecretKey` and `exportKeys` with+ `ExportMode`, armored if the context has `setArmor`; `removeKey`.+- **Key generation** — `Crypto.Gpgme.Key.Gen` builds the parameter list gpgme+ expects (key type, length, usage, expiry, passphrase) out of types rather than+ hand-written strings.+- **Callbacks** — answer a passphrase request from your own code instead of a+ pinentry prompt (`setPassphraseCallback`), and follow slow operations with+ `setProgressCallback`.++Every operation runs in a `Ctx`, a gpgme context bound to a GnuPG home+directory. Use `withCtx` and it is freed for you.++## Requirements++The gpgme C library with its headers, and a GnuPG installation:++```sh+apt install libgpgme-dev # Debian, Ubuntu+brew install gpgme # macOS+```++Both the gpgme 1.x and 2.x series work. gpgme 2.x additionally needs+`bindings-gpgme >= 0.2`, since gpgme 2.0 dropped the trust item API that older+bindings referenced.++## Getting started++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Crypto.Gpgme++main :: IO ()+main = do+ let alicePubFpr = "EAACEB8A"++ -- encrypt for alice, out of bob's keyring+ Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> do+ Just aPubKey <- getKey bCtx alicePubFpr NoSecret+ either (const Nothing) Just <$> encrypt bCtx [aPubKey] NoFlag "hello"++ -- decrypt as alice, answering the passphrase request in-process rather than+ -- at a pinentry prompt (needs allow-loopback-pinentry in gpg-agent.conf)+ dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx -> do+ setPassphraseCallback aCtx (Just (\_ _ _ -> return (Just "alice123")))+ decrypt aCtx enc++ print dec+```++`withCtx` takes the home directory, the locale and the protocol. For one-shot+use there are shorthands that build their own context, like+`encrypt' "test/bob" alicePubFpr "hello"`.++The [test suite](test) doubles as the fullest set of examples: it exercises every+operation above against the keyrings in `test/`.++## Documentation++The API docs live on [Hackage](https://hackage.haskell.org/package/h-gpgme).+For what each underlying call really does, the+[gpgme manual](https://www.gnupg.org/documentation/manuals/gpgme.pdf) is the+authority — h-gpgme's names follow it closely.++## Contributing++Issues and pull requests are welcome. `cabal test` runs the suite; tests+marked `NoCi` are skipped in CI with `--test-options='--pattern=!/NoCi/'`. [test/README.md](test/README.md) describes+the test keyrings, and [RELEASE.md](RELEASE.md) how a release is cut.++[Changelog](CHANGELOG.md) · [License](LICENSE) (MIT)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
h-gpgme.cabal view
@@ -1,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
src/Crypto/Gpgme/Crypto.hs view
@@ -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
src/Crypto/Gpgme/Ctx.hs view
@@ -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
src/Crypto/Gpgme/Internal.hs view
@@ -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
test/CryptoTest.hs view
@@ -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
+ test/InternalTest.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+module InternalTest (tests) where++import Bindings.Gpgme+import Foreign+import Foreign.C.String (newCString)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit++import Crypto.Gpgme+import Crypto.Gpgme.Internal++tests :: [TestTree]+tests =+ [ testCase "collectSignaturesWithoutVerify" collectSignaturesWithoutVerify+ , testCase "collectFprsWalksList" collectFprsWalksList+ , testCase "verifyGarbageDoesNotCrash" verifyGarbageDoesNotCrash+ ]++-- gpgme_op_verify_result returns NULL when no successful verify ran on the+-- context, which used to segfault (stackoverflow.com/questions/48908274)+collectSignaturesWithoutVerify :: Assertion+collectSignaturesWithoutVerify = do+ _ <- c'gpgme_check_version nullPtr+ ctxPtr <- malloc+ checkError "gpgme_new" =<< c'gpgme_new ctxPtr+ ctx <- peek ctxPtr+ sigs <- collectSignatures' ctx+ c'gpgme_release ctx+ free ctxPtr+ assertEqual "expected no signatures" [] sigs++-- collectFprs used to diverge on any non-empty list because peeking a+-- whole C'_gpgme_invalid_key recurses via its mistyped next field+collectFprsWalksList :: Assertion+collectFprsWalksList = do+ second <- newInvalidKey "BBBB" 2 nullPtr+ first <- newInvalidKey "AAAA" 1 second+ assertEqual "expected both invalid keys" [("AAAA", 1), ("BBBB", 2)] (collectFprs first)+ where+ newInvalidKey fpr reason next = do+ ptr <- mallocBytes (sizeOf (undefined :: C'_gpgme_invalid_key))+ poke (castPtr (p'_gpgme_invalid_key'next ptr)) next+ poke (p'_gpgme_invalid_key'fpr ptr) =<< newCString fpr+ poke (p'_gpgme_invalid_key'reason ptr) reason+ return ptr++verifyGarbageDoesNotCrash :: Assertion+verifyGarbageDoesNotCrash = do+ res <- verify' "test/bob" "this is not a signature"+ case res of+ Left _ -> return ()+ Right r -> assertFailure ("expected verification error, got: " ++ show r)
test/KeyGenTest.hs view
@@ -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
test/KeyTest.hs view
@@ -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
test/Main.hs view
@@ -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 ]
test/TestUtil.hs view
@@ -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