diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -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.*/ diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,26 @@ +[![Hackage](https://img.shields.io/hackage/v/h-gpgme.svg)](https://hackage.haskell.org/package/h-gpgme) +[![CI](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml/badge.svg)](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml) +![MIT License](https://img.shields.io/github/license/rethab/h-gpgme?label=license) + + +h-gpgme: High Level Haskell Bindings for GnuPG Made Easy +======================================================== + +## Examples + +```haskell +let alice_pub_fpr = "EAACEB8A" + +-- encrypt +Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do + aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret + fromRight $ encrypt bCtx [aPubKey] NoFlag plain + +-- decrypt +dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx -> + decrypt aCtx enc +``` + +See the test folder for more examples + +[Changelog](CHANGELOG.markdown) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/h-gpgme.cabal b/h-gpgme.cabal new file mode 100644 --- /dev/null +++ b/h-gpgme.cabal @@ -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 diff --git a/src/Crypto/Gpgme.hs b/src/Crypto/Gpgme.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme.hs @@ -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: +-- +-- +-- == 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 diff --git a/src/Crypto/Gpgme/Crypto.hs b/src/Crypto/Gpgme/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Crypto.hs @@ -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' diff --git a/src/Crypto/Gpgme/Ctx.hs b/src/Crypto/Gpgme/Ctx.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Ctx.hs @@ -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 +-- 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 diff --git a/src/Crypto/Gpgme/Internal.hs b/src/Crypto/Gpgme/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Internal.hs @@ -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 diff --git a/src/Crypto/Gpgme/Key.hs b/src/Crypto/Gpgme/Key.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Key.hs @@ -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' diff --git a/src/Crypto/Gpgme/Key/Gen.hs b/src/Crypto/Gpgme/Key/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Key/Gen.hs @@ -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 ("" /=)) + [ "" + , "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 + , "" + ] + 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 diff --git a/src/Crypto/Gpgme/Types.hs b/src/Crypto/Gpgme/Types.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Types.hs @@ -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) diff --git a/test/CryptoTest.hs b/test/CryptoTest.hs new file mode 100644 --- /dev/null +++ b/test/CryptoTest.hs @@ -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 diff --git a/test/CtxTest.hs b/test/CtxTest.hs new file mode 100644 --- /dev/null +++ b/test/CtxTest.hs @@ -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 + ) diff --git a/test/KeyGenTest.hs b/test/KeyGenTest.hs new file mode 100644 --- /dev/null +++ b/test/KeyGenTest.hs @@ -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 @?= + "\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\ + \\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 @?= + "\n\ + \Key-Type: default\n\ + \Expire-Date: 10d\n\ + \\n" + +expireDateWeeks :: Assertion +expireDateWeeks = + let (Just p) = G.toPositive 10 + params = (def :: G.GenKeyParams) { + G.expireDate = Just $ G.ExpireW p + } + in G.toParamsString params @?= + "\n\ + \Key-Type: default\n\ + \Expire-Date: 10w\n\ + \\n" + +expireDateMonths :: Assertion +expireDateMonths = + let (Just p) = G.toPositive 10 + params = (def :: G.GenKeyParams) { + G.expireDate = Just $ G.ExpireM p + } + in G.toParamsString params @?= + "\n\ + \Key-Type: default\n\ + \Expire-Date: 10m\n\ + \\n" + +expireDateYears :: Assertion +expireDateYears = + let (Just p) = G.toPositive 10 + params = (def :: G.GenKeyParams) { + G.expireDate = Just $ G.ExpireY p + } + in G.toParamsString params @?= + "\n\ + \Key-Type: default\n\ + \Expire-Date: 10y\n\ + \\n" + +expireDateSeconds :: Assertion +expireDateSeconds = + let (Just p) = G.toPositive 123456 + params = (def :: G.GenKeyParams) { + G.expireDate = Just $ G.ExpireS p + } + in G.toParamsString params @?= + "\n\ + \Key-Type: default\n\ + \Expire-Date: seconds=123456\n\ + \\n" + +creationDateSeconds :: Assertion +creationDateSeconds = + let (Just p) = G.toPositive 123456 + params = (def :: G.GenKeyParams) { + G.creationDate = Just $ G.CreationS p + } + in G.toParamsString params @?= + "\n\ + \Key-Type: default\n\ + \Creation-Date: seconds=123456\n\ + \\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 diff --git a/test/KeyTest.hs b/test/KeyTest.hs new file mode 100644 --- /dev/null +++ b/test/KeyTest.hs @@ -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) " + 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" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/TestUtil.hs b/test/TestUtil.hs new file mode 100644 --- /dev/null +++ b/test/TestUtil.hs @@ -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