h-gpgme (empty) → 0.6.2.0
raw patch · 19 files changed
Files
- .gitignore +18/−0
- CHANGELOG.markdown +70/−0
- LICENSE +20/−0
- README.markdown +26/−0
- Setup.hs +2/−0
- h-gpgme.cabal +85/−0
- src/Crypto/Gpgme.hs +126/−0
- src/Crypto/Gpgme/Crypto.hs +453/−0
- src/Crypto/Gpgme/Ctx.hs +189/−0
- src/Crypto/Gpgme/Internal.hs +135/−0
- src/Crypto/Gpgme/Key.hs +235/−0
- src/Crypto/Gpgme/Key/Gen.hs +217/−0
- src/Crypto/Gpgme/Types.hs +178/−0
- test/CryptoTest.hs +317/−0
- test/CtxTest.hs +82/−0
- test/KeyGenTest.hs +228/−0
- test/KeyTest.hs +139/−0
- test/Main.hs +19/−0
- test/TestUtil.hs +53/−0
+ .gitignore view
@@ -0,0 +1,18 @@+.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 view
@@ -0,0 +1,70 @@+# Changelog++## 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
@@ -0,0 +1,20 @@+Copyright (c) 2022 Reto++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.markdown view
@@ -0,0 +1,26 @@+[](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)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ h-gpgme.cabal view
@@ -0,0 +1,85 @@+Name: h-gpgme+Version: 0.6.2.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.8+ , GHC==9.0+ , GHC==9.2+Category: Cryptography+Build-Type: Simple+Cabal-Version: >=1.10+Extra-Source-Files:+ CHANGELOG.markdown+ README.markdown+ .gitignore+++source-repository head+ type: git+ location: https://github.com/rethab/h-gpgme++library+ hs-source-dirs: src+ 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+ build-depends: base == 4.*+ , bindings-gpgme >= 0.1.8 && <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+ 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+ , tasty+ , tasty-quickcheck+ , tasty-hunit+ , QuickCheck + other-modules: Crypto.Gpgme+ , Crypto.Gpgme.Crypto+ , Crypto.Gpgme.Ctx+ , Crypto.Gpgme.Internal+ , Crypto.Gpgme.Key+ , Crypto.Gpgme.Key.Gen+ , Crypto.Gpgme.Types+ , CryptoTest+ , CtxTest+ , KeyTest+ , KeyGenTest+ , TestUtil
+ src/Crypto/Gpgme.hs view
@@ -0,0 +1,126 @@++-- |+-- Module : Crypto.Gpgme+-- Copyright : (c) Reto Hablützel 2015+-- License : MIT+--+-- Maintainer : rethab@rethab.ch+-- Stability : experimental+-- 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.+--+-- See the GnuPG manual for more information: <https://www.gnupg.org/documentation/manuals/gpgme.pdf>+--+--+-- == Example (from the tests):+--+-- >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+-- >+--++module Crypto.Gpgme (+ -- * Context+ Ctx+ , newCtx+ , freeCtx+ , withCtx+ , setArmor+ , setKeyListingMode+ -- ** Passphrase callbacks+ , isPassphraseCbSupported+ , PassphraseCb+ , setPassphraseCallback+ -- ** Progress callbacks+ , progressCb+ , setProgressCallback++ -- * Keys+ , Key+ , importKeyFromFile+ , getKey+ , listKeys+ , removeKey+ , RemoveKeyFlags(..)++ , searchKeys+ -- * Information about keys+ , Validity (..)+ , PubKeyAlgo (..)+ , KeySignature (..)+ , UserId (..)+ , KeyUserId (..)+ , keyUserIds+ , keyUserIds'+ , SubKey (..)+ , keySubKeys+ , keySubKeys'++ -- * Encryption+ , Signature+ , SignatureSummary(..)+ , VerificationResult+ , encrypt+ , encryptSign+ , encryptFd+ , encryptSignFd+ , encrypt'+ , encryptSign'+ , decrypt+ , decryptFd+ , decryptVerifyFd+ , decrypt'+ , decryptVerify+ , decryptVerify'+ , verify+ , verify'+ , verifyDetached+ , verifyDetached'+ , verifyPlain+ , verifyPlain'+ , sign++ -- * Error handling+ , GpgmeError+ , errorString+ , sourceString++ -- * Other Types+ , KeyListingMode(..)+ , SignMode(..)++ , Fpr+ , Encrypted+ , Plain++ , Protocol(..)++ , InvalidKey++ , IncludeSecret(..)++ , Flag(..)++ , DecryptError(..)++ , HgpgmeException(..)++) where+++import Crypto.Gpgme.Ctx+import Crypto.Gpgme.Crypto+import Crypto.Gpgme.Types+import Crypto.Gpgme.Key
+ src/Crypto/Gpgme/Crypto.hs view
@@ -0,0 +1,453 @@+module Crypto.Gpgme.Crypto (++ encrypt+ , encryptSign+ , encryptFd+ , encryptSignFd+ , encrypt'+ , encryptSign'+ , decrypt+ , decryptFd+ , decryptVerifyFd+ , decrypt'+ , decryptVerify+ , decryptVerify'+ , verify+ , verify'+ , verifyDetached+ , verifyDetached'+ , verifyPlain+ , verifyPlain'+ , sign++) where++import System.Posix.Types (Fd(Fd))+import Bindings.Gpgme+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, mapExceptT)+import Foreign+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import GHC.Ptr++import Crypto.Gpgme.Ctx+import Crypto.Gpgme.Internal+import Crypto.Gpgme.Key+import Crypto.Gpgme.Types++locale :: String+locale = "C"++-- | Convenience wrapper around 'withCtx' and 'withKey' to+-- encrypt a single plaintext for a single recipient with+-- its homedirectory.+encrypt' :: String -> Fpr -> Plain -> IO (Either String Encrypted)+encrypt' = encryptIntern' encrypt++-- | Convenience wrapper around 'withCtx' and 'withKey' to+-- encrypt and sign a single plaintext for a single recipient+-- with its homedirectory.+encryptSign' :: String -> Fpr -> Plain -> IO (Either String Encrypted)+encryptSign' = encryptIntern' encryptSign++orElse :: Monad m => m (Maybe a) -> e -> ExceptT e m a+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)+ where+ h (Left e) = Left (f e)+ h (Right a) = Right (g a)++encryptIntern' :: (Ctx -> [Key] -> Flag -> Plain+ -> IO (Either [InvalidKey] Encrypted)+ ) -> String -> Fpr -> Plain -> IO (Either String Encrypted)+encryptIntern' encrFun gpgDir recFpr plain =+ withCtx gpgDir locale OpenPGP $ \ctx -> runExceptT $+ do pubKey <- getKey ctx recFpr NoSecret `orElse` ("no such key: " ++ show recFpr)+ bimapExceptT show id $ ExceptT $ encrFun ctx [pubKey] NoFlag plain++-- | encrypt for a list of recipients+encrypt :: Ctx -> [Key] -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted)+encrypt = encryptIntern c'gpgme_op_encrypt++-- | encrypt and sign for a list of recipients+encryptSign :: Ctx -> [Key] -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) +encryptSign = encryptIntern c'gpgme_op_encrypt_sign++encryptIntern :: (C'gpgme_ctx_t+ -> GHC.Ptr.Ptr C'gpgme_key_t+ -> C'gpgme_encrypt_flags_t+ -> C'gpgme_data_t+ -> C'gpgme_data_t+ -> IO C'gpgme_error_t+ )+ -> Ctx+ -> [Key]+ -> Flag+ -> Plain+ -> IO (Either [InvalidKey] Encrypted) +encryptIntern enc_op Ctx {_ctx=ctxPtr} recPtrs flag plain = do+ -- init buffer with plaintext+ plainBufPtr <- malloc+ BS.useAsCString plain $ \bs -> do+ let copyData = 1 -- gpgme shall copy data, as bytestring will free it+ let plainlen = fromIntegral (BS.length plain)+ ret <- c'gpgme_data_new_from_mem plainBufPtr bs plainlen copyData+ checkError "data_new_from_mem" ret+ plainBuf <- peek plainBufPtr++ -- init buffer for result+ resultBufPtr <- newDataBuffer+ resultBuf <- peek resultBufPtr++ ctx <- peek ctxPtr++ -- encrypt+ withKeyPtrArray recPtrs $ \recArray -> + checkError "op_encrypt" =<< enc_op ctx recArray (fromFlag flag)+ plainBuf resultBuf+ free plainBufPtr++ -- check whether all keys could be used for encryption+ encResPtr <- c'gpgme_op_encrypt_result ctx+ encRes <- peek encResPtr+ let recPtr = c'_gpgme_op_encrypt_result'invalid_recipients encRes++ let res = if recPtr /= nullPtr+ then Left (collectFprs recPtr)+ else Right (collectResult resultBuf)++ free resultBufPtr++ return res++-- | Encrypt plaintext+encryptFd :: Ctx -> [Key] -> Flag -> Fd -> Fd -> IO (Either [InvalidKey] ())+encryptFd = encryptFdIntern c'gpgme_op_encrypt++-- | Encrypt and sign plaintext+encryptSignFd :: Ctx -> [Key] -> Flag -> Fd -> Fd -> IO (Either [InvalidKey] ())+encryptSignFd = encryptFdIntern c'gpgme_op_encrypt_sign++encryptFdIntern :: (C'gpgme_ctx_t+ -> GHC.Ptr.Ptr C'gpgme_key_t+ -> C'gpgme_encrypt_flags_t+ -> C'gpgme_data_t+ -> C'gpgme_data_t+ -> IO C'gpgme_error_t+ )+ -> Ctx+ -> [Key]+ -> Flag+ -> Fd -- ^ Plaintext data+ -> Fd -- ^ Ciphertext data+ -> IO (Either [InvalidKey] ())+encryptFdIntern enc_op Ctx {_ctx=ctxPtr} recPtrs flag (Fd plainCInt) (Fd cipherCInt) = do+ -- Initialize plaintext buffer+ plainBufPtr <- malloc+ _ <- c'gpgme_data_new_from_fd plainBufPtr plainCInt+ plainBuf <- peek plainBufPtr++ -- Initialize ciphertext buffer+ cipherBufPtr <- malloc+ _ <- c'gpgme_data_new_from_fd cipherBufPtr cipherCInt+ cipherBuf <- peek cipherBufPtr++ ctx <- peek ctxPtr++ -- encrypt+ withKeyPtrArray recPtrs $ \recArray ->+ checkError "op_encrypt" =<< enc_op ctx recArray (fromFlag flag)+ plainBuf cipherBuf+ free plainBufPtr++ -- check whether all keys could be used for encryption+ encResPtr <- c'gpgme_op_encrypt_result ctx+ encRes <- peek encResPtr+ let recPtr = c'_gpgme_op_encrypt_result'invalid_recipients encRes++ let res = if recPtr /= nullPtr+ then Left (collectFprs recPtr)+ else Right ()++ free cipherBufPtr++ return res++-- | Build a null-terminated array of pointers from a list of 'Key's+withKeyPtrArray :: [Key] -> (Ptr C'gpgme_key_t -> IO a) -> IO a+withKeyPtrArray [] f = f nullPtr+withKeyPtrArray keys f = do+ arr <- newArray0 nullPtr =<< mapM (peek . unsafeForeignPtrToPtr . unKey) keys+ f arr++-- | Convenience wrapper around 'withCtx' and 'withKey' to+-- decrypt a single ciphertext with its homedirectory.+decrypt' :: String -> Encrypted -> IO (Either DecryptError Plain)+decrypt' = decryptInternal' decrypt++-- | Convenience wrapper around 'withCtx' and 'withKey' to+-- decrypt and verify a single ciphertext with its homedirectory.+decryptVerify' :: String -> Encrypted -> IO (Either DecryptError Plain)+decryptVerify' = decryptInternal' decryptVerify++decryptInternal' :: (Ctx -> Encrypted -> IO (Either DecryptError Plain))+ -> String+ -> Encrypted+ -> IO (Either DecryptError Plain)+decryptInternal' decrFun gpgDir cipher =+ withCtx gpgDir locale OpenPGP $ \ctx ->+ decrFun ctx cipher++-- | Decrypts a ciphertext+decrypt :: Ctx -> Encrypted -> IO (Either DecryptError Plain)+decrypt = decryptIntern c'gpgme_op_decrypt++-- | Decrypts and verifies a ciphertext+decryptVerify :: Ctx -> Encrypted -> IO (Either DecryptError Plain)+decryptVerify = decryptIntern c'gpgme_op_decrypt_verify++decryptIntern :: (C'gpgme_ctx_t+ -> C'gpgme_data_t+ -> C'gpgme_data_t+ -> IO C'gpgme_error_t+ )+ -> Ctx+ -> Encrypted+ -> IO (Either DecryptError Plain)+decryptIntern dec_op Ctx {_ctx=ctxPtr} cipher = do+ -- init buffer with cipher+ cipherBufPtr <- malloc+ BS.useAsCString cipher $ \bs -> do+ let copyData = 1 -- gpgme shall copy data, as bytestring will free it+ let cipherlen = fromIntegral (BS.length cipher)+ ret <- c'gpgme_data_new_from_mem cipherBufPtr bs cipherlen copyData+ checkError "data_new_from_mem" ret+ cipherBuf <- peek cipherBufPtr++ -- init buffer for result+ resultBufPtr <- newDataBuffer+ resultBuf <- peek resultBufPtr++ ctx <- peek ctxPtr++ -- decrypt+ errcode <- dec_op ctx cipherBuf resultBuf++ let res = if errcode /= noError+ then Left (toDecryptError errcode)+ else Right (collectResult resultBuf)++ free cipherBufPtr+ free resultBufPtr++ return res++-- | Decrypt a ciphertext+decryptFd :: Ctx -> Fd -> Fd -> IO (Either DecryptError ())+decryptFd = decryptFdIntern c'gpgme_op_decrypt++-- | Decrypt and verify ciphertext+decryptVerifyFd :: Ctx -> Fd -> Fd -> IO (Either DecryptError ())+decryptVerifyFd = decryptFdIntern c'gpgme_op_decrypt_verify++decryptFdIntern :: (C'gpgme_ctx_t+ -> C'gpgme_data_t+ -> C'gpgme_data_t+ -> IO C'gpgme_error_t+ )+ -> Ctx+ -> Fd+ -> Fd+ -> IO (Either DecryptError ())+decryptFdIntern dec_op Ctx {_ctx=ctxPtr} (Fd cipherCInt) (Fd plainCInt)= do+ -- Initialize ciphertext buffer+ cipherBufPtr <- malloc+ _ <- c'gpgme_data_new_from_fd cipherBufPtr cipherCInt+ cipherBuf <- peek cipherBufPtr++ -- Initialize plaintext buffer+ plainBufPtr <- malloc+ _ <- c'gpgme_data_new_from_fd plainBufPtr plainCInt+ plainBuf <- peek plainBufPtr++ ctx <- peek ctxPtr++ -- decrypt+ errcode <- dec_op ctx cipherBuf plainBuf++ let res = if errcode /= noError+ then Left (toDecryptError errcode)+ else Right ()++ free cipherBufPtr+ free plainBufPtr++ return res++-- | Sign plaintext for a list of signers+sign :: Ctx -- ^ Context to sign+ -> [Key] -- ^ Keys to used for signing. An empty list will use context's default key.+ -> SignMode -- ^ Signing mode+ -> Plain -- ^ Plain text to sign+ -> IO (Either [InvalidKey] Plain)+sign = signIntern c'gpgme_op_sign++signIntern :: ( C'gpgme_ctx_t+ -> C'gpgme_data_t+ -> C'gpgme_data_t+ -> C'gpgme_sig_mode_t+ -> IO C'gpgme_error_t+ ) -- ^ c'gpgme_op_sign type signature+ -> Ctx+ -> [Key]+ -> SignMode+ -> Plain+ -> IO (Either [InvalidKey] Encrypted)+signIntern sign_op Ctx {_ctx=ctxPtr} signPtrs mode plain = do+ -- init buffer with plaintext+ plainBufPtr <- malloc+ BS.useAsCString plain $ \bs -> do+ let copyData = 1 -- gpgme shall copy data, as bytestring will free it+ let plainlen = fromIntegral (BS.length plain)+ ret <- c'gpgme_data_new_from_mem plainBufPtr bs plainlen copyData+ checkError "data_new_from_mem" ret+ plainBuf <- peek plainBufPtr++ -- init buffer for result+ resultBufPtr <- newDataBuffer+ resultBuf <- peek resultBufPtr++ ctx <- peek ctxPtr++ -- add signing keys+ mapM_ ( \kForPtr -> withForeignPtr (unKey kForPtr)+ (\kPtr -> do+ k <- peek kPtr+ c'gpgme_signers_add ctx k+ )+ ) signPtrs++ -- sign+ let modeCode = case mode of+ Normal -> c'GPGME_SIG_MODE_NORMAL+ Detach -> c'GPGME_SIG_MODE_DETACH+ Clear -> c'GPGME_SIG_MODE_CLEAR++ checkError "op_sign" =<< sign_op ctx plainBuf resultBuf modeCode+ free plainBufPtr++ -- check whether all keys could be used for signingi+ signResPtr <- c'gpgme_op_sign_result ctx+ signRes <- peek signResPtr+ let recPtr = c'_gpgme_op_sign_result'invalid_signers signRes++ let res = if recPtr /= nullPtr+ then Left (collectFprs recPtr)+ else Right (collectResult resultBuf)++ free resultBufPtr++ return res+++-- | Verify a payload with a detached signature+verifyDetached :: Ctx -- ^ GPG context+ -> Signature -- ^ Detached signature+ -> BS.ByteString -- ^ Signed text+ -> IO (Either GpgmeError VerificationResult)+verifyDetached ctx sig dat = do+ res <- verifyInternal go ctx sig dat+ return $ fmap fst res+ where+ go ctx' sig' dat' = do+ errcode <- c'gpgme_op_verify ctx' sig' dat' 0+ return (errcode, ())++-- | Convenience wrapper around 'withCtx' to+-- verify a single detached signature with its homedirectory.+verifyDetached' :: String -- ^ GPG context home directory+ -> Signature -- ^ Detached signature+ -> BS.ByteString -- ^ Signed text+ -> IO (Either GpgmeError VerificationResult)+verifyDetached' gpgDir sig dat =+ withCtx gpgDir locale OpenPGP $ \ctx ->+ verifyDetached ctx sig dat++{-# DEPRECATED verifyPlain "Use verify" #-}+verifyPlain :: Ctx -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, BS.ByteString))+verifyPlain c s _ = verify c s+{-# DEPRECATED verifyPlain' "Use verify'" #-}+verifyPlain' :: String -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, BS.ByteString))+verifyPlain' str sig _ = verify' str sig++-- | Verify a payload with a plain signature+verify :: Ctx -> Signature -> IO (Either GpgmeError (VerificationResult, BS.ByteString))+verify c s = verifyInternal go c s (C8.pack "")+ where+ go ctx sig _ = do+ -- init buffer for result+ resultBufPtr <- newDataBuffer+ resultBuf <- peek resultBufPtr++ errcode <- c'gpgme_op_verify ctx sig 0 resultBuf++ let res = if errcode /= noError+ then mempty+ else collectResult resultBuf++ free resultBufPtr++ return (errcode, res)++-- | Convenience wrapper around 'withCtx' to+-- verify a single plain signature with its homedirectory.+verify' :: String -> Signature -> IO (Either GpgmeError (VerificationResult, BS.ByteString))+verify' gpgDir sig =+ withCtx gpgDir locale OpenPGP $ \ctx ->+ verify ctx sig++verifyInternal :: ( C'gpgme_ctx_t+ -> C'gpgme_data_t+ -> C'gpgme_data_t+ -> IO (C'gpgme_error_t, a)+ )+ -> Ctx+ -> Signature+ -> BS.ByteString+ -> IO (Either GpgmeError (VerificationResult, a))+verifyInternal ver_op Ctx {_ctx=ctxPtr} sig dat = do+ -- init buffer with signature+ sigBufPtr <- malloc+ BS.useAsCString sig $ \bs -> do+ let copyData = 1 -- gpgme shall copy data, as bytestring will free it+ let siglen = fromIntegral (BS.length sig)+ ret <- c'gpgme_data_new_from_mem sigBufPtr bs siglen copyData+ checkError "data_new_from_mem" ret+ sigBuf <- peek sigBufPtr++ -- init buffer with data+ datBufPtr <- malloc+ BS.useAsCString dat $ \bs -> do+ let copyData = 1 -- gpgme shall copy data, as bytestring will free it+ let datlen = fromIntegral (BS.length dat)+ ret <- c'gpgme_data_new_from_mem datBufPtr bs datlen copyData+ checkError "data_new_from_mem" ret+ datBuf <- peek datBufPtr++ ctx <- peek ctxPtr++ -- verify+ (errcode, res) <- ver_op ctx sigBuf datBuf++ sigs <- collectSignatures' ctx+ let res' = if errcode /= noError+ then Left (GpgmeError errcode)+ else Right (sigs, res)++ free sigBufPtr+ free datBufPtr++ return res'
+ src/Crypto/Gpgme/Ctx.hs view
@@ -0,0 +1,189 @@+module Crypto.Gpgme.Ctx where++import Bindings.Gpgme+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++import Crypto.Gpgme.Types+import Crypto.Gpgme.Internal++-- | Creates a new 'Ctx' from a @homedirectory@, a @locale@+-- and a @protocol@. Needs to be freed with 'freeCtx', which+-- is why you are encouraged to use 'withCtx'.+newCtx :: String -- ^ path to gpg homedirectory+ -> String -- ^ locale+ -> Protocol -- ^ protocol+ -> IO Ctx+newCtx homedir localeStr protocol =+ do homedirPtr <- newCString homedir++ -- check version: necessary for initialization!!+ version <- c'gpgme_check_version nullPtr >>= peekCString++ -- create context+ ctxPtr <- malloc+ checkError "gpgme_new" =<< c'gpgme_new ctxPtr++ ctx <- peek ctxPtr++ -- find engine version+ engInfo <- c'gpgme_ctx_get_engine_info ctx >>= peek+ engVersion <- peekCString $ c'_gpgme_engine_info'version engInfo++ -- set locale+ locale <- newCString localeStr+ checkError "set_locale" =<< c'gpgme_set_locale ctx lcCtype locale++ -- set protocol in ctx+ checkError "set_protocol" =<< c'gpgme_set_protocol ctx+ (fromProtocol protocol)++ -- set homedir in ctx+ checkError "set_engine_info" =<< c'gpgme_ctx_set_engine_info ctx+ (fromProtocol protocol) nullPtr homedirPtr++ return (Ctx ctxPtr version protocol engVersion)+ where lcCtype :: CInt+ lcCtype = 0++-- | Free a previously created 'Ctx'+freeCtx :: Ctx -> IO ()+freeCtx Ctx {_ctx=ctxPtr} =+ do ctx <- peek ctxPtr+ c'gpgme_release ctx+ free ctxPtr++-- | Runs the action with a new 'Ctx' and frees it afterwards+--+-- See 'newCtx' for a descrption of the parameters.+withCtx :: String -- ^ path to gpg homedirectory+ -> String -- ^ locale+ -> Protocol -- ^ protocol+ -> (Ctx -> IO a) -- ^ action to be run with ctx+ -> IO a+withCtx homedir localeStr prot f = do+ ctx <- newCtx homedir localeStr prot+ catch+ ( do+ res <- f ctx+ freeCtx ctx+ return res+ )+ -- If an exception occurs, first free the GPG context+ -- and then throw our own exception to signal that+ -- the exception was caught and accounted for.+ ( \(SomeException e) -> do+ freeCtx ctx+ throwIO $ HgpgmeException (toException e)+ )++-- | Sets armor output on ctx+setArmor :: Bool -> Ctx -> IO ()+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+ let m = foldl (\memo -> (memo .|.) . fromKeyListingMode) 0 modes+ ctx <- peek ctxPtr+ checkError "set_keylist_mode" =<< c'gpgme_set_keylist_mode ctx m++-- | Are passphrase callbacks supported?+--+-- This functionality is known to be broken in some gpg versions,+-- see 'setPassphraseCb' for details.+isPassphraseCbSupported :: Ctx -> Bool+isPassphraseCbSupported ctx+ | OpenPGP <- _protocol ctx =+ case () of+ _ | "2.0" `isPrefixOf` ver -> False+ | "1." `isPrefixOf` ver -> False+ | otherwise -> True+ | otherwise = True -- give the user the benefit of a doubt+ where+ ver = _engineVersion ctx++-- | A callback invoked when the engine requires a passphrase to+-- proceed. The callback should return @Just@ the requested passphrase,+-- or @Nothing@ to cancel the operation.+type PassphraseCb =+ String -- ^ user ID hint+ -> String -- ^ passphrase info+ -> Bool -- ^ @True@ if the previous attempt was bad+ -> IO (Maybe String)++-- | Construct a passphrase callback, handling reporting of the+-- passphrase back to gpgme.+passphraseCb :: PassphraseCb -> IO C'gpgme_passphrase_cb_t+passphraseCb callback = do+ let go _ hint info prev_bad fd = do+ hint' <- peekCString hint+ info' <- peekCString info+ result <- callback hint' info' (prev_bad /= 0)+ 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)+ return $ maybe errCanceled (const 0) result+ errCanceled = 99 -- TODO: Use constant+ mk'gpgme_passphrase_cb_t go++-- | Set the callback invoked when a passphrase is required from the user.+--+-- 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.+setPassphraseCallback :: Ctx -- ^ context+ -> Maybe PassphraseCb -- ^ a callback, or Nothing to disable+ -> IO ()+setPassphraseCallback Ctx {_ctx=ctxPtr} callback = do+ ctx <- peek ctxPtr+ let mode = case callback of+ Nothing -> c'GPGME_PINENTRY_MODE_DEFAULT+ Just _ -> c'GPGME_PINENTRY_MODE_LOOPBACK+ -- With GPG 1.4 using the use-agent option and >= GPG 2.0 the passphrase+ -- callback won't have an opportunity to execute unless the loopback+ -- pinentry-mode is used+ c'gpgme_set_pinentry_mode ctx mode >>= checkError "setPassphraseCallback"+ cb <- maybe (return nullFunPtr) passphraseCb callback+ c'gpgme_set_passphrase_cb ctx cb nullPtr++-- | A callback invoked when the engine uses a progress notification.+-- See the PROGRESS section of docs/DETAILS in gnupg repository.+type ProgressCb =+ String -- ^ WHAT type of progress+ -> Char -- ^ CHAR is the character displayed with no --status-fd enabled, with the linefeed replaced by an 'X'+ -> Integer -- ^ CUR is the current progress+ -> Integer -- ^ TOTAL is the total possible progress+ -> IO ()++-- | Construct a progress callback+progressCb :: ProgressCb -> IO C'gpgme_progress_cb_t+progressCb callback = do+ let go _ what char cur total = do+ what' <- peekCString what+ let charChar = toEnum (fromEnum $ toInteger char)::Char+ callback what' charChar (toInteger cur) (toInteger total)+ mk'gpgme_progress_cb_t go++-- | Set the callback invoked when a progress feedback is available.+setProgressCallback :: Ctx -- ^ context+ -> Maybe ProgressCb+ -> IO ()+setProgressCallback Ctx {_ctx=ctxPtr} callback = do+ ctx <- peek ctxPtr+ cb <- maybe (return nullFunPtr) progressCb callback+ c'gpgme_set_progress_cb ctx cb nullPtr
+ src/Crypto/Gpgme/Internal.hs view
@@ -0,0 +1,135 @@+module Crypto.Gpgme.Internal where++import Bindings.Gpgme+import Control.Monad (unless)+import qualified Data.ByteString as BS+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++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)+ 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+ 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+collectSignatures ctx = unsafePerformIO $ collectSignatures' ctx++-- ^ Return signatures a GPG verify action.+collectSignatures' :: C'gpgme_ctx_t -> IO VerificationResult+collectSignatures' ctx = do+ verify_res <- c'gpgme_op_verify_result ctx+ sigs <- peek $ p'_gpgme_op_verify_result'signatures verify_res+ go sigs+ 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+ next <- peek $ p'_gpgme_signature'next sig+ xs <- go next+ return $ (GpgmeError status, toSignatureSummaries summary, fpr) : xs++checkError :: String -> C'gpgme_error_t -> IO ()+checkError fun gpgme_err =+ unless (gpgme_err == noError) $+ do errstr <- c'gpgme_strerror gpgme_err+ str <- peekCString errstr+ srcstr <- c'gpgme_strsource gpgme_err+ src <- peekCString srcstr+ error ("Fun: " ++ fun +++ ", Error: " ++ str +++ ", Source: " ++ show src)++noError :: Num a => a+noError = 0++fromKeyListingMode :: KeyListingMode -> C'gpgme_keylist_mode_t+fromKeyListingMode KeyListingLocal = c'GPGME_KEYLIST_MODE_LOCAL+fromKeyListingMode KeyListingExtern = c'GPGME_KEYLIST_MODE_EXTERN+fromKeyListingMode KeyListingSigs = c'GPGME_KEYLIST_MODE_SIGS+fromKeyListingMode KeyListingSigNotations = c'GPGME_KEYLIST_MODE_SIG_NOTATIONS+fromKeyListingMode KeyListingValidate = c'GPGME_KEYLIST_MODE_VALIDATE+++fromProtocol :: (Num a) => Protocol -> a+fromProtocol CMS = c'GPGME_PROTOCOL_CMS+fromProtocol GPGCONF = c'GPGME_PROTOCOL_GPGCONF+fromProtocol OpenPGP = c'GPGME_PROTOCOL_OpenPGP+fromProtocol UNKNOWN = c'GPGME_PROTOCOL_UNKNOWN++fromSecret :: IncludeSecret -> CInt+fromSecret WithSecret = 1+fromSecret NoSecret = 0++fromFlag :: Flag -> CUInt+fromFlag AlwaysTrust = c'GPGME_ENCRYPT_ALWAYS_TRUST+fromFlag NoFlag = 0++toValidity :: C'gpgme_validity_t -> Validity+toValidity n+ | n == c'GPGME_VALIDITY_UNKNOWN = ValidityUnknown+ | n == c'GPGME_VALIDITY_UNDEFINED = ValidityUndefined+ | n == c'GPGME_VALIDITY_NEVER = ValidityNever+ | n == c'GPGME_VALIDITY_MARGINAL = ValidityMarginal+ | n == c'GPGME_VALIDITY_FULL = ValidityFull+ | n == c'GPGME_VALIDITY_ULTIMATE = ValidityUltimate+ | otherwise = error "validityFromInt: Unrecognized trust validity"++toPubKeyAlgo :: C'gpgme_pubkey_algo_t -> PubKeyAlgo+toPubKeyAlgo n+ | n == c'GPGME_PK_RSA = Rsa+ | n == c'GPGME_PK_RSA_E = RsaE+ | n == c'GPGME_PK_RSA_S = RsaS+ | n == c'GPGME_PK_ELG_E = ElgE+ | n == c'GPGME_PK_DSA = Dsa+ | n == c'GPGME_PK_ELG = Elg+ | otherwise = error "toPubKeyAlgo: Unrecognized public key algorithm"++newDataBuffer :: IO (Ptr C'gpgme_data_t)+newDataBuffer = do+ resultBufPtr <- malloc+ checkError "data_new" =<< c'gpgme_data_new resultBufPtr+ return resultBufPtr
+ src/Crypto/Gpgme/Key.hs view
@@ -0,0 +1,235 @@+module Crypto.Gpgme.Key (+ getKey+ , importKeyFromFile+ , listKeys+ , removeKey+ , searchKeys+ -- * Information about keys+ , Validity (..)+ , PubKeyAlgo (..)+ , KeySignature (..)+ , UserId (..)+ , KeyUserId (..)+ , keyUserIds+ , keyUserIds'+ , SubKey (..)+ , keySubKeys+ , keySubKeys'+ ) where++import Bindings.Gpgme+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC8+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Foreign+import Foreign.C+import System.IO.Unsafe++import Crypto.Gpgme.Types+import Crypto.Gpgme.Internal++-- | Returns a list of all known 'Key's from the @context@.+listKeys :: Ctx -- ^ context to operate in+ -> IncludeSecret -- ^ whether to include the secrets+ -> IO [Key]+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 include the secrets+ -> 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 include the secrets+ -> 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 pat (fromSecret secret) >>= checkError "listKeys"+ let eof = 16383+ go accum = do+ key <- allocKey+ ret <- peek ctxPtr >>= \ctx ->+ withKeyPtr key $ c'gpgme_op_keylist_next ctx+ code <- c'gpgme_err_code ret+ case ret of+ _ | ret == noError -> go (key : accum)+ | code == eof -> return accum+ | otherwise -> checkError "listKeys" ret >> return []+ go []++-- | Returns a 'Key' from the @context@ based on its @fingerprint@.+-- 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+ -> IO (Maybe Key)+getKey Ctx {_ctx=ctxPtr} fpr secret = do+ key <- allocKey+ ret <- BS.useAsCString fpr $ \cFpr ->+ peek ctxPtr >>= \ctx ->+ withKeyPtr key $ \keyPtr ->+ c'gpgme_get_key ctx cFpr keyPtr (fromSecret secret)+ if ret == noError+ 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 {_ctx=ctxPtr} fp = do+ dataPtr <- newDataBuffer+ ret <-+ BS.useAsCString (BSC8.pack fp) $ \cFp ->+ c'gpgme_data_new_from_file dataPtr cFp 1+ 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 ret+ err -> pure $ Just $ GpgmeError err+ free dataPtr+ pure mGpgErr++-- | Removes the 'Key' from @context@+removeKey :: Ctx -- ^ context to operate in+ -> Key -- ^ key to delete+ -> RemoveKeyFlags -- ^ flags for remove operation+ -> IO (Maybe GpgmeError)+removeKey Ctx {_ctx=ctxPtr} key flags = do+ ctx <- peek ctxPtr+ ret <- withKeyPtr key (\keyPtr -> do+ k <- peek keyPtr+ c'gpgme_op_delete_ext ctx k cFlags)+ if ret == 0+ then return Nothing+ else return $ Just $ GpgmeError ret+ where+ 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+ , keysigTimestamp :: Maybe UTCTime+ , keysigExpires :: Maybe UTCTime+ , keysigUserId :: UserId+ -- TODO: Notations+ }++readTime :: CLong -> Maybe UTCTime+readTime (-1) = Nothing+readTime 0 = Nothing+readTime t = Just $ posixSecondsToUTCTime $ realToFrac t++readKeySignatures :: C'gpgme_key_sig_t -> IO [KeySignature]+readKeySignatures p0 = peekList c'_gpgme_key_sig'next p0 >>= mapM readSig+ where+ readSig 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+ where+ signerId :: IO UserId+ signerId =+ UserId <$> peekCString (c'_gpgme_key_sig'uid sig)+ <*> peekCString (c'_gpgme_key_sig'name sig)+ <*> peekCString (c'_gpgme_key_sig'email sig)+ <*> peekCString (c'_gpgme_key_sig'comment sig)++-- | A user ID consisting of a name, comment, and email address.+data UserId = UserId { userId :: String+ , userName :: String+ , userEmail :: String+ , userComment :: String+ }+ deriving (Ord, Eq, Show)++-- | A user ID+data KeyUserId = KeyUserId { keyuserValidity :: Validity+ , keyuserId :: UserId+ , keyuserSignatures :: [KeySignature]+ }++peekList :: Storable a => (a -> Ptr a) -> Ptr a -> IO [a]+peekList nextFunc = go []+ where+ go accum p+ | p == nullPtr = return accum+ | otherwise = do v <- peek p+ go (v : accum) (nextFunc v)++-- | Extract 'KeyUserId's from 'Key'.+keyUserIds' :: Key -> IO [KeyUserId]+keyUserIds' key = withForeignPtr (unKey key) $ \keyPtr -> do+ key' <- peek keyPtr >>= peek+ peekList c'_gpgme_user_id'next (c'_gpgme_key'uids key') >>= mapM readKeyUserId+ where+ readKeyUserId :: C'_gpgme_user_id -> IO KeyUserId+ readKeyUserId uid =+ (KeyUserId (toValidity $ c'_gpgme_user_id'validity uid)+ <$> userId')+ <*> readKeySignatures (c'_gpgme_user_id'signatures uid)+ where+ userId' :: IO UserId+ userId' =+ UserId <$> peekCString (c'_gpgme_user_id'uid uid)+ <*> peekCString (c'_gpgme_user_id'name uid)+ <*> peekCString (c'_gpgme_user_id'email uid)+ <*> peekCString (c'_gpgme_user_id'comment uid)++-- | Extract 'KeyUserId's from 'Key'. Uses 'unsafePerformIO' to bypass @IO@ monad!+-- Use 'keyUserIds' instead if possible.+keyUserIds :: Key -> [KeyUserId]+keyUserIds = unsafePerformIO . keyUserIds'++data SubKey = SubKey { subkeyAlgorithm :: PubKeyAlgo+ , subkeyLength :: Int+ , subkeyKeyId :: String+ , subkeyFpr :: Fpr+ , subkeyTimestamp :: Maybe UTCTime+ , subkeyExpires :: Maybe UTCTime+ , subkeyCardNumber :: Maybe String+ }++-- | Extract 'SubKey's from 'Key'.+keySubKeys' :: Key -> IO [SubKey]+keySubKeys' key = withForeignPtr (unKey key) $ \keyPtr -> do+ key' <- peek keyPtr >>= peek+ peekList c'_gpgme_subkey'next (c'_gpgme_key'subkeys key') >>= mapM readSubKey+ where+ readSubKey :: C'_gpgme_subkey -> IO SubKey+ readSubKey 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+ | ptr == nullPtr = return Nothing+ | otherwise = Just <$> f ptr++-- | Extract 'SubKey's from 'Key'. Uses 'unsafePerformIO' to bypass @IO@ monad!+-- Use 'keySubKeys' instead if possible.+keySubKeys :: Key -> [SubKey]+keySubKeys = unsafePerformIO . keySubKeys'
+ src/Crypto/Gpgme/Key/Gen.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Crypto.Gpgme.Key.Gen+License : Public Domain++Maintainer : daveparrish@tutanota.com+Stability : experimental+Portability : untested++Key generation for h-gpgme.++It is suggested to import as qualified. For example:++> import qualified Crypto.Gpgme.Key.Gen as G+-}++module Crypto.Gpgme.Key.Gen (+ -- * Usage+ genKey++ -- * Parameters+ , GenKeyParams (..)+ -- ** BitSize+ , BitSize+ , Crypto.Gpgme.Key.Gen.bitSize+ -- ** UsageList+ , UsageList (..)+ , Encrypt (..)+ , Sign (..)+ , Auth (..)+ -- ** ExpireDate+ , ExpireDate (..)+ -- ** CreationDate+ , CreationDate (..)+ -- * Other+ , Positive (unPositive)+ , toPositive+ , toParamsString+ ) where++import Crypto.Gpgme.Types+import Crypto.Gpgme.Internal++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC8+import Text.Email.Validate+import Foreign as F+import Foreign.C.String as FCS+import Bindings.Gpgme+import Data.Time.Clock+import Data.Time.Format+import Data.Default++-- | Key generation parameters.+--+-- See: https://www.gnupg.org/documentation/manuals/gnupg/Unattended-GPG-key-generation.html+data GenKeyParams = GenKeyParams {+ keyType :: Maybe PubKeyAlgo+ , keyLength :: Maybe BitSize+ , keyGrip :: BS.ByteString+ , keyUsage :: Maybe UsageList+ , subkeyType :: Maybe PubKeyAlgo+ , subkeyLength :: Maybe BitSize+ , passphrase :: BS.ByteString+ , nameReal :: BS.ByteString+ , nameComment :: BS.ByteString+ , nameEmail :: Maybe EmailAddress+ , expireDate :: Maybe ExpireDate+ , creationDate :: Maybe CreationDate+ , preferences :: BS.ByteString+ , revoker :: BS.ByteString+ , keyserver :: BS.ByteString+ , handle :: BS.ByteString+ , rawParams :: BS.ByteString -- ^ Add custom XML+ }++-- | Default parameters+--+-- Intended to be used to build custom paramemters.+--+-- > params = (def :: GenKeyParams) { keyType = Just Dsa }+--+-- See tests for working example of all parameters in use.+instance Default GenKeyParams where+ def = GenKeyParams Nothing Nothing "" Nothing Nothing Nothing "" "" ""+ Nothing Nothing Nothing "" "" "" "" ""++-- | Key-Length parameter+newtype BitSize = BitSize Int++-- | Bit size constrained to 1024-4096 bits+bitSize :: Int -> Either String BitSize+bitSize x+ | x < 1024 = Left "BitSize must be greater than 1024"+ | x > 4096 = Left "BitSize must be less than 4096"+ | otherwise = Right $ BitSize x++-- Key-Usage types+data Encrypt = Encrypt+data Sign = Sign+data Auth = Auth+data UsageList = UsageList {+ encrypt :: Maybe Encrypt+ , sign :: Maybe Sign+ , auth :: Maybe Auth+ }++-- | Default UsageList+--+-- Intended to be used to build custom UsageList parameter+--+-- > usageListParam = (def :: UsageList) (Just Encrypt)+--+-- See tests for working example of all parameters in use.+instance Default UsageList where+ def = UsageList Nothing Nothing Nothing++-- | Expire-Date parameter+--+-- Beware, 'genKey' will not check that ExpireDate is after+-- CreationDate of generated key.+data ExpireDate =+ ExpireT UTCTime | ExpireD Positive | ExpireW Positive |+ ExpireM Positive | ExpireY Positive | ExpireS Positive+-- TODO: Constrain ExpireDate to something that is valid.+-- No ISODate before today or creation date.++-- | Creation-Date parameter+data CreationDate = CreationT UTCTime+ | CreationS Positive -- ^ Seconds since epoch++-- | Only a positive Int+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)++-- | Generate a GPG key+genKey :: Ctx -- ^ context to operate in+ -> GenKeyParams -- ^ parameters to use for generating key+ -> IO (Either GpgmeError Fpr)+genKey Ctx {_ctx=ctxPtr} params = do+ ctx <- F.peek ctxPtr+ ret <- BS.useAsCString (toParamsString params) $ \p -> do+ let nullGpgmeData = 0 -- Using 0 as NULL for gpgme_data_t+ c'gpgme_op_genkey ctx p nullGpgmeData nullGpgmeData+ if ret == noError+ then do+ rPtr <- c'gpgme_op_genkey_result ctx+ r <- F.peek rPtr+ let fprPtr = c'_gpgme_op_genkey_result'fpr r+ fpr <- FCS.peekCString fprPtr++ return . Right $ BSC8.pack fpr+ else return . Left $ GpgmeError ret++-- | Used by 'genKey' generate a XML string for GPG+toParamsString :: GenKeyParams -> BS.ByteString+toParamsString params = (BSC8.unlines . filter ("" /=))+ [ "<GnupgKeyParms format=\"internal\">"+ , "Key-Type: " <> maybe "default" keyTypeToString (keyType params)+ , maybeLine "Key-Length: " keyLengthToString $ keyLength params+ , addLabel "Key-Grip: " $ keyGrip params+ , maybeLine "Key-Usage: " keyUsageListToString $ keyUsage params+ , maybeLine "Subkey-Type: " keyTypeToString $ subkeyType params+ , maybeLine "Subkey-Length: " keyLengthToString $ subkeyLength params+ , addLabel "Passphrase: " $ passphrase params+ , addLabel "Name-Real: " $ nameReal params+ , addLabel "Name-Comment: " $ nameComment params+ , maybeLine "Name-Email: " toByteString $ nameEmail params+ , maybeLine "Expire-Date: " expireDateToString $ expireDate params+ , maybeLine "Creation-Date: " creationDateToString $ creationDate params+ , addLabel "Preferences: " $ preferences params+ , addLabel "Revoker: " $ revoker params+ , addLabel "Keyserver: " $ keyserver params+ , addLabel "Handle: " $ handle params+ -- Allow for additional parameters as a raw ByteString+ , rawParams params+ , "</GnupgKeyParms>"+ ]+ where+ maybeLine :: BS.ByteString -> (a -> BS.ByteString) -> Maybe a -> BS.ByteString+ maybeLine h f p = addLabel h $ maybe "" f p+ -- Add label if not an empty string+ addLabel :: BS.ByteString -> BS.ByteString -> BS.ByteString+ addLabel _ "" = ""+ addLabel h s = h <> s+ keyTypeToString :: PubKeyAlgo -> BS.ByteString+ keyTypeToString Rsa = "RSA"+ keyTypeToString RsaE = "RSA-E"+ keyTypeToString RsaS = "RSA-S"+ keyTypeToString ElgE = "ELG-E"+ keyTypeToString Dsa = "DSA"+ keyTypeToString Elg = "ELG"+ keyLengthToString :: BitSize -> BS.ByteString+ keyLengthToString (BitSize i) = BSC8.pack $ show i+ keyUsageListToString :: UsageList -> BS.ByteString+ keyUsageListToString (UsageList e s a) =+ let eStr = maybe (""::BS.ByteString) (const "encrypt") e+ sStr = maybe (""::BS.ByteString) (const "sign") s+ aStr = maybe (""::BS.ByteString) (const "auth") a+ in (BSC8.intercalate "," . filter ("" /=)) [eStr, sStr, aStr]+ expireDateToString :: ExpireDate -> BS.ByteString+ expireDateToString (ExpireD p) = BSC8.pack (show (unPositive p) ++ "d")+ expireDateToString (ExpireW p) = BSC8.pack (show (unPositive p) ++ "w")+ expireDateToString (ExpireM p) = BSC8.pack (show (unPositive p) ++ "m")+ expireDateToString (ExpireY p) = BSC8.pack (show (unPositive p) ++ "y")+ expireDateToString (ExpireS p) =+ BSC8.pack ("seconds=" ++ show (unPositive p))+ expireDateToString (ExpireT t) =+ BSC8.pack $ formatTime defaultTimeLocale "%Y%m%dT%H%M%S" t+ creationDateToString :: CreationDate -> BS.ByteString+ creationDateToString (CreationS p) =+ BSC8.pack ("seconds=" ++ show (unPositive p))+ creationDateToString (CreationT t) =+ BSC8.pack $ formatTime defaultTimeLocale "%Y%m%dT%H%M%S" t
+ src/Crypto/Gpgme/Types.hs view
@@ -0,0 +1,178 @@+module Crypto.Gpgme.Types where++import Bindings.Gpgme+import qualified Data.ByteString as BS+import Data.Maybe (mapMaybe)+import Foreign+import qualified Foreign.Concurrent as FC+import Foreign.C.String (peekCString)+import System.IO.Unsafe (unsafePerformIO)+import Control.Exception (SomeException, Exception)++-- | the protocol to be used in the crypto engine+data Protocol =+ CMS+ | GPGCONF+ | OpenPGP+ | UNKNOWN+ deriving (Show, Eq, Ord)++-- | Context to be passed around with operations. Use 'newCtx' or+-- 'withCtx' in order to obtain an instance.+data Ctx = Ctx {+ _ctx :: Ptr C'gpgme_ctx_t -- ^ context+ , _version :: String -- ^ GPGME version+ , _protocol :: Protocol -- ^ context protocol+ , _engineVersion :: String -- ^ engine version+}++-- | Modes for key listings+data KeyListingMode+ = KeyListingLocal+ | KeyListingExtern+ | KeyListingSigs+ | KeyListingSigNotations+ | KeyListingValidate++-- | Modes for signing with GPG+data SignMode = Normal | Detach | Clear deriving Show++-- | a fingerprint+type Fpr = BS.ByteString++-- | a plaintext+type Plain = BS.ByteString++-- | an ciphertext+type Encrypted = BS.ByteString++-- | a signature+type Signature = BS.ByteString++-- | the summary of a signature status+data SignatureSummary =+ BadPolicy -- ^ A policy requirement was not met+ | CrlMissing -- ^ The CRL is not available+ | CrlTooOld -- ^ Available CRL is too old+ | Green -- ^ The signature is good but one might want to display some extra information+ | KeyExpired -- ^ The key or one of the certificates has expired+ | KeyMissing -- ^ Can’t verify due to a missing key or certificate+ | KeyRevoked -- ^ The key or at least one certificate has been revoked+ | Red -- ^ The signature is bad+ | SigExpired -- ^ The signature has expired+ | SysError -- ^ A system error occured+ | UnknownSummary C'gpgme_sigsum_t -- ^ The summary is something else+ | Valid -- ^ The signature is fully valid+ deriving (Show, Eq, Ord)++-- | Translate the gpgme_sigsum_t bit vector to a list of SignatureSummary+toSignatureSummaries :: C'gpgme_sigsum_t -> [SignatureSummary]+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)+ , (c'GPGME_SIGSUM_GREEN , Green)+ , (c'GPGME_SIGSUM_KEY_EXPIRED, KeyExpired)+ , (c'GPGME_SIGSUM_KEY_MISSING, KeyMissing)+ , (c'GPGME_SIGSUM_KEY_REVOKED, KeyRevoked)+ , (c'GPGME_SIGSUM_RED , Red)+ , (c'GPGME_SIGSUM_SIG_EXPIRED, SigExpired)+ , (c'GPGME_SIGSUM_SYS_ERROR , SysError)+ , (c'GPGME_SIGSUM_VALID , Valid)+ ]++type VerificationResult = [(GpgmeError, [SignatureSummary], Fpr)]++-- | The fingerprint and an error code+type InvalidKey = (String, Int)+-- TODO map intot better error code++-- | A key from the context+newtype Key = Key { unKey :: ForeignPtr C'gpgme_key_t }++-- | Allocate a key+allocKey :: IO Key+allocKey = do+ keyPtr <- malloc+ let finalize = do+ peek keyPtr >>= c'gpgme_key_unref+ free keyPtr+ Key `fmap` FC.newForeignPtr keyPtr finalize++-- | Perform an action with the pointer to a 'Key'+withKeyPtr :: Key -> (Ptr C'gpgme_key_t -> IO a) -> IO a+withKeyPtr (Key fPtr) = withForeignPtr fPtr++-- | Whether to include secret keys when searching+data IncludeSecret =+ WithSecret -- ^ do not include secret keys+ | NoSecret -- ^ include secret keys+ deriving (Show, Eq, Ord)++data Flag =+ AlwaysTrust+ | NoFlag+ deriving (Show, Eq, Ord)++-- | A GPGME error.+--+-- Errors in GPGME consist of two parts: a code indicating the nature of the fault,+-- and a source indicating from which subsystem the error originated.+newtype GpgmeError = GpgmeError C'gpgme_error_t+ deriving (Show, Ord, Eq)++-- | An explanatory string for a GPGME error.+errorString :: GpgmeError -> String+errorString (GpgmeError n) =+ unsafePerformIO $ c'gpgme_strerror n >>= peekCString++-- | An explanatory string describing the source of a GPGME error+sourceString :: GpgmeError -> String+sourceString (GpgmeError n) =+ unsafePerformIO $ c'gpgme_strsource n >>= peekCString++-- | error indicating what went wrong in decryption+data DecryptError =+ NoData -- ^ no data to decrypt+ | Failed -- ^ not a valid cipher+ | BadPass -- ^ passphrase for secret was wrong+ | Unknown GpgmeError -- ^ something else went wrong+ deriving (Show, Eq, Ord)++toDecryptError :: C'gpgme_error_t -> DecryptError+toDecryptError n =+ case unsafePerformIO $ c'gpgme_err_code n of+ 58 -> NoData+ 152 -> Failed+ 11 -> BadPass+ x -> Unknown (GpgmeError x)++-- | The validity of a user identity+data Validity =+ ValidityUnknown+ | ValidityUndefined+ | ValidityNever+ | ValidityMarginal+ | ValidityFull+ | ValidityUltimate+ deriving (Show, Ord, Eq)++-- | A public-key encryption algorithm+data PubKeyAlgo =+ Rsa+ | RsaE+ | RsaS+ | ElgE+ | Dsa+ | Elg+ deriving (Show, Ord, Eq)++-- | h-gpgme exception for wrapping exception which occur outside of the control of h-gpgme+newtype HgpgmeException = HgpgmeException SomeException deriving (Show)+instance Exception HgpgmeException++-- | Flags for removeKey function+data RemoveKeyFlags = RemoveKeyFlags {+ allowSecret :: Bool -- ^ if False, only public keys are removed, otherwise secret keys are removed as well+ , force :: Bool -- ^ if True, don't ask for confirmation+ } deriving (Show, Eq, Ord)
+ test/CryptoTest.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE OverloadedStrings #-}+module CryptoTest (tests, cbTests) where++import System.IO+import System.IO.Temp+import System.Posix.IO+import Control.Monad (when)+import Control.Monad.Trans.Maybe+import Control.Monad.IO.Class+import Control.Monad.Catch+import Control.Concurrent+import Data.List (isInfixOf)+import Data.ByteString.Char8 ()+import Data.Maybe ( fromJust )+import qualified Data.ByteString as BS+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck+import Test.HUnit hiding (assert)+import Test.QuickCheck.Monadic++import Crypto.Gpgme+import Crypto.Gpgme.Types ( GpgmeError (GpgmeError) )+import TestUtil++tests :: TestTree+tests = testGroup "crypto"+ [ testProperty "bobEncryptForAliceDecryptPromptNoCi"+ $ bobEncryptForAliceDecrypt False+ , testProperty "bobEncryptSignForAliceDecryptVerifyPromptNoCi"+ $ bobEncryptSignForAliceDecryptVerify False++ , testProperty "bobEncryptForAliceDecryptShortPromptNoCi"+ bobEncryptForAliceDecryptShort+ , testProperty "bobEncryptSignForAliceDecryptVerifyShortPromptNoCi"+ bobEncryptSignForAliceDecryptVerifyShort++ , 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+ ]++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" []++hush :: Monad m => m (Either e a) -> MaybeT m a+hush = MaybeT . fmap (either (const Nothing) Just)++withPassphraseCb :: String -> Ctx -> IO ()+withPassphraseCb passphrase ctx = do+ setPassphraseCallback ctx (Just callback)+ where+ callback _ _ _ = return (Just passphrase)++bobEncryptForAliceDecrypt :: Bool -> Plain -> Property+bobEncryptForAliceDecrypt passphrCb plain =+ not (BS.null plain) ==> monadicIO $ do+ 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 $ 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 =+ not (BS.null plain) ==> monadicIO $ do+ dec <- run encrAndDecr+ assert $ dec == plain+ where encrAndDecr =+ do -- encrypt+ enc <- encrypt' "test/bob" alicePubFpr plain++ -- decrypt+ dec <- decrypt' "test/alice" (fromRight enc)++ return $ fromRight dec++bobEncryptSignForAliceDecryptVerify :: Bool -> Plain -> Property+bobEncryptSignForAliceDecryptVerify passphrCb plain =+ not (BS.null plain) ==> monadicIO $ do+ 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++ -- 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 =+ not (BS.null plain) ==> monadicIO $ do+ dec <- run encrAndDecr+ assert $ dec == plain+ where encrAndDecr =+ do -- encrypt+ enc <- encryptSign' "test/bob" alicePubFpr plain++ -- decrypt+ dec <- decryptVerify' "test/alice" (fromRight enc)++ return $ fromRight dec++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)++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++bobEncryptSymmetrically :: Assertion+bobEncryptSymmetrically = do++ -- encrypt+ cipher <- fmap fromRight $+ withCtx "test/bob" "C" OpenPGP $ \ctx ->+ encrypt ctx [] NoFlag "plaintext"+ assertBool "must not be plain" (cipher /= "plaintext")++ -- decrypt+ plain <- fmap fromRight $+ withCtx "test/alice" "C" OpenPGP $ \ctx ->+ decrypt ctx cipher++ assertEqual "should decrypt to same" "plaintext" plain++bobDetachSignAndVerifySpecifyKeyPrompt :: Assertion+bobDetachSignAndVerifySpecifyKeyPrompt = do+ resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+ 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+ resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+ key <- getKey ctx bobPubFpr NoSecret+ resSign <- sign ctx [fromJust key] Clear "Clear text message from bob specifying signing key"+ verifyPlain ctx (fromRight resSign) ""+ assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify++bobClearSignAndVerifyDefaultKeyPrompt :: Assertion+bobClearSignAndVerifyDefaultKeyPrompt = do+ resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+ resSign <- sign ctx [] Clear "Clear text message from bob with default key"+ verifyPlain ctx (fromRight resSign) ""+ assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify++bobNormalSignAndVerifySpecifyKeyPrompt :: Assertion+bobNormalSignAndVerifySpecifyKeyPrompt = do+ resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+ 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+ resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+ resSign <- sign ctx [] Normal "Normal text message from bob with default key"+ verify ctx (fromRight resSign)+ assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify++encryptFile :: Assertion+encryptFile =+ withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+ withPassphraseCb "bob123" ctx+ withTestTmpFiles $ \pp ph cp ch dp dh -> do+ plainFd <- handleToFd ph+ cipherFd <- handleToFd ch+ decryptedFd <- handleToFd dh++ key <- getKey ctx 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 ()+ else assertFailure $ show resEnc++ -- Recreate the cipher FD because it is closed (or something) from the encrypt command+ cipherHandle' <- openFile cp ReadWriteMode+ cipherFd' <- handleToFd cipherHandle'++ -- Decrypt ciphertext+ resDec <- decryptFd ctx cipherFd' decryptedFd+ if resDec == Right ()+ then return ()+ else assertFailure $ show resDec++ -- Compare plaintext and decrypted text+ plaintext <- readFile pp+ decryptedtext <- readFile dp+ plaintext @=? decryptedtext++-- Encrypt from FD pipe into a FD file+encryptStream :: Assertion+encryptStream =+ withCtx "test/bob/" "C" OpenPGP $ \ctx -> do+ withPassphraseCb "bob123" ctx+ withTestTmpFiles $ \_ _ cp ch dp dh -> do++ cipherFd <- handleToFd ch+ decryptedFd <- handleToFd dh++ -- Use bob's key+ key <- getKey ctx 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++withTestTmpFiles :: (MonadIO m, MonadMask m)+ => ( FilePath -> Handle -- Plaintext+ -> FilePath -> Handle -- Ciphertext+ -> FilePath -> Handle -- Decrypted text+ -> m a)+ -> m a+withTestTmpFiles f =+ withSystemTempFile "plain" $ \pp ph ->+ withSystemTempFile "cipher" $ \cp ch ->+ withSystemTempFile "decrypt" $ \dp dh ->+ f pp ph cp ch dp dh+++-- Verify that the signature verification is successful+isVerifyValid :: Either t ([(GpgmeError, [SignatureSummary], t1)], t2) -> Bool+isVerifyValid (Right ([v], _)) = isVerifyValid' v+isVerifyValid (Right (v:vs, t)) = isVerifyValid' v && isVerifyValid (Right (vs,t))+isVerifyValid _ = False+isVerifyValid' :: (GpgmeError, [SignatureSummary], t) -> Bool+isVerifyValid' (GpgmeError 0, [Green,Valid], _) = True+isVerifyValid' _ = False++-- Verify that the signature verification is successful for verifyDetach+isVerifyDetachValid :: Either t [(GpgmeError, [SignatureSummary], t1)] -> Bool+isVerifyDetachValid (Right [v]) = isVerifyDetachValid' v+isVerifyDetachValid (Right ((v:vs))) = isVerifyDetachValid' v && isVerifyDetachValid (Right vs)+isVerifyDetachValid _ = False+isVerifyDetachValid' :: (GpgmeError, [SignatureSummary], t) -> Bool+isVerifyDetachValid' (GpgmeError 0, [Green,Valid], _) = True+isVerifyDetachValid' _ = False
+ test/CtxTest.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+module CtxTest (tests) where++import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class (lift)+import qualified Data.ByteString as BS+import Data.Maybe (fromMaybe)+import Control.Exception (catch, fromException)+import System.IO.Error (isUserError)++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit++import Crypto.Gpgme+import TestUtil++tests :: [TestTree]+tests = [ testCase "runActionWithCtx" runActionWithCtx+ , testCase "setArmor" setArmor'+ , testCase "unsetArmor" unsetArmor+ , testCase "noSetListingMode" noSetListingMode+ , testCase "setListingMode" setListingMode+ , testCase "exceptionSafe" exceptionSafe+ ]++runActionWithCtx :: Assertion+runActionWithCtx = do+ res <- withCtx "test/alice" "C" OpenPGP $ \_ ->+ return "foo" :: IO BS.ByteString+ res @?= "foo"++setArmor' :: Assertion+setArmor' = do+ let armorPrefix = "-----BEGIN PGP MESSAGE-----"+ enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do+ 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)++unsetArmor :: Assertion+unsetArmor = do+ let armorPrefix = "-----BEGIN PGP MESSAGE-----"+ enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do+ 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)++noSetListingMode :: Assertion+noSetListingMode = do+ sigs <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret+ kuids <- lift $ keyUserIds' aPubKey+ return $ concatMap keyuserSignatures kuids+ let sigs' = fromMaybe [] sigs+ null sigs' @? "There should be no signatures, but there are some"++setListingMode :: Assertion+setListingMode = do+ sigs <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do+ lift $ setKeyListingMode [KeyListingLocal, KeyListingSigs] bCtx+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret+ kuids <- lift $ keyUserIds' aPubKey+ return $ concatMap keyuserSignatures kuids+ let sigs' = fromMaybe [] sigs+ 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+exceptionSafe :: Assertion+exceptionSafe = catch+ ( do+ res <- withCtx "test/alice" "C" OpenPGP $ \_ ->+ ioError (userError "Busted") >>+ return "foo" :: IO BS.ByteString+ res @?= "foo")+ ( \(HgpgmeException e) -> do+ let mioe = fromException e :: Maybe IOError+ maybe (assertFailure $ show mioe) (\ioe -> isUserError ioe @?= True) mioe+ )
+ test/KeyGenTest.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE OverloadedStrings #-}+module KeyGenTest (tests) where++import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit++import Text.Email.Validate+import System.FilePath ((</>))+import System.Directory ( removeDirectoryRecursive )+import System.IO ( hPutStr+ , hPutStrLn+ , IOMode (..)+ , withFile+ , hGetContents+ )+import Data.Time.Calendar+import Data.Time.Clock+import Data.Default+import Data.List ( isPrefixOf )+import Data.ByteString.Char8 ( unpack )++import Crypto.Gpgme+import qualified Crypto.Gpgme.Key.Gen as G+import TestUtil++tests :: [TestTree]+tests = [ testCase "allGenKeyParameters" allGenKeyParameters+ , testCase "expireDateDays" expireDateDays+ , testCase "expireDateWeeks" expireDateWeeks+ , testCase "expireDateMonths" expireDateMonths+ , testCase "expireDateYears" expireDateYears+ , testCase "expireDateSeconds" expireDateSeconds+ , testCase "creationDateSeconds" creationDateSeconds+ , testCase "genKeyNoCi" genKey+ , testCase "progressCallbackNoCi" progressCallback+ ]++-- For getting values from Either+errorOnLeft :: Either String a -> a+errorOnLeft (Right x) = x+errorOnLeft (Left s) = error s++-- Test parameter list generation for generating keys+allGenKeyParameters :: Assertion+allGenKeyParameters =+ let params = (def :: G.GenKeyParams) -- G.defaultGenKeyParams+ { G.keyType = Just Dsa+ , G.keyLength = Just $ errorOnLeft $ G.bitSize 1024+ , G.keyGrip = "123abc"+ , G.keyUsage = Just $ (def :: G.UsageList) {+ G.encrypt = Just G.Encrypt+ , G.sign = Just G.Sign+ , G.auth = Just G.Auth+ }+ , G.subkeyType = Just ElgE+ , G.subkeyLength = Just $ errorOnLeft $ G.bitSize 1024+ , G.passphrase = "easy to guess"+ , G.nameReal = "Foo Bar"+ , G.nameComment = "A great comment"+ , G.nameEmail = Just $ errorOnLeft $ validate "foo@example.com"+ , G.expireDate = Just $ G.ExpireT $ UTCTime (fromGregorian 2050 8 15) 52812+ , G.creationDate = Just $ G.CreationT $+ UTCTime (fromGregorian 2040 8 16) 52813+ , G.preferences = "Some preference"+ , G.revoker = "RSA:fpr sensitive"+ , G.keyserver = "https://keyserver.com/"+ , G.handle = "Key handle here"+ }+ in G.toParamsString params @?=+ "<GnupgKeyParms format=\"internal\">\n\+ \Key-Type: DSA\n\+ \Key-Length: 1024\n\+ \Key-Grip: 123abc\n\+ \Key-Usage: encrypt,sign,auth\n\+ \Subkey-Type: ELG-E\n\+ \Subkey-Length: 1024\n\+ \Passphrase: easy to guess\n\+ \Name-Real: Foo Bar\n\+ \Name-Comment: A great comment\n\+ \Name-Email: foo@example.com\n\+ \Expire-Date: 20500815T144012\n\+ \Creation-Date: 20400816T144013\n\+ \Preferences: Some preference\n\+ \Revoker: RSA:fpr sensitive\n\+ \Keyserver: https://keyserver.com/\n\+ \Handle: Key handle here\n\+ \</GnupgKeyParms>\n"++genKey :: Assertion+genKey = do+ tmpDir <- createTemporaryTestDir "genKey"++ ret <- withCtx tmpDir "C" OpenPGP $ \ctx -> do+ let params = (def :: G.GenKeyParams)+ { G.keyType = Just Dsa+ , G.keyLength = Just $ errorOnLeft $ G.bitSize 1024+ , G.rawParams =+ "Subkey-Type: ELG-E\n\+ \Subkey-Length: 1024\n\+ \Name-Real: Joe Tester\n\+ \Name-Comment: (pp=abc)\n\+ \Name-Email: joe@foo.bar\n\+ \Expire-Date: 0\n\+ \Passphrase: abc\n"+ }++ G.genKey ctx params+ -- Cleanup temporary directory+ removeDirectoryRecursive tmpDir+ either+ (\l -> assertFailure $ "Left was return value " ++ show l)+ (\r -> assertBool ("Fingerprint ("+ ++ unpack r+ ++ ") starts with '0x' indicating it is actually a pointer.")+ (not $ isPrefixOf "0x" (unpack r))) ret++-- Other ExpireDate to string possibilities+expireDateDays :: Assertion+expireDateDays =+ let (Just p) = G.toPositive 10+ params = (def :: G.GenKeyParams) {+ G.expireDate = Just $ G.ExpireD p+ }+ in G.toParamsString params @?=+ "<GnupgKeyParms format=\"internal\">\n\+ \Key-Type: default\n\+ \Expire-Date: 10d\n\+ \</GnupgKeyParms>\n"++expireDateWeeks :: Assertion+expireDateWeeks =+ let (Just p) = G.toPositive 10+ params = (def :: G.GenKeyParams) {+ G.expireDate = Just $ G.ExpireW p+ }+ in G.toParamsString params @?=+ "<GnupgKeyParms format=\"internal\">\n\+ \Key-Type: default\n\+ \Expire-Date: 10w\n\+ \</GnupgKeyParms>\n"++expireDateMonths :: Assertion+expireDateMonths =+ let (Just p) = G.toPositive 10+ params = (def :: G.GenKeyParams) {+ G.expireDate = Just $ G.ExpireM p+ }+ in G.toParamsString params @?=+ "<GnupgKeyParms format=\"internal\">\n\+ \Key-Type: default\n\+ \Expire-Date: 10m\n\+ \</GnupgKeyParms>\n"++expireDateYears :: Assertion+expireDateYears =+ let (Just p) = G.toPositive 10+ params = (def :: G.GenKeyParams) {+ G.expireDate = Just $ G.ExpireY p+ }+ in G.toParamsString params @?=+ "<GnupgKeyParms format=\"internal\">\n\+ \Key-Type: default\n\+ \Expire-Date: 10y\n\+ \</GnupgKeyParms>\n"++expireDateSeconds :: Assertion+expireDateSeconds =+ let (Just p) = G.toPositive 123456+ params = (def :: G.GenKeyParams) {+ G.expireDate = Just $ G.ExpireS p+ }+ in G.toParamsString params @?=+ "<GnupgKeyParms format=\"internal\">\n\+ \Key-Type: default\n\+ \Expire-Date: seconds=123456\n\+ \</GnupgKeyParms>\n"++creationDateSeconds :: Assertion+creationDateSeconds =+ let (Just p) = G.toPositive 123456+ params = (def :: G.GenKeyParams) {+ G.creationDate = Just $ G.CreationS p+ }+ in G.toParamsString params @?=+ "<GnupgKeyParms format=\"internal\">\n\+ \Key-Type: default\n\+ \Creation-Date: seconds=123456\n\+ \</GnupgKeyParms>\n"++progressCallback :: Assertion+progressCallback = do+ tmpDir <- createTemporaryTestDir "progress_callback"++ -- Setup context+ genRet <- withCtx tmpDir "C" OpenPGP $ \ctx -> do+ -- Setup generation parameters+ let params = (def :: G.GenKeyParams)+ { G.keyType = Just Rsa+ , G.keyLength = Just $ errorOnLeft $ G.bitSize 2048+ , G.nameReal = "Joe Tester"+ , G.nameEmail = Just $ errorOnLeft $ validate "joe@foo.bar"+ , G.passphrase = "abc"+ }++ -- Setup callback which writes to temporary file.+ testProgressCb what char cur total =+ withFile (tmpDir </> "testProgress.log") AppendMode (\h -> do+ hPutStr h ("what: " ++ what)+ hPutStr h (" char: " ++ show char)+ hPutStr h (" cur: " ++ show cur)+ hPutStr h (" total: " ++ show total)+ hPutStrLn h "")++ setProgressCallback ctx (Just testProgressCb)++ -- Run key generation+ G.genKey ctx params++ -- Make sure the file has some evidence of progress notifications+ ret <- withFile (tmpDir </> "testProgress.log") ReadMode (\h -> do+ contents <- hGetContents h+ not (null (lines contents)) @? "No lines in progress file")++ -- Cleanup test+ removeDirectoryRecursive tmpDir+ assertBool ("Left was return value: " ++ show ret) (either (const False) (const True) genRet)+ return ret
+ test/KeyTest.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings #-}+module KeyTest (tests) where++import Data.Maybe+import Data.List+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit++import System.FilePath ((</>))+import System.Directory ( removeDirectoryRecursive+ , createDirectory+ , listDirectory+ , copyFile+ )++import Crypto.Gpgme+import TestUtil++tests :: [TestTree]+tests = [ testCase "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+ ]++getAlicePubFromAlice :: Assertion+getAlicePubFromAlice = do+ withCtx "test/alice" "C" OpenPGP $ \ctx ->+ do key <- getKey ctx alicePubFpr NoSecret+ isJust key @? "missing " ++ show alicePubFpr++getBobPubFromAlice :: Assertion+getBobPubFromAlice = do+ withCtx "test/alice/" "C" OpenPGP $ \ctx ->+ do key <- getKey ctx bobPubFpr NoSecret+ isJust key @? "missing " ++ show bobPubFpr++aliceListPubKeys :: Assertion+aliceListPubKeys = do+ withCtx "test/alice" "C" OpenPGP $ \ctx ->+ do keys <- listKeys ctx NoSecret+ length keys @?= 2+ let keyIds = [["163EC68CCF3FBF8E","DD2469546C4FB8F2"],+ ["6B9809775CF91391","3BA69AA2EAACEB8A"]]+ map (map subkeyKeyId . keySubKeys) keys @?= keyIds++aliceListSecretKeys :: Assertion+aliceListSecretKeys = do+ withCtx "test/alice" "C" OpenPGP $ \ctx ->+ do keys <- listKeys ctx WithSecret+ length keys @?= 1++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 inexistentFpr NoSecret+ isNothing key @? "existing " ++ show inexistentFpr++checkAlicePubUserIds :: Assertion+checkAlicePubUserIds = do+ withCtx "test/alice" "C" OpenPGP $ \ctx ->+ do Just key <- getKey ctx alicePubFpr NoSecret+ let uids = keyUserIds key+ length uids @?= 1+ let kuid = head uids+ uid = keyuserId kuid+ keyuserValidity kuid @?= ValidityUltimate+ userId uid @?= "Alice (Test User A) <alice@email.com>"+ userName uid @?= "Alice"+ userEmail uid @?= "alice@email.com"+ userComment uid @?= "Test User A"++checkAlicePubSubkeys :: Assertion+checkAlicePubSubkeys = do+ withCtx "test/alice" "C" OpenPGP $ \ctx ->+ do Just key <- getKey ctx alicePubFpr NoSecret+ let subs = keySubKeys key+ length subs @?= 2+ let sub = head subs+ subkeyAlgorithm sub @?= Rsa+ subkeyLength sub @?= 2048+ subkeyKeyId sub @?= "6B9809775CF91391"+ subkeyFpr sub @?= "3F10159E56ECB494ED42EFA36B9809775CF91391"++removeAliceKey :: Assertion+removeAliceKey = do+ tmpDir <- createTemporaryTestDir "removeAliceKey"++ -- Copy alice's key into temporary directory so we can safely remove it+ let aliceTmpDir = tmpDir </> "alice"+ createDirectory aliceTmpDir+ aliceFiles <- listDirectory "test/alice"+ mapM_ (\f -> copyFile ("test/alice" </> f) (tmpDir </> "alice" </> f))+ $ filter (\f -> not ("S.gpg-agent" `isPrefixOf` f)+ && f /= "private-keys-v1.d"+ && f /= ".gpg-v21-migrated"+ && f /= "randomSeed"+ ) aliceFiles++ withCtx (tmpDir </> "alice") "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"
+ test/Main.hs view
@@ -0,0 +1,19 @@+module Main where++import Test.Tasty (defaultMain, testGroup)++import KeyTest+import KeyGenTest+import CtxTest+import CryptoTest++main :: IO ()+main = do+ passphraseCbTests <- CryptoTest.cbTests+ defaultMain $ testGroup "tests"+ [ testGroup "key" KeyTest.tests+ , testGroup "keyGen" KeyGenTest.tests+ , testGroup "ctx" CtxTest.tests+ , CryptoTest.tests+ , passphraseCbTests+ ]
+ test/TestUtil.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module TestUtil where++import qualified Data.ByteString as BS+import Control.Monad (when)+import Data.Maybe (fromJust, fromMaybe)+import Test.QuickCheck+import System.FilePath ((</>))+import System.Directory ( getTemporaryDirectory+ , createDirectoryIfMissing+ , removeDirectoryRecursive+ , doesDirectoryExist+ )+++alicePubFpr :: BS.ByteString+alicePubFpr = "EAACEB8A"++bobPubFpr :: BS.ByteString+bobPubFpr = "6C4FB8F2"++-- Orphan instance here! Because this is only a test, orphans are probably OK.+-- http://stackoverflow.com/a/3081367/350221+instance Arbitrary BS.ByteString where+ arbitrary = fmap BS.pack arbitrary++justAndRight :: Maybe (Either a b) -> Bool+justAndRight = either (const False) (const True) . fromMaybe (Left undefined)++fromJustAndRight :: (Show a) => Maybe (Either a b) -> b+fromJustAndRight = fromRight . fromJust++fromRight :: (Show a) => Either a b -> b+fromRight = either (\e -> error $ "not right: " ++ show e) id++fromLeft :: Either e a -> e+fromLeft (Left e) = e+fromLeft _ = error "is not left"++isLeft :: Either a b -> Bool+isLeft (Right _) = False+isLeft (Left _) = True++createTemporaryTestDir :: String -> IO FilePath+createTemporaryTestDir s = do+ tmpDir <- getTemporaryDirectory >>= \x -> pure $ x </> s+ -- Cleanup tests that failed the last time+ tmpCheck <- doesDirectoryExist tmpDir+ when tmpCheck $ removeDirectoryRecursive tmpDir+ -- Create temporary directory+ createDirectoryIfMissing True tmpDir+ return tmpDir