diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +.cabal-sandbox/ +cabal.sandbox.config +dist/ +.hpc/ +test/alice/random_seed +test/alice/.gpg-v21-migrated +test/alice/private-keys-v1.d/ +test/bob/random_seed +test/bob/.gpg-v21-migrated +test/bob/private-keys-v1.d/ +/.stack-work diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,36 @@ +# Used as reference in building this Travis-CI configuration +# https://github.com/simonmichael/hledger/blob/master/.travis.yml +language: bash + +# Trusty required for Docker +# https://github.com/travis-ci/travis-ci/issues/5448#issuecomment-171420138 +dist: trusty + +branches: + only: + - master + +sudo: required + +services: + - docker + +# Test all +matrix: + include: + - env: + - STACK_YAML: stack.yaml + +install: + # Docker build + - docker-compose build --pull + # Stack setup + - docker-compose run --rm tests stack --stack-yaml ${STACK_YAML} setup + # Stack clean (Remove any old builds) + - docker-compose run --rm tests stack --stack-yaml ${STACK_YAML} clean + +script: + # Stack build + - docker-compose run --rm tests stack --stack-yaml ${STACK_YAML} build --haddock --no-haddock-deps + # Stack test (Only non-interactive tests) + - ./runtests-travis ${STACK_YAML} diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,37 @@ +# Changelog + +## 0.5.0.0 + +### New Features + +- Add Stack support +- Add key generation functionality +- Add remove key functionality +- Add clear sign functionality +- Add progress callback functionality +- Add file encryption and decryption +- Add safe `collectSignatures'` function + +### Bug fixes + +- Prevent potential memory leak in `withCtx` +- Return full fingerprint for `keySubKeys` +- Fix crash bug in `verifyInternal` involving a call to `performUnsafeIO` + +### Maintenance +- Replace dependency on `either` with `transfers` (thanks hvr) + +## 0.4.0.0 +- verifyDetached and verifyDetached' Verify a payload using a detached signature. (thanks mmhat) +- verifyPlain and verifyPlain' Verify a payload using a plain signature. (thanks mmhat) + +## 0.3.0.0 +- Added listKeys (thanks bgamari) +- Replaced withArmor with setArmor +- Removed withKey, manual freeing is no longer required so you can use getKey (thanks bgamari) +- Support for passphrase callbacks (thanks bgamari) + - Note that the operation of this feature is a bit inconsistent between GPG versions. GPG 1.4 using the use-agent option and GPG >= 2.1 require that the gpg-agent for the session has the allow-loopback-pinentry option enabled (this can be achieved by adding allow-loopback-pinentry to gpg-agent.conf. GPG versions between 2.0 and 2.1 do not support the --pinentry-mode option necessary for this support. + - See http://lists.gnupg.org/pipermail/gnupg-devel/2013-February/027345.html and the gpgme-tool example included in the gpgme tree for details. + +## 0.2.0.0 +- Added withArmor for ASCII-armored output (thanks yaccz) diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,23 @@ +[![Hackage](https://img.shields.io/hackage/v/h-gpgme.svg)](https://hackage.haskell.org/package/h-gpgme) [![Build Status](https://travis-ci.org/rethab/h-gpgme.svg?branch=master)](https://travis-ci.org/rethab/h-gpgme) + +h-gpgme: High Level Haskell Bindings for GnuPG Made Easy +======================================================== + +## Examples + +```haskell +let alice_pub_fpr = "EAACEB8A" + +-- encrypt +Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do + aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret + fromRight $ encrypt bCtx [aPubKey] NoFlag plain + +-- decrypt +dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx -> + decrypt aCtx enc +``` + +See the test folder for more examples + +[Changelog](CHANGELOG.markdown) diff --git a/h-gpgme.cabal b/h-gpgme.cabal --- a/h-gpgme.cabal +++ b/h-gpgme.cabal @@ -1,20 +1,25 @@ Name: h-gpgme -Version: 0.4.0.0 -Description: High Level Binding for GnuPG Made Easy (gpgme) +Version: 0.5.0.0 +Description: High Level Binding for GnuPG Made Easy (gpgme): A Haskell API for the gpgme C library. Synopsis: High Level Binding for GnuPG Made Easy (gpgme) License: MIT License-file: LICENSE Author: Reto Habluetzel -Maintainer: rethab@rethab.ch -Copyright: (c) Reto Habluetzel 2016 -Author: Reto Habluetzel 2016 +Maintainer: rethab@protonmail.ch +Copyright: (c) Reto Habluetzel 2018 Homepage: https://github.com/rethab/h-gpgme Bug-reports: https://github.com/rethab/h-gpgme/issues Tested-With: GHC==7.10.3 Category: Cryptography Build-Type: Simple Cabal-Version: >=1.10 +Extra-Source-Files: + CHANGELOG.markdown + README.markdown + .gitignore + .travis.yml + source-repository head type: git location: https://github.com/rethab/h-gpgme @@ -24,6 +29,7 @@ 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 @@ -32,28 +38,47 @@ build-depends: base == 4.* , bindings-gpgme >= 0.1.6 && <0.2 , bytestring >= 0.9 - , either >= 4.3 && <5.0 + , 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 - -fhpc hs-source-dirs: src, test main-is: Main.hs build-depends: base == 4.* , bindings-gpgme >= 0.1.6 && <0.2 , bytestring >= 0.9 - , either >= 4.3 && <5.0 - , transformers >= 0.3 && <0.5 + , transformers >= 0.4.1 && <0.6 , time >= 1.4 && <2.0 , unix >= 2.5 + , directory + , filepath + , email-validate + , data-default + , temporary + , exceptions - , HUnit >= 1.2 && <1.3 + , HUnit >= 1.2 && <1.4 , tasty >= 0.10 && <1.0 , tasty-quickcheck >= 0.8 && <1.0 , tasty-hunit >= 0.9 && <1.0 , 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 --- a/src/Crypto/Gpgme.hs +++ b/src/Crypto/Gpgme.hs @@ -42,11 +42,15 @@ , isPassphraseCbSupported , PassphraseCb , setPassphraseCallback + -- ** Progress callbacks + , progressCb + , setProgressCallback -- * Keys , Key , getKey , listKeys + , removeKey -- * Information about keys , Validity (..) , PubKeyAlgo (..) @@ -54,8 +58,10 @@ , UserId (..) , KeyUserId (..) , keyUserIds + , keyUserIds' , SubKey (..) , keySubKeys + , keySubKeys' -- * Encryption , Signature @@ -63,16 +69,23 @@ , VerificationResult , encrypt , encryptSign + , encryptFd + , encryptSignFd , encrypt' , encryptSign' , decrypt + , decryptFd + , decryptVerifyFd , decrypt' , decryptVerify , decryptVerify' + , verify + , verify' , verifyDetached , verifyDetached' , verifyPlain , verifyPlain' + , sign -- * Error handling , GpgmeError @@ -80,6 +93,8 @@ , sourceString -- * Other Types + , SignMode(..) + , Fpr , Encrypted , Plain @@ -93,6 +108,8 @@ , Flag(..) , DecryptError(..) + + , HgpgmeException(..) ) where diff --git a/src/Crypto/Gpgme/Crypto.hs b/src/Crypto/Gpgme/Crypto.hs --- a/src/Crypto/Gpgme/Crypto.hs +++ b/src/Crypto/Gpgme/Crypto.hs @@ -2,23 +2,32 @@ 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 (liftM) -import Control.Monad.Trans.Either +import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, mapExceptT) import Foreign import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import GHC.Ptr @@ -43,16 +52,22 @@ encryptSign' :: String -> Fpr -> Plain -> IO (Either String Encrypted) encryptSign' = encryptIntern' encryptSign -orElse :: Monad m => m (Maybe a) -> e -> EitherT e m a -orElse action err = EitherT $ maybe (Left err) return `liftM` action +orElse :: Monad m => m (Maybe a) -> e -> ExceptT e m a +orElse action err = ExceptT $ maybe (Left err) return `liftM` 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 -> runEitherT $ + withCtx gpgDir locale OpenPGP $ \ctx -> runExceptT $ do pubKey <- getKey ctx recFpr NoSecret `orElse` ("no such key: " ++ show recFpr) - bimapEitherT show id $ EitherT $ encrFun ctx [pubKey] NoFlag plain + bimapExceptT show id $ ExceptT $ encrFun ctx [pubKey] NoFlag plain -- | encrypt for a list of recipients encrypt :: Ctx -> [Key] -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) @@ -109,6 +124,59 @@ 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 @@ -142,7 +210,6 @@ 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 @@ -179,8 +246,119 @@ 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 -> Signature -> BS.ByteString -> IO (Either GpgmeError VerificationResult) +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 @@ -191,21 +369,31 @@ -- | Convenience wrapper around 'withCtx' to -- verify a single detached signature with its homedirectory. -verifyDetached' :: String -> Signature -> BS.ByteString -> IO (Either GpgmeError VerificationResult) +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 --- | Verify a payload with a plain signature +{-# DEPRECATED verifyPlain "Use verify" #-} verifyPlain :: Ctx -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, BS.ByteString)) -verifyPlain = verifyInternal go +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 dat = do + go ctx sig _ = do -- init buffer for result resultBufPtr <- newDataBuffer resultBuf <- peek resultBufPtr - errcode <- c'gpgme_op_verify ctx sig dat resultBuf + errcode <- c'gpgme_op_verify ctx sig 0 resultBuf let res = if errcode /= noError then mempty @@ -217,12 +405,20 @@ -- | Convenience wrapper around 'withCtx' to -- verify a single plain signature with its homedirectory. -verifyPlain' :: String -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, BS.ByteString)) -verifyPlain' gpgDir sig dat = +verify' :: String -> Signature -> IO (Either GpgmeError (VerificationResult, BS.ByteString)) +verify' gpgDir sig = withCtx gpgDir locale OpenPGP $ \ctx -> - verifyPlain ctx sig dat + 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 :: ( 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 @@ -247,9 +443,10 @@ -- verify (errcode, res) <- ver_op ctx sigBuf datBuf + sigs <- collectSignatures' ctx let res' = if errcode /= noError then Left (GpgmeError errcode) - else Right (collectSignatures ctx, res) + else Right (sigs, res) free sigBufPtr free datBufPtr diff --git a/src/Crypto/Gpgme/Ctx.hs b/src/Crypto/Gpgme/Ctx.hs --- a/src/Crypto/Gpgme/Ctx.hs +++ b/src/Crypto/Gpgme/Ctx.hs @@ -2,6 +2,7 @@ import Bindings.Gpgme import Control.Monad (when) +import Control.Exception (SomeException(SomeException), catch, throwIO, toException) import Data.List (isPrefixOf) import Foreign import Foreign.C.String @@ -66,9 +67,19 @@ -> IO a withCtx homedir localeStr prot f = do ctx <- newCtx homedir localeStr prot - res <- f ctx - freeCtx ctx - return res + 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 () @@ -141,3 +152,30 @@ 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 --- a/src/Crypto/Gpgme/Internal.hs +++ b/src/Crypto/Gpgme/Internal.hs @@ -34,8 +34,13 @@ else return BS.empty seekSet = 0 +-- ^ Unsafe IO version of `collectSignatures`. Try to use `collectSignatures'` instead. collectSignatures :: C'gpgme_ctx_t -> VerificationResult -collectSignatures ctx = unsafePerformIO $ do +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 diff --git a/src/Crypto/Gpgme/Key.hs b/src/Crypto/Gpgme/Key.hs --- a/src/Crypto/Gpgme/Key.hs +++ b/src/Crypto/Gpgme/Key.hs @@ -1,6 +1,7 @@ module Crypto.Gpgme.Key ( getKey , listKeys + , removeKey -- * Information about keys , Validity (..) , PubKeyAlgo (..) @@ -8,12 +9,13 @@ , UserId (..) , KeyUserId (..) , keyUserIds + , keyUserIds' , SubKey (..) , keySubKeys + , keySubKeys' ) where import Bindings.Gpgme -import Control.Applicative import qualified Data.ByteString as BS import Data.Time.Clock import Data.Time.Clock.POSIX @@ -59,6 +61,25 @@ then return . Just $ key else return Nothing +-- | Removes the 'Key' from @context@ +removeKey :: Ctx -- ^ context to operate in + -> Key -- ^ key to delete + -> IncludeSecret -- ^ include secret keys for deleting + -> IO (Maybe GpgmeError) +removeKey (Ctx {_ctx=ctxPtr}) key secret = do + ctx <- peek ctxPtr + ret <- withKeyPtr key (\keyPtr -> do + k <- peek keyPtr + c'gpgme_op_delete ctx k s) + if ret == 0 + then return Nothing + else return $ Just $ GpgmeError ret + where + s = secretToCInt secret + secretToCInt :: IncludeSecret -> CInt + secretToCInt WithSecret = 1 + secretToCInt NoSecret = 0 + -- | A key signature data KeySignature = KeySig { keysigAlgorithm :: PubKeyAlgo , keysigKeyId :: String @@ -112,6 +133,7 @@ | 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 @@ -130,6 +152,8 @@ <*> 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' @@ -142,6 +166,7 @@ , subkeyCardNumber :: Maybe String } +-- | Extract 'SubKey's from 'Key'. keySubKeys' :: Key -> IO [SubKey] keySubKeys' key = withForeignPtr (unKey key) $ \keyPtr -> do key' <- peek keyPtr >>= peek @@ -152,7 +177,7 @@ SubKey <$> pure (toPubKeyAlgo $ c'_gpgme_subkey'pubkey_algo sub) <*> pure (fromIntegral $ c'_gpgme_subkey'length sub) <*> peekCString (c'_gpgme_subkey'keyid sub) - <*> BS.packCString (c'_gpgme_subkey'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) @@ -162,5 +187,7 @@ | 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,218 @@ +{-# 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 Data.Monoid ((<>)) +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 +data 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 +data 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 --- a/src/Crypto/Gpgme/Types.hs +++ b/src/Crypto/Gpgme/Types.hs @@ -7,6 +7,7 @@ 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 = @@ -25,6 +26,9 @@ , _engineVersion :: String -- ^ engine version } +-- | Modes for signing with GPG +data SignMode = Normal | Detach | Clear deriving Show + -- | a fingerprint type Fpr = BS.ByteString @@ -154,3 +158,7 @@ | 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 diff --git a/test/CryptoTest.hs b/test/CryptoTest.hs new file mode 100644 --- /dev/null +++ b/test/CryptoTest.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE OverloadedStrings #-} +module CryptoTest (tests, cbTests) where + +import System.IO +import System.IO.Temp +import System.Posix.IO +import Control.Monad (liftM, 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) + , SignMode ( Clear, Detach, Normal ) + ) +import TestUtil + +tests :: TestTree +tests = testGroup "crypto" + [ testProperty "bob_encrypt_for_alice_decrypt_prompt_no_travis" + $ bob_encrypt_for_alice_decrypt False + , testProperty "bob_encrypt_sign_for_alice_decrypt_verify_prompt_no_travis" + $ bob_encrypt_sign_for_alice_decrypt_verify False + + , testProperty "bob_encrypt_for_alice_decrypt_short_prompt_no_travis" + bob_encrypt_for_alice_decrypt_short + , testProperty "bob_encrypt_sign_for_alice_decrypt_verify_short_prompt_no_travis" + bob_encrypt_sign_for_alice_decrypt_verify_short + + , testCase "decrypt_garbage" decrypt_garbage + , testCase "encrypt_wrong_key" encrypt_wrong_key + , testCase "bob_encrypt_symmetrically_prompt_no_travis" bob_encrypt_symmetrically + , testCase "bob_detach_sign_and_verify_specify_key_prompt_no_travis" bob_detach_sign_and_verify_specify_key_prompt + , testCase "bob_clear_sign_and_verify_specify_key_prompt_no_travis" bob_clear_sign_and_verify_specify_key_prompt + , testCase "bob_clear_sign_and_verify_default_key_prompt_no_travis" bob_clear_sign_and_verify_default_key_prompt + , testCase "bob_normal_sign_and_verify_specify_key_prompt_no_travis" bob_normal_sign_and_verify_specify_key_prompt + , testCase "bob_normal_sign_and_verify_default_key_prompt_no_travis" bob_normal_sign_and_verify_default_key_prompt + , testCase "encrypt_file_no_travis" encrypt_file + , testCase "encrypt_stream_no_travis" encrypt_stream + ] + +cbTests :: IO TestTree +cbTests = do + supported <- withCtx "test/bob" "C" OpenPGP $ \ctx -> + return $ isPassphraseCbSupported ctx + if supported + then return $ testGroup "passphrase-cb" + [ testProperty "bob_encrypt_for_alice_decrypt" + $ bob_encrypt_for_alice_decrypt True + , testProperty "bob_encrypt_sign_for_alice_decrypt_verify_with_passphrase_cb_prompt_no_travis" + $ bob_encrypt_sign_for_alice_decrypt_verify True + ] + else return $ testGroup "passphrase-cb" [] + +hush :: Monad m => m (Either e a) -> MaybeT m a +hush = MaybeT . liftM (either (const Nothing) Just) + +withPassphraseCb :: String -> Ctx -> IO () +withPassphraseCb passphrase ctx = do + setPassphraseCallback ctx (Just callback) + where + callback _ _ _ = return (Just passphrase) + +bob_encrypt_for_alice_decrypt :: Bool -> Plain -> Property +bob_encrypt_for_alice_decrypt passphrCb plain = + not (BS.null plain) ==> monadicIO $ do + dec <- run encr_and_decr + assert $ dec == plain + where encr_and_decr = + do -- encrypt + Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do + aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret + hush $ encrypt bCtx [aPubKey] NoFlag plain + + -- decrypt + dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx -> do + when passphrCb $ withPassphraseCb "alice123" aCtx + decrypt aCtx enc + + return $ fromRight dec + +bob_encrypt_for_alice_decrypt_short :: Plain -> Property +bob_encrypt_for_alice_decrypt_short plain = + not (BS.null plain) ==> monadicIO $ do + dec <- run encr_and_decr + assert $ dec == plain + where encr_and_decr = + do -- encrypt + enc <- encrypt' "test/bob" alice_pub_fpr plain + + -- decrypt + dec <- decrypt' "test/alice" (fromRight enc) + + return $ fromRight dec + +bob_encrypt_sign_for_alice_decrypt_verify :: Bool -> Plain -> Property +bob_encrypt_sign_for_alice_decrypt_verify passphrCb plain = + not (BS.null plain) ==> monadicIO $ do + dec <- run encr_and_decr + assert $ dec == plain + where encr_and_decr = + do -- encrypt + Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do + aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret + hush $ encryptSign bCtx [aPubKey] NoFlag plain + + -- decrypt + dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx -> do + when passphrCb $ withPassphraseCb "alice123" aCtx + decryptVerify aCtx enc + + return $ fromRight dec + +bob_encrypt_sign_for_alice_decrypt_verify_short :: Plain -> Property +bob_encrypt_sign_for_alice_decrypt_verify_short plain = + not (BS.null plain) ==> monadicIO $ do + dec <- run encr_and_decr + assert $ dec == plain + where encr_and_decr = + do -- encrypt + enc <- encryptSign' "test/bob" alice_pub_fpr plain + + -- decrypt + dec <- decryptVerify' "test/alice" (fromRight enc) + + return $ fromRight dec + +encrypt_wrong_key :: Assertion +encrypt_wrong_key = do + res <- encrypt' "test/bob" "INEXISTENT" "plaintext" + assertBool "should fail" (isLeft res) + let err = fromLeft res + assertBool "should contain key" ("INEXISTENT" `isInfixOf` err) + +decrypt_garbage :: Assertion +decrypt_garbage = do + val <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> + decrypt bCtx (BS.pack [1,2,3,4,5,6]) + isLeft val @? "should be left " ++ show val + +bob_encrypt_symmetrically :: Assertion +bob_encrypt_symmetrically = do + + -- 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 + +bob_detach_sign_and_verify_specify_key_prompt :: Assertion +bob_detach_sign_and_verify_specify_key_prompt = do + resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do + key <- getKey ctx bob_pub_fpr 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 + +bob_clear_sign_and_verify_specify_key_prompt :: Assertion +bob_clear_sign_and_verify_specify_key_prompt = do + resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do + key <- getKey ctx bob_pub_fpr NoSecret + resSign <- sign ctx [(fromJust key)] Clear "Clear text message from bob specifying signing key" + verifyPlain ctx (fromRight resSign) "" + assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify + +bob_clear_sign_and_verify_default_key_prompt :: Assertion +bob_clear_sign_and_verify_default_key_prompt = do + 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 + +bob_normal_sign_and_verify_specify_key_prompt :: Assertion +bob_normal_sign_and_verify_specify_key_prompt = do + resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do + key <- getKey ctx bob_pub_fpr NoSecret + resSign <- sign ctx [(fromJust key)] Normal "Normal text message from bob specifying signing key" + verify ctx (fromRight resSign) + assertBool "Could not verify bob's signature was correct" $ isVerifyValid resVerify + +bob_normal_sign_and_verify_default_key_prompt :: Assertion +bob_normal_sign_and_verify_default_key_prompt = do + 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 + +encrypt_file :: Assertion +encrypt_file = + 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 bob_pub_fpr 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 +encrypt_stream :: Assertion +encrypt_stream = + 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 bob_pub_fpr NoSecret + + -- Create pipe + (pipeRead, pipeWrite) <- createPipe + + -- Write to pipe + -- Add plaintext content + let testString = take (1000) $ repeat '.' + _ <- 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 * 1) + + -- 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,60 @@ +{-# LANGUAGE OverloadedStrings #-} +module CtxTest (tests) where + +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class (lift) +import qualified Data.ByteString as BS +import Control.Exception (catch, fromException) +import System.IO.Error (IOError, isUserError) + +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase) +import Test.HUnit + +import Crypto.Gpgme +import TestUtil + +tests :: [TestTree] +tests = [ testCase "run_action_with_ctx" run_action_with_ctx + , testCase "set_armor" set_armor + , testCase "unset_armor" unset_armor + , testCase "exception_safe" exception_safe + ] + +run_action_with_ctx :: Assertion +run_action_with_ctx = do + res <- withCtx "test/alice" "C" OpenPGP $ \_ -> + return "foo" :: IO BS.ByteString + res @?= "foo" + +set_armor :: Assertion +set_armor = do + let armorPrefix = "-----BEGIN PGP MESSAGE-----" + enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do + aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret + lift $ setArmor True bCtx + lift $ encrypt bCtx [aPubKey] NoFlag "plaintext" + (armorPrefix `BS.isPrefixOf` fromJustAndRight enc) @? ("Armored must start with " ++ show armorPrefix) + +unset_armor :: Assertion +unset_armor = do + let armorPrefix = "-----BEGIN PGP MESSAGE-----" + enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do + aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret + lift $ setArmor False bCtx + lift $ encrypt bCtx [aPubKey] NoFlag "plaintext" + (not $ armorPrefix `BS.isPrefixOf` fromJustAndRight enc) @? ("Binary must not start with " ++ show armorPrefix) + +-- Ensure that if an exception occurs then the expected exception type is returned so that we know +-- the context was freed +exception_safe :: Assertion +exception_safe = catch + ( 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 "all_gen_key_parameters" all_gen_key_parameters + , testCase "expire_date_days" expire_date_days + , testCase "expire_date_weeks" expire_date_weeks + , testCase "expire_date_months" expire_date_months + , testCase "expire_date_years" expire_date_years + , testCase "expire_date_seconds" expire_date_seconds + , testCase "creation_date_seconds" creation_date_seconds + , testCase "gen_key_no_travis" gen_key + , testCase "progress_callback_no_travis" progress_callback + ] + +-- 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 +all_gen_key_parameters :: Assertion +all_gen_key_parameters = + 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" + +gen_key :: Assertion +gen_key = do + tmpDir <- createTemporaryTestDir "gen_key" + + 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 +expire_date_days :: Assertion +expire_date_days = + 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" + +expire_date_weeks :: Assertion +expire_date_weeks = + 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" + +expire_date_months :: Assertion +expire_date_months = + 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" + +expire_date_years :: Assertion +expire_date_years = + 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" + +expire_date_seconds :: Assertion +expire_date_seconds = + 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" + +creation_date_seconds :: Assertion +creation_date_seconds = + 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" + +progress_callback :: Assertion +progress_callback = 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 + ((length $ lines contents) > 0) @? "No lines in progress file") + + -- Cleanup test + removeDirectoryRecursive tmpDir + assertBool ("Left was return value: " ++ show ret) (either (\_ -> False) (\_ -> 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,116 @@ +{-# 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 "get_alice_pub_from_alice" get_alice_pub_from_alice + , testCase "get_bob_pub_from_alice" get_bob_pub_from_alice + , testCase "alice_list_pub_keys" alice_list_pub_keys + , testCase "alice_list_secret_keys" alice_list_secret_keys + , testCase "get_inexistent_from_alice" get_inexistent_pub_from_alice + , testCase "check_alice_pub_user_ids" check_alice_pub_user_ids + , testCase "check_alice_pub_subkeys" check_alice_pub_subkeys + , testCase "remove_alice_key_prompt" remove_alice_key + ] + +get_alice_pub_from_alice :: Assertion +get_alice_pub_from_alice = do + withCtx "test/alice" "C" OpenPGP $ \ctx -> + do key <- getKey ctx alice_pub_fpr NoSecret + isJust key @? "missing " ++ show alice_pub_fpr + +get_bob_pub_from_alice :: Assertion +get_bob_pub_from_alice = do + withCtx "test/alice/" "C" OpenPGP $ \ctx -> + do key <- getKey ctx bob_pub_fpr NoSecret + isJust key @? "missing " ++ show bob_pub_fpr + +alice_list_pub_keys :: Assertion +alice_list_pub_keys = 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 + +alice_list_secret_keys :: Assertion +alice_list_secret_keys = do + withCtx "test/alice" "C" OpenPGP $ \ctx -> + do keys <- listKeys ctx WithSecret + length keys @?= 1 + +get_inexistent_pub_from_alice :: Assertion +get_inexistent_pub_from_alice = do + let inexistent_fpr = "ABCDEF" + withCtx "test/alice/" "C" OpenPGP $ \ctx -> + do key <- getKey ctx inexistent_fpr NoSecret + isNothing key @? "existing " ++ show inexistent_fpr + +check_alice_pub_user_ids :: Assertion +check_alice_pub_user_ids = do + withCtx "test/alice" "C" OpenPGP $ \ctx -> + do Just key <- getKey ctx alice_pub_fpr NoSecret + let uids = keyUserIds key + length uids @?= 1 + let kuid = head uids + uid = keyuserId kuid + keyuserValidity kuid @?= ValidityUltimate + userId uid @?= "Alice (Test User A) " + userName uid @?= "Alice" + userEmail uid @?= "alice@email.com" + userComment uid @?= "Test User A" + +check_alice_pub_subkeys :: Assertion +check_alice_pub_subkeys = do + withCtx "test/alice" "C" OpenPGP $ \ctx -> + do Just key <- getKey ctx alice_pub_fpr NoSecret + let subs = keySubKeys key + length subs @?= 2 + let sub = head subs + subkeyAlgorithm sub @?= Rsa + subkeyLength sub @?= 2048 + subkeyKeyId sub @?= "6B9809775CF91391" + subkeyFpr sub @?= "3F10159E56ECB494ED42EFA36B9809775CF91391" + +remove_alice_key :: Assertion +remove_alice_key = do + tmpDir <- createTemporaryTestDir "remove_alice_key" + + -- Copy alice's key into temporary directory so we can safely remove it + let alice_tmpDir = tmpDir "alice" + createDirectory $ alice_tmpDir + alice_files <- listDirectory "test/alice" + mapM_ (\f -> copyFile ("test/alice" f) (tmpDir "alice" f)) + $ filter (\f -> (not $ isPrefixOf "S.gpg-agent" f) + && f /= "private-keys-v1.d" + && f /= ".gpg-v21-migrated" + && f /= "random_seed" + ) alice_files + + withCtx (tmpDir "alice") "C" OpenPGP $ \ctx -> + do key <- getKey ctx alice_pub_fpr WithSecret + start_num <- listKeys ctx WithSecret >>= \l -> return $ length l + start_num @?= 1 + ret <- removeKey ctx (fromJust key) WithSecret + end_num <- listKeys ctx WithSecret >>= \l -> return $ length l + end_num @?= 0 + ret @?= Nothing + + -- Cleanup test + removeDirectoryRecursive tmpDir diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,15 +2,17 @@ import Test.Tasty (defaultMain, testGroup) -import KeyTest -import CtxTest -import CryptoTest +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,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module TestUtil where + +import qualified Data.ByteString as BS +import Data.Maybe (fromJust) +import Test.QuickCheck +import System.FilePath (()) +import System.Directory ( getTemporaryDirectory + , createDirectoryIfMissing + , removeDirectoryRecursive + , doesDirectoryExist + ) + + +alice_pub_fpr :: BS.ByteString +alice_pub_fpr = "EAACEB8A" + +bob_pub_fpr :: BS.ByteString +bob_pub_fpr = "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) . maybe (Left undefined) id + +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 + tmp_check <- doesDirectoryExist tmpDir + if tmp_check + then removeDirectoryRecursive tmpDir + else return () + -- Create temporary directory + createDirectoryIfMissing True tmpDir + return tmpDir