diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -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} diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,4 +1,7 @@ -[![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) +[![Hackage](https://img.shields.io/hackage/v/h-gpgme.svg)](https://hackage.haskell.org/package/h-gpgme) +[![CI](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml/badge.svg)](https://github.com/rethab/h-gpgme/actions/workflows/ci.yml) +![MIT License](https://img.shields.io/github/license/rethab/h-gpgme?label=license) + h-gpgme: High Level Haskell Bindings for GnuPG Made Easy ======================================================== diff --git a/h-gpgme.cabal b/h-gpgme.cabal --- a/h-gpgme.cabal +++ b/h-gpgme.cabal @@ -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 diff --git a/src/Crypto/Gpgme.hs b/src/Crypto/Gpgme.hs --- a/src/Crypto/Gpgme.hs +++ b/src/Crypto/Gpgme.hs @@ -49,9 +49,12 @@ -- * Keys , Key + , importKeyFromFile , getKey , listKeys , removeKey + , RemoveKeyFlags(..) + -- * Information about keys , Validity (..) , PubKeyAlgo (..) 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 @@ -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 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 @@ -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 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 @@ -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 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,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 diff --git a/src/Crypto/Gpgme/Key/Gen.hs b/src/Crypto/Gpgme/Key/Gen.hs --- a/src/Crypto/Gpgme/Key/Gen.hs +++ b/src/Crypto/Gpgme/Key/Gen.hs @@ -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 ("" /=)) [ "" - , "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 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 @@ -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) diff --git a/test/CryptoTest.hs b/test/CryptoTest.hs --- a/test/CryptoTest.hs +++ b/test/CryptoTest.hs @@ -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 diff --git a/test/CtxTest.hs b/test/CtxTest.hs --- a/test/CtxTest.hs +++ b/test/CtxTest.hs @@ -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 ) diff --git a/test/KeyGenTest.hs b/test/KeyGenTest.hs --- a/test/KeyGenTest.hs +++ b/test/KeyGenTest.hs @@ -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 @?= "\n\ \Key-Type: DSA\n\ \Key-Length: 1024\n\ @@ -87,9 +87,9 @@ \Handle: Key handle here\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: 10d\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: 10w\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: 10m\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: 10y\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Expire-Date: seconds=123456\n\ \\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 @?= "\n\ \Key-Type: default\n\ \Creation-Date: seconds=123456\n\ \\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 diff --git a/test/KeyTest.hs b/test/KeyTest.hs --- a/test/KeyTest.hs +++ b/test/KeyTest.hs @@ -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" diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -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