h-gpgme 0.5.1.0 → 0.6.0.0
raw patch · 18 files changed
+353/−321 lines, 18 filesdep ~HUnitdep ~bindings-gpgmedep ~tasty
Dependency ranges changed: HUnit, bindings-gpgme, tasty, tasty-hunit, tasty-quickcheck
Files
- .gitignore +5/−0
- .travis.yml +0/−36
- CHANGELOG.markdown +17/−0
- LICENSE +1/−1
- README.markdown +4/−1
- h-gpgme.cabal +9/−10
- src/Crypto/Gpgme.hs +3/−0
- src/Crypto/Gpgme/Crypto.hs +10/−17
- src/Crypto/Gpgme/Ctx.hs +7/−6
- src/Crypto/Gpgme/Internal.hs +7/−1
- src/Crypto/Gpgme/Key.hs +46/−21
- src/Crypto/Gpgme/Key/Gen.hs +13/−14
- src/Crypto/Gpgme/Types.hs +9/−3
- test/CryptoTest.hs +84/−86
- test/CtxTest.hs +28/−28
- test/KeyGenTest.hs +41/−41
- test/KeyTest.hs +60/−46
- test/TestUtil.hs +9/−10
.gitignore view
@@ -9,3 +9,8 @@ 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
− .travis.yml
@@ -1,36 +0,0 @@-# 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}
CHANGELOG.markdown view
@@ -1,5 +1,22 @@ # Changelog +## 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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014 Reto Hablützel+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
README.markdown view
@@ -1,4 +1,7 @@-[](https://hackage.haskell.org/package/h-gpgme) [](https://travis-ci.org/rethab/h-gpgme)+[](https://hackage.haskell.org/package/h-gpgme) +[](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml)++ h-gpgme: High Level Haskell Bindings for GnuPG Made Easy ========================================================
h-gpgme.cabal view
@@ -1,12 +1,12 @@ Name: h-gpgme-Version: 0.5.1.0+Version: 0.6.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@protonmail.ch-Copyright: (c) Reto Habluetzel 2018+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==7.10.3@@ -17,7 +17,6 @@ CHANGELOG.markdown README.markdown .gitignore- .travis.yml source-repository head@@ -36,7 +35,7 @@ , Crypto.Gpgme.Internal , Crypto.Gpgme.Types build-depends: base == 4.*- , bindings-gpgme >= 0.1.6 && <0.2+ , bindings-gpgme >= 0.1.8 && <0.2 , bytestring >= 0.9 , transformers >= 0.4.1 && <0.6 , time >= 1.4 && <2.0@@ -65,10 +64,10 @@ , temporary , exceptions - , HUnit >= 1.2 && <1.4- , tasty >= 0.10 && <1.0- , tasty-quickcheck >= 0.8 && <1.0- , tasty-hunit >= 0.9 && <1.0+ , HUnit+ , tasty+ , tasty-quickcheck+ , tasty-hunit , QuickCheck other-modules: Crypto.Gpgme , Crypto.Gpgme.Crypto
src/Crypto/Gpgme.hs view
@@ -49,9 +49,12 @@ -- * Keys , Key+ , importKeyFromFile , getKey , listKeys , removeKey+ , RemoveKeyFlags(..)+ -- * Information about keys , Validity (..) , PubKeyAlgo (..)
src/Crypto/Gpgme/Crypto.hs view
@@ -26,7 +26,6 @@ import Bindings.Gpgme import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8-import Control.Monad (liftM) import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, mapExceptT) import Foreign import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)@@ -53,7 +52,7 @@ encryptSign' = encryptIntern' encryptSign orElse :: Monad m => m (Maybe a) -> e -> ExceptT e m a-orElse action err = ExceptT $ maybe (Left err) return `liftM` action+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)@@ -89,7 +88,7 @@ -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) -encryptIntern enc_op (Ctx {_ctx=ctxPtr}) recPtrs flag plain = do+encryptIntern enc_op Ctx {_ctx=ctxPtr} recPtrs flag plain = do -- init buffer with plaintext plainBufPtr <- malloc BS.useAsCString plain $ \bs -> do@@ -145,7 +144,7 @@ -> Fd -- ^ Plaintext data -> Fd -- ^ Ciphertext data -> IO (Either [InvalidKey] ())-encryptFdIntern enc_op (Ctx {_ctx=ctxPtr}) recPtrs flag (Fd plainCInt) (Fd cipherCInt) = do+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@@ -171,7 +170,7 @@ let res = if recPtr /= nullPtr then Left (collectFprs recPtr)- else Right (())+ else Right () free cipherBufPtr @@ -218,7 +217,7 @@ -> Ctx -> Encrypted -> IO (Either DecryptError Plain)-decryptIntern dec_op (Ctx {_ctx=ctxPtr}) cipher = do+decryptIntern dec_op Ctx {_ctx=ctxPtr} cipher = do -- init buffer with cipher cipherBufPtr <- malloc BS.useAsCString cipher $ \bs -> do@@ -263,7 +262,7 @@ -> Fd -> Fd -> IO (Either DecryptError ())-decryptFdIntern dec_op (Ctx {_ctx=ctxPtr}) (Fd cipherCInt) (Fd plainCInt)= do+decryptFdIntern dec_op Ctx {_ctx=ctxPtr} (Fd cipherCInt) (Fd plainCInt)= do -- Initialize ciphertext buffer cipherBufPtr <- malloc _ <- c'gpgme_data_new_from_fd cipherBufPtr cipherCInt@@ -281,7 +280,7 @@ let res = if errcode /= noError then Left (toDecryptError errcode)- else Right (())+ else Right () free cipherBufPtr free plainBufPtr@@ -307,7 +306,7 @@ -> SignMode -> Plain -> IO (Either [InvalidKey] Encrypted)-signIntern sign_op (Ctx {_ctx=ctxPtr}) signPtrs mode plain = do+signIntern sign_op Ctx {_ctx=ctxPtr} signPtrs mode plain = do -- init buffer with plaintext plainBufPtr <- malloc BS.useAsCString plain $ \bs -> do@@ -324,7 +323,7 @@ ctx <- peek ctxPtr -- add signing keys- _ <- mapM ( \kForPtr -> withForeignPtr (unKey kForPtr)+ mapM_ ( \kForPtr -> withForeignPtr (unKey kForPtr) (\kPtr -> do k <- peek kPtr c'gpgme_signers_add ctx k@@ -419,7 +418,7 @@ -> Signature -> BS.ByteString -> IO (Either GpgmeError (VerificationResult, a))-verifyInternal ver_op (Ctx {_ctx=ctxPtr}) sig dat = do+verifyInternal ver_op Ctx {_ctx=ctxPtr} sig dat = do -- init buffer with signature sigBufPtr <- malloc BS.useAsCString sig $ \bs -> do@@ -452,9 +451,3 @@ free datBufPtr return res'--newDataBuffer :: IO (Ptr C'gpgme_data_t)-newDataBuffer = do- resultBufPtr <- malloc- checkError "data_new" =<< c'gpgme_data_new resultBufPtr- return resultBufPtr
src/Crypto/Gpgme/Ctx.hs view
@@ -4,6 +4,7 @@ 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@@ -52,7 +53,7 @@ -- | Free a previously created 'Ctx' freeCtx :: Ctx -> IO ()-freeCtx (Ctx {_ctx=ctxPtr}) =+freeCtx Ctx {_ctx=ctxPtr} = do ctx <- peek ctxPtr c'gpgme_release ctx free ctxPtr@@ -83,13 +84,13 @@ -- | Sets armor output on ctx setArmor :: Bool -> Ctx -> IO ()-setArmor armored (Ctx {_ctx = ctxPtr}) = do+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+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@@ -126,7 +127,7 @@ hint' <- peekCString hint info' <- peekCString info result <- callback hint' info' (prev_bad /= 0)- let phrase = maybe "" id result+ 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)@@ -148,7 +149,7 @@ setPassphraseCallback :: Ctx -- ^ context -> Maybe PassphraseCb -- ^ a callback, or Nothing to disable -> IO ()-setPassphraseCallback (Ctx {_ctx=ctxPtr}) callback = do+setPassphraseCallback Ctx {_ctx=ctxPtr} callback = do ctx <- peek ctxPtr let mode = case callback of Nothing -> c'GPGME_PINENTRY_MODE_DEFAULT@@ -182,7 +183,7 @@ setProgressCallback :: Ctx -- ^ context -> Maybe ProgressCb -> IO ()-setProgressCallback (Ctx {_ctx=ctxPtr}) callback = do+setProgressCallback Ctx {_ctx=ctxPtr} callback = do ctx <- peek ctxPtr cb <- maybe (return nullFunPtr) progressCb callback c'gpgme_set_progress_cb ctx cb nullPtr
src/Crypto/Gpgme/Internal.hs view
@@ -3,7 +3,7 @@ import Bindings.Gpgme import Control.Monad (unless) import qualified Data.ByteString as BS-import Foreign (allocaBytes, castPtr, nullPtr, peek)+import Foreign (allocaBytes, castPtr, nullPtr, peek, Ptr, malloc) import Foreign.C.String (peekCString) import Foreign.C.Types (CUInt, CInt) import System.IO.Unsafe (unsafePerformIO)@@ -109,3 +109,9 @@ | n == c'GPGME_PK_DSA = Dsa | n == c'GPGME_PK_ELG = Elg | otherwise = error "toPubKeyAlgo: Unrecognized public key algorithm"++newDataBuffer :: IO (Ptr C'gpgme_data_t)+newDataBuffer = do+ resultBufPtr <- malloc+ checkError "data_new" =<< c'gpgme_data_new resultBufPtr+ return resultBufPtr
src/Crypto/Gpgme/Key.hs view
@@ -1,5 +1,6 @@ module Crypto.Gpgme.Key ( getKey+ , importKeyFromFile , listKeys , removeKey -- * Information about keys@@ -17,6 +18,7 @@ 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@@ -30,7 +32,7 @@ listKeys :: Ctx -- ^ context to operate in -> IncludeSecret -- ^ whether to include the secrets -> IO [Key]-listKeys (Ctx {_ctx=ctxPtr}) secret = do+listKeys Ctx {_ctx=ctxPtr} secret = do peek ctxPtr >>= \ctx -> c'gpgme_op_keylist_start ctx nullPtr (fromSecret secret) >>= checkError "listKeys" let eof = 16383@@ -51,7 +53,7 @@ -> Fpr -- ^ fingerprint -> IncludeSecret -- ^ whether to include secrets when searching for the key -> IO (Maybe Key)-getKey (Ctx {_ctx=ctxPtr}) fpr secret = do+getKey Ctx {_ctx=ctxPtr} fpr secret = do key <- allocKey ret <- BS.useAsCString fpr $ \cFpr -> peek ctxPtr >>= \ctx ->@@ -61,25 +63,47 @@ 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- -> IncludeSecret -- ^ include secret keys for deleting+ -> RemoveKeyFlags -- ^ flags for remove operation -> IO (Maybe GpgmeError)-removeKey (Ctx {_ctx=ctxPtr}) key secret = do+removeKey Ctx {_ctx=ctxPtr} key flags = do ctx <- peek ctxPtr ret <- withKeyPtr key (\keyPtr -> do k <- peek keyPtr- c'gpgme_op_delete ctx k s)+ c'gpgme_op_delete_ext ctx k cFlags) if ret == 0 then return Nothing else return $ Just $ GpgmeError ret where- s = secretToCInt secret- secretToCInt :: IncludeSecret -> CInt- secretToCInt WithSecret = 1- secretToCInt NoSecret = 0+ 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@@ -98,8 +122,8 @@ readKeySignatures p0 = peekList c'_gpgme_key_sig'next p0 >>= mapM readSig where readSig sig =- KeySig <$> pure (toPubKeyAlgo $ c'_gpgme_key_sig'pubkey_algo sig)- <*> peekCString (c'_gpgme_key_sig'keyid 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@@ -141,9 +165,9 @@ where readKeyUserId :: C'_gpgme_user_id -> IO KeyUserId readKeyUserId uid =- KeyUserId <$> pure (toValidity $ c'_gpgme_user_id'validity uid)- <*> userId'- <*> readKeySignatures (c'_gpgme_user_id'signatures uid)+ (KeyUserId (toValidity $ c'_gpgme_user_id'validity uid)+ <$> userId')+ <*> readKeySignatures (c'_gpgme_user_id'signatures uid) where userId' :: IO UserId userId' =@@ -174,13 +198,14 @@ where readSubKey :: C'_gpgme_subkey -> IO SubKey readSubKey sub =- 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'fpr sub)- <*> pure (readTime $ c'_gpgme_subkey'timestamp sub)- <*> pure (readTime $ c'_gpgme_subkey'expires sub)- <*> orNull peekCString (c'_gpgme_subkey'card_number 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
src/Crypto/Gpgme/Key/Gen.hs view
@@ -45,7 +45,6 @@ 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@@ -88,7 +87,7 @@ Nothing Nothing Nothing "" "" "" "" "" -- | Key-Length parameter-data BitSize = BitSize Int+newtype BitSize = BitSize Int -- | Bit size constrained to 1024-4096 bits bitSize :: Int -> Either String BitSize@@ -132,16 +131,16 @@ | CreationS Positive -- ^ Seconds since epoch -- | Only a positive Int-data Positive = Positive { unPositive :: 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)+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+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@@ -158,9 +157,9 @@ -- | Used by 'genKey' generate a XML string for GPG toParamsString :: GenKeyParams -> BS.ByteString-toParamsString params = (BSC8.unlines . filter ((/=)""))+toParamsString params = (BSC8.unlines . filter ("" /=)) [ "<GnupgKeyParms format=\"internal\">"- , "Key-Type: " <> (maybe "default" keyTypeToString $ keyType params)+ , "Key-Type: " <> maybe "default" keyTypeToString (keyType params) , maybeLine "Key-Length: " keyLengthToString $ keyLength params , addLabel "Key-Grip: " $ keyGrip params , maybeLine "Key-Usage: " keyUsageListToString $ keyUsage params@@ -201,18 +200,18 @@ 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]+ 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 (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))+ 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))+ BSC8.pack ("seconds=" ++ show (unPositive p)) creationDateToString (CreationT t) = BSC8.pack $ formatTime defaultTimeLocale "%Y%m%dT%H%M%S" t
src/Crypto/Gpgme/Types.hs view
@@ -2,7 +2,7 @@ import Bindings.Gpgme import qualified Data.ByteString as BS-import Data.Maybe(catMaybes)+import Data.Maybe (mapMaybe) import Foreign import qualified Foreign.Concurrent as FC import Foreign.C.String (peekCString)@@ -67,7 +67,7 @@ -- | Translate the gpgme_sigsum_t bit vector to a list of SignatureSummary toSignatureSummaries :: C'gpgme_sigsum_t -> [SignatureSummary]-toSignatureSummaries x = catMaybes $ map (\(mask, val) -> if mask .&. x == 0 then Nothing else Just val)+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)@@ -101,7 +101,7 @@ -- | Perform an action with the pointer to a 'Key' withKeyPtr :: Key -> (Ptr C'gpgme_key_t -> IO a) -> IO a-withKeyPtr (Key fPtr) f = withForeignPtr fPtr f+withKeyPtr (Key fPtr) = withForeignPtr fPtr -- | Whether to include secret keys when searching data IncludeSecret =@@ -170,3 +170,9 @@ -- | h-gpgme exception for wrapping exception which occur outside of the control of h-gpgme newtype HgpgmeException = HgpgmeException SomeException deriving (Show) instance Exception HgpgmeException++-- | Flags for removeKey function+data RemoveKeyFlags = RemoveKeyFlags {+ allowSecret :: Bool -- ^ if False, only public keys are removed, otherwise secret keys are removed as well+ , force :: Bool -- ^ if True, don't ask for confirmation+ } deriving (Show, Eq, Ord)
test/CryptoTest.hs view
@@ -4,7 +4,7 @@ import System.IO import System.IO.Temp import System.Posix.IO-import Control.Monad (liftM, when)+import Control.Monad (when) import Control.Monad.Trans.Maybe import Control.Monad.IO.Class import Control.Monad.Catch@@ -20,33 +20,31 @@ import Test.QuickCheck.Monadic import Crypto.Gpgme-import Crypto.Gpgme.Types ( GpgmeError (GpgmeError)- , SignMode ( Clear, Detach, Normal )- )+import Crypto.Gpgme.Types ( GpgmeError (GpgmeError) ) 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 "bobEncryptForAliceDecryptPromptNoCi"+ $ bobEncryptForAliceDecrypt False+ , testProperty "bobEncryptSignForAliceDecryptVerifyPromptNoCi"+ $ bobEncryptSignForAliceDecryptVerify 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+ , testProperty "bobEncryptForAliceDecryptShortPromptNoCi"+ bobEncryptForAliceDecryptShort+ , testProperty "bobEncryptSignForAliceDecryptVerifyShortPromptNoCi"+ bobEncryptSignForAliceDecryptVerifyShort - , 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+ , 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@@ -55,15 +53,15 @@ 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+ [ 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 . liftM (either (const Nothing) Just)+hush = MaybeT . fmap (either (const Nothing) Just) withPassphraseCb :: String -> Ctx -> IO () withPassphraseCb passphrase ctx = do@@ -71,15 +69,15 @@ where callback _ _ _ = return (Just passphrase) -bob_encrypt_for_alice_decrypt :: Bool -> Plain -> Property-bob_encrypt_for_alice_decrypt passphrCb plain =+bobEncryptForAliceDecrypt :: Bool -> Plain -> Property+bobEncryptForAliceDecrypt passphrCb plain = not (BS.null plain) ==> monadicIO $ do- dec <- run encr_and_decr+ dec <- run encrAndDecr assert $ dec == plain- where encr_and_decr =+ where encrAndDecr = do -- encrypt Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret hush $ encrypt bCtx [aPubKey] NoFlag plain -- decrypt@@ -89,29 +87,29 @@ return $ fromRight dec -bob_encrypt_for_alice_decrypt_short :: Plain -> Property-bob_encrypt_for_alice_decrypt_short plain =+bobEncryptForAliceDecryptShort :: Plain -> Property+bobEncryptForAliceDecryptShort plain = not (BS.null plain) ==> monadicIO $ do- dec <- run encr_and_decr+ dec <- run encrAndDecr assert $ dec == plain- where encr_and_decr =+ where encrAndDecr = do -- encrypt- enc <- encrypt' "test/bob" alice_pub_fpr plain+ enc <- encrypt' "test/bob" alicePubFpr 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 =+bobEncryptSignForAliceDecryptVerify :: Bool -> Plain -> Property+bobEncryptSignForAliceDecryptVerify passphrCb plain = not (BS.null plain) ==> monadicIO $ do- dec <- run encr_and_decr+ dec <- run encrAndDecr assert $ dec == plain- where encr_and_decr =+ where encrAndDecr = do -- encrypt Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret hush $ encryptSign bCtx [aPubKey] NoFlag plain -- decrypt@@ -121,35 +119,35 @@ return $ fromRight dec -bob_encrypt_sign_for_alice_decrypt_verify_short :: Plain -> Property-bob_encrypt_sign_for_alice_decrypt_verify_short plain =+bobEncryptSignForAliceDecryptVerifyShort :: Plain -> Property+bobEncryptSignForAliceDecryptVerifyShort plain = not (BS.null plain) ==> monadicIO $ do- dec <- run encr_and_decr+ dec <- run encrAndDecr assert $ dec == plain- where encr_and_decr =+ where encrAndDecr = do -- encrypt- enc <- encryptSign' "test/bob" alice_pub_fpr plain+ enc <- encryptSign' "test/bob" alicePubFpr plain -- decrypt dec <- decryptVerify' "test/alice" (fromRight enc) return $ fromRight dec -encrypt_wrong_key :: Assertion-encrypt_wrong_key = do+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) -decrypt_garbage :: Assertion-decrypt_garbage = do+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 -bob_encrypt_symmetrically :: Assertion-bob_encrypt_symmetrically = do+bobEncryptSymmetrically :: Assertion+bobEncryptSymmetrically = do -- encrypt cipher <- fmap fromRight $@@ -164,47 +162,47 @@ 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+bobDetachSignAndVerifySpecifyKeyPrompt :: Assertion+bobDetachSignAndVerifySpecifyKeyPrompt = do resVerify <- withCtx "test/bob/" "C" OpenPGP $ \ctx -> do- key <- getKey ctx bob_pub_fpr NoSecret+ key <- getKey ctx bobPubFpr NoSecret let msgToSign = "Clear text message from bob!!"- resSign <-sign ctx [(fromJust key)] Detach msgToSign+ 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+bobClearSignAndVerifySpecifyKeyPrompt :: Assertion+bobClearSignAndVerifySpecifyKeyPrompt = 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"+ 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 -bob_clear_sign_and_verify_default_key_prompt :: Assertion-bob_clear_sign_and_verify_default_key_prompt = do+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 -bob_normal_sign_and_verify_specify_key_prompt :: Assertion-bob_normal_sign_and_verify_specify_key_prompt = do+bobNormalSignAndVerifySpecifyKeyPrompt :: Assertion+bobNormalSignAndVerifySpecifyKeyPrompt = 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"+ 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 -bob_normal_sign_and_verify_default_key_prompt :: Assertion-bob_normal_sign_and_verify_default_key_prompt = do+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 -encrypt_file :: Assertion-encrypt_file =+encryptFile :: Assertion+encryptFile = withCtx "test/bob/" "C" OpenPGP $ \ctx -> do withPassphraseCb "bob123" ctx withTestTmpFiles $ \pp ph cp ch dp dh -> do@@ -212,14 +210,14 @@ cipherFd <- handleToFd ch decryptedFd <- handleToFd dh - key <- getKey ctx bob_pub_fpr NoSecret+ 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 ())+ resEnc <- encryptFd ctx [fromJust key] NoFlag plainFd cipherFd+ if resEnc == Right () then return () else assertFailure $ show resEnc @@ -229,7 +227,7 @@ -- Decrypt ciphertext resDec <- decryptFd ctx cipherFd' decryptedFd- if (resDec == Right ())+ if resDec == Right () then return () else assertFailure $ show resDec @@ -239,8 +237,8 @@ plaintext @=? decryptedtext -- Encrypt from FD pipe into a FD file-encrypt_stream :: Assertion-encrypt_stream =+encryptStream :: Assertion+encryptStream = withCtx "test/bob/" "C" OpenPGP $ \ctx -> do withPassphraseCb "bob123" ctx withTestTmpFiles $ \_ _ cp ch dp dh -> do@@ -249,14 +247,14 @@ decryptedFd <- handleToFd dh -- Use bob's key- key <- getKey ctx bob_pub_fpr NoSecret+ key <- getKey ctx bobPubFpr NoSecret -- Create pipe (pipeRead, pipeWrite) <- createPipe -- Write to pipe -- Add plaintext content- let testString = take (1000) $ repeat '.'+ let testString = replicate 1000 '.' _ <- forkIO $ do threadWaitWrite pipeWrite _ <- fdWrite pipeWrite testString@@ -265,11 +263,11 @@ -- Start encrypting in thread _ <- forkIO $ do threadWaitRead pipeRead- _ <- encryptFd ctx [(fromJust key)] NoFlag pipeRead cipherFd+ _ <- encryptFd ctx [fromJust key] NoFlag pipeRead cipherFd closeFd pipeRead -- Wait a second for threads to finish- threadDelay (1000 * 1000 * 1)+ threadDelay (1000 * 1000) -- Check result -- Recreate the cipher FD because it is closed (or something) from the encrypt command@@ -279,7 +277,7 @@ -- Decrypt ciphertext resDec <- decryptFd ctx cipherFd' decryptedFd- if (resDec == Right ())+ if resDec == Right () then return () else assertFailure $ show resDec @@ -302,8 +300,8 @@ -- 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 (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@@ -311,8 +309,8 @@ -- 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 (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
test/CtxTest.hs view
@@ -6,7 +6,7 @@ import qualified Data.ByteString as BS import Data.Maybe (fromMaybe) import Control.Exception (catch, fromException)-import System.IO.Error (IOError, isUserError)+import System.IO.Error (isUserError) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase)@@ -16,67 +16,67 @@ 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 "no_set_listing_mode" no_set_listing_mode- , testCase "set_listing_mode" set_listing_mode- , testCase "exception_safe" exception_safe+tests = [ testCase "runActionWithCtx" runActionWithCtx+ , testCase "setArmor" setArmor'+ , testCase "unsetArmor" unsetArmor+ , testCase "noSetListingMode" noSetListingMode+ , testCase "setListingMode" setListingMode+ , testCase "exceptionSafe" exceptionSafe ] -run_action_with_ctx :: Assertion-run_action_with_ctx = do+runActionWithCtx :: Assertion+runActionWithCtx = do res <- withCtx "test/alice" "C" OpenPGP $ \_ -> return "foo" :: IO BS.ByteString res @?= "foo" -set_armor :: Assertion-set_armor = do+setArmor' :: Assertion+setArmor' = do let armorPrefix = "-----BEGIN PGP MESSAGE-----" enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ 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) -unset_armor :: Assertion-unset_armor = do+unsetArmor :: Assertion+unsetArmor = do let armorPrefix = "-----BEGIN PGP MESSAGE-----" enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ 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)+ not (armorPrefix `BS.isPrefixOf` fromJustAndRight enc) @? ("Binary must not start with " ++ show armorPrefix) -no_set_listing_mode :: Assertion-no_set_listing_mode = do+noSetListingMode :: Assertion+noSetListingMode = do sigs <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret kuids <- lift $ keyUserIds' aPubKey return $ concatMap keyuserSignatures kuids let sigs' = fromMaybe [] sigs- (length sigs' == 0) @? ("There should be no signatures, but there are some")+ null sigs' @? "There should be no signatures, but there are some" -set_listing_mode :: Assertion-set_listing_mode = do+setListingMode :: Assertion+setListingMode = do sigs <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do lift $ setKeyListingMode [KeyListingLocal, KeyListingSigs] bCtx- aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret+ aPubKey <- MaybeT $ getKey bCtx alicePubFpr NoSecret kuids <- lift $ keyUserIds' aPubKey return $ concatMap keyuserSignatures kuids let sigs' = fromMaybe [] sigs- (length sigs' > 0) @? ("There should be some signatures, but there are non")+ 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-exception_safe :: Assertion-exception_safe = catch+exceptionSafe :: Assertion+exceptionSafe = catch ( do res <- withCtx "test/alice" "C" OpenPGP $ \_ ->- (ioError $ userError "Busted") >>+ ioError (userError "Busted") >> return "foo" :: IO BS.ByteString res @?= "foo") ( \(HgpgmeException e) -> do- let mioe = (fromException e) :: Maybe IOError+ let mioe = fromException e :: Maybe IOError maybe (assertFailure $ show mioe) (\ioe -> isUserError ioe @?= True) mioe )
test/KeyGenTest.hs view
@@ -25,15 +25,15 @@ 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+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@@ -42,8 +42,8 @@ errorOnLeft (Left s) = error s -- Test parameter list generation for generating keys-all_gen_key_parameters :: Assertion-all_gen_key_parameters =+allGenKeyParameters :: Assertion+allGenKeyParameters = let params = (def :: G.GenKeyParams) -- G.defaultGenKeyParams { G.keyType = Just Dsa , G.keyLength = Just $ errorOnLeft $ G.bitSize 1024@@ -67,7 +67,7 @@ , G.keyserver = "https://keyserver.com/" , G.handle = "Key handle here" }- in (G.toParamsString params) @?=+ in G.toParamsString params @?= "<GnupgKeyParms format=\"internal\">\n\ \Key-Type: DSA\n\ \Key-Length: 1024\n\@@ -87,9 +87,9 @@ \Handle: Key handle here\n\ \</GnupgKeyParms>\n" -gen_key :: Assertion-gen_key = do- tmpDir <- createTemporaryTestDir "gen_key"+genKey :: Assertion+genKey = do+ tmpDir <- createTemporaryTestDir "genKey" ret <- withCtx tmpDir "C" OpenPGP $ \ctx -> do let params = (def :: G.GenKeyParams)@@ -109,87 +109,87 @@ -- Cleanup temporary directory removeDirectoryRecursive tmpDir either- (\(l) -> assertFailure $ "Left was return value " ++ (show l))- (\(r) -> assertBool ("Fingerprint ("- ++ (unpack r)+ (\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 =+expireDateDays :: Assertion+expireDateDays = let (Just p) = G.toPositive 10 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireD p }- in (G.toParamsString params) @?=+ in G.toParamsString params @?= "<GnupgKeyParms format=\"internal\">\n\ \Key-Type: default\n\ \Expire-Date: 10d\n\ \</GnupgKeyParms>\n" -expire_date_weeks :: Assertion-expire_date_weeks =+expireDateWeeks :: Assertion+expireDateWeeks = let (Just p) = G.toPositive 10 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireW p }- in (G.toParamsString params) @?=+ in G.toParamsString params @?= "<GnupgKeyParms format=\"internal\">\n\ \Key-Type: default\n\ \Expire-Date: 10w\n\ \</GnupgKeyParms>\n" -expire_date_months :: Assertion-expire_date_months =+expireDateMonths :: Assertion+expireDateMonths = let (Just p) = G.toPositive 10 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireM p }- in (G.toParamsString params) @?=+ in G.toParamsString params @?= "<GnupgKeyParms format=\"internal\">\n\ \Key-Type: default\n\ \Expire-Date: 10m\n\ \</GnupgKeyParms>\n" -expire_date_years :: Assertion-expire_date_years =+expireDateYears :: Assertion+expireDateYears = let (Just p) = G.toPositive 10 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireY p }- in (G.toParamsString params) @?=+ in G.toParamsString params @?= "<GnupgKeyParms format=\"internal\">\n\ \Key-Type: default\n\ \Expire-Date: 10y\n\ \</GnupgKeyParms>\n" -expire_date_seconds :: Assertion-expire_date_seconds =+expireDateSeconds :: Assertion+expireDateSeconds = let (Just p) = G.toPositive 123456 params = (def :: G.GenKeyParams) { G.expireDate = Just $ G.ExpireS p }- in (G.toParamsString params) @?=+ in G.toParamsString params @?= "<GnupgKeyParms format=\"internal\">\n\ \Key-Type: default\n\ \Expire-Date: seconds=123456\n\ \</GnupgKeyParms>\n" -creation_date_seconds :: Assertion-creation_date_seconds =+creationDateSeconds :: Assertion+creationDateSeconds = let (Just p) = G.toPositive 123456 params = (def :: G.GenKeyParams) { G.creationDate = Just $ G.CreationS p }- in (G.toParamsString params) @?=+ in G.toParamsString params @?= "<GnupgKeyParms format=\"internal\">\n\ \Key-Type: default\n\ \Creation-Date: seconds=123456\n\ \</GnupgKeyParms>\n" -progress_callback :: Assertion-progress_callback = do+progressCallback :: Assertion+progressCallback = do tmpDir <- createTemporaryTestDir "progress_callback" -- Setup context@@ -220,9 +220,9 @@ -- 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")+ not (null (lines contents)) @? "No lines in progress file") -- Cleanup test removeDirectoryRecursive tmpDir- assertBool ("Left was return value: " ++ show ret) (either (\_ -> False) (\_ -> True) genRet)- return $ ret+ assertBool ("Left was return value: " ++ show ret) (either (const False) (const True) genRet)+ return ret
test/KeyTest.hs view
@@ -18,30 +18,32 @@ 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+tests = [ testCase "getAlicePubFromAlice" getAlicePubFromAlice+ , testCase "getBobPubFromAlice" getBobPubFromAlice+ , testCase "aliceListPubKeys" aliceListPubKeys+ , testCase "aliceListSecretKeys" aliceListSecretKeys+ , testCase "getInexistentFromAlice" getInexistentPubFromAlice+ , testCase "checkAlicePubUserIds" checkAlicePubUserIds+ , testCase "checkAlicePubSubkeys" checkAlicePubSubkeys+ , testCase "removeAliceKey" removeAliceKey+ , testCase "readFromFileWorks" readFromFileWorks+ , testCase "readFromFileDoesn'tExist" readFromFileDoesn'tExist ] -get_alice_pub_from_alice :: Assertion-get_alice_pub_from_alice = do+getAlicePubFromAlice :: Assertion+getAlicePubFromAlice = do withCtx "test/alice" "C" OpenPGP $ \ctx ->- do key <- getKey ctx alice_pub_fpr NoSecret- isJust key @? "missing " ++ show alice_pub_fpr+ do key <- getKey ctx alicePubFpr NoSecret+ isJust key @? "missing " ++ show alicePubFpr -get_bob_pub_from_alice :: Assertion-get_bob_pub_from_alice = do+getBobPubFromAlice :: Assertion+getBobPubFromAlice = do withCtx "test/alice/" "C" OpenPGP $ \ctx ->- do key <- getKey ctx bob_pub_fpr NoSecret- isJust key @? "missing " ++ show bob_pub_fpr+ do key <- getKey ctx bobPubFpr NoSecret+ isJust key @? "missing " ++ show bobPubFpr -alice_list_pub_keys :: Assertion-alice_list_pub_keys = do+aliceListPubKeys :: Assertion+aliceListPubKeys = do withCtx "test/alice" "C" OpenPGP $ \ctx -> do keys <- listKeys ctx NoSecret length keys @?= 2@@ -49,23 +51,23 @@ ["6B9809775CF91391","3BA69AA2EAACEB8A"]] map (map subkeyKeyId . keySubKeys) keys @?= keyIds -alice_list_secret_keys :: Assertion-alice_list_secret_keys = do+aliceListSecretKeys :: Assertion+aliceListSecretKeys = 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"+getInexistentPubFromAlice :: Assertion+getInexistentPubFromAlice = do+ let inexistentFpr = "ABCDEF" withCtx "test/alice/" "C" OpenPGP $ \ctx ->- do key <- getKey ctx inexistent_fpr NoSecret- isNothing key @? "existing " ++ show inexistent_fpr+ do key <- getKey ctx inexistentFpr NoSecret+ isNothing key @? "existing " ++ show inexistentFpr -check_alice_pub_user_ids :: Assertion-check_alice_pub_user_ids = do+checkAlicePubUserIds :: Assertion+checkAlicePubUserIds = do withCtx "test/alice" "C" OpenPGP $ \ctx ->- do Just key <- getKey ctx alice_pub_fpr NoSecret+ do Just key <- getKey ctx alicePubFpr NoSecret let uids = keyUserIds key length uids @?= 1 let kuid = head uids@@ -76,10 +78,10 @@ userEmail uid @?= "alice@email.com" userComment uid @?= "Test User A" -check_alice_pub_subkeys :: Assertion-check_alice_pub_subkeys = do+checkAlicePubSubkeys :: Assertion+checkAlicePubSubkeys = do withCtx "test/alice" "C" OpenPGP $ \ctx ->- do Just key <- getKey ctx alice_pub_fpr NoSecret+ do Just key <- getKey ctx alicePubFpr NoSecret let subs = keySubKeys key length subs @?= 2 let sub = head subs@@ -88,29 +90,41 @@ subkeyKeyId sub @?= "6B9809775CF91391" subkeyFpr sub @?= "3F10159E56ECB494ED42EFA36B9809775CF91391" -remove_alice_key :: Assertion-remove_alice_key = do- tmpDir <- createTemporaryTestDir "remove_alice_key"+removeAliceKey :: Assertion+removeAliceKey = do+ tmpDir <- createTemporaryTestDir "removeAliceKey" -- 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"+ let aliceTmpDir = tmpDir </> "alice"+ createDirectory aliceTmpDir+ aliceFiles <- listDirectory "test/alice" mapM_ (\f -> copyFile ("test/alice" </> f) (tmpDir </> "alice" </> f))- $ filter (\f -> (not $ isPrefixOf "S.gpg-agent" f)+ $ filter (\f -> not ("S.gpg-agent" `isPrefixOf` f) && f /= "private-keys-v1.d" && f /= ".gpg-v21-migrated"- && f /= "random_seed"- ) alice_files+ && f /= "randomSeed"+ ) aliceFiles 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+ do key <- getKey ctx alicePubFpr WithSecret+ startNum <- listKeys ctx WithSecret >>= \l -> return $ length l+ startNum @?= 1+ ret <- removeKey ctx (fromJust key) (RemoveKeyFlags True True)+ endNum <- listKeys ctx WithSecret >>= \l -> return $ length l+ endNum @?= 0 ret @?= Nothing -- Cleanup test removeDirectoryRecursive tmpDir++readFromFileWorks :: Assertion+readFromFileWorks = do+ withCtx "test/real-person" "C" OpenPGP $ \ctx -> do+ mRet <- importKeyFromFile ctx "test/real-person/real-person.key"+ mRet @?= Nothing++readFromFileDoesn'tExist :: Assertion+readFromFileDoesn'tExist = do+ withCtx "test/real-person" "C" OpenPGP $ \ctx -> do+ mRet <- importKeyFromFile ctx "this-file-doesn't-exist"+ isJust mRet @? "shouldn't be able to read this file"
test/TestUtil.hs view
@@ -3,7 +3,8 @@ module TestUtil where import qualified Data.ByteString as BS-import Data.Maybe (fromJust)+import Control.Monad (when)+import Data.Maybe (fromJust, fromMaybe) import Test.QuickCheck import System.FilePath ((</>)) import System.Directory ( getTemporaryDirectory@@ -13,11 +14,11 @@ ) -alice_pub_fpr :: BS.ByteString-alice_pub_fpr = "EAACEB8A"+alicePubFpr :: BS.ByteString+alicePubFpr = "EAACEB8A" -bob_pub_fpr :: BS.ByteString-bob_pub_fpr = "6C4FB8F2"+bobPubFpr :: BS.ByteString+bobPubFpr = "6C4FB8F2" -- Orphan instance here! Because this is only a test, orphans are probably OK. -- http://stackoverflow.com/a/3081367/350221@@ -25,7 +26,7 @@ arbitrary = fmap BS.pack arbitrary justAndRight :: Maybe (Either a b) -> Bool-justAndRight = either (const False) (const True) . maybe (Left undefined) id+justAndRight = either (const False) (const True) . fromMaybe (Left undefined) fromJustAndRight :: (Show a) => Maybe (Either a b) -> b fromJustAndRight = fromRight . fromJust@@ -45,10 +46,8 @@ 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 ()+ tmpCheck <- doesDirectoryExist tmpDir+ when tmpCheck $ removeDirectoryRecursive tmpDir -- Create temporary directory createDirectoryIfMissing True tmpDir return tmpDir