diff --git a/h-gpgme.cabal b/h-gpgme.cabal --- a/h-gpgme.cabal +++ b/h-gpgme.cabal @@ -1,15 +1,15 @@ Name: h-gpgme -Version: 0.2.0.0 +Version: 0.3.0.0 Description: High Level Binding for GnuPG Made Easy (gpgme) License: MIT License-file: LICENSE Author: Reto Habluetzel Maintainer: rethab@rethab.ch -Copyright: (c) Reto Habluetzel 2014 -Author: Reto Habluetzel 2014 +Copyright: (c) Reto Habluetzel 2015 +Author: Reto Habluetzel 2015 Homepage: https://github.com/rethab/h-gpgme Bug-reports: https://github.com/rethab/h-gpgme/issues -Tested-With: GHC==7.8.2 +Tested-With: GHC==7.8.3 Category: Cryptography Build-Type: Simple Cabal-Version: >=1.10 @@ -30,8 +30,10 @@ , Crypto.Gpgme.Internal , Crypto.Gpgme.Types build-depends: base == 4.* - , bindings-gpgme >= 0.1 && <0.2 + , bindings-gpgme >= 0.1.6 && <0.2 , bytestring >= 0.9 + , either >= 4.3 && <5.0 + , time >= 1.4 && <2.0 , unix >= 2.5 default-language: Haskell2010 @@ -43,12 +45,15 @@ hs-source-dirs: src, test main-is: Main.hs build-depends: base == 4.* - , bindings-gpgme >= 0.1 && <0.2 + , bindings-gpgme >= 0.1.6 && <0.2 , bytestring >= 0.9 + , either >= 4.3 && <5.0 + , transformers >= 0.3 && <0.5 + , time >= 1.4 && <2.0 , unix >= 2.5 - , HUnit == 1.2.* - , test-framework == 0.8.* - , test-framework-quickcheck2 == 0.3.* - , test-framework-hunit == 0.3.* + , HUnit >= 1.2 && <1.3 + , tasty >= 0.10 && <1.0 + , tasty-quickcheck >= 0.8 && <1.0 + , tasty-hunit >= 0.9 && <1.0 , QuickCheck diff --git a/src/Crypto/Gpgme.hs b/src/Crypto/Gpgme.hs --- a/src/Crypto/Gpgme.hs +++ b/src/Crypto/Gpgme.hs @@ -1,7 +1,7 @@ -- | -- Module : Crypto.Gpgme --- Copyright : (c) Reto Hablützel 2014 +-- Copyright : (c) Reto Hablützel 2015 -- License : MIT -- -- Maintainer : rethab@rethab.ch @@ -19,16 +19,16 @@ -- -- == Example (from the tests): -- --- >let alice_pub_fpr = "EAACEB8A" --- > --- >-- encrypt --- >enc <- withCtx "test/bob" "C" openPGP $ \bCtx -> --- > withKey bCtx alice_pub_fpr noSecret $ \aPubKey -> --- > encrypt bCtx [aPubKey] noFlag plain +-- >let alice_pub_fpr = "EAACEB8A" +-- > +-- >Just enc <- withCtx "test/bob" "C" OpenPGP $ \bCtx -> runMaybeT $ do +-- > aPubKey <- MaybeT $ getKey bCtx alice_pub_fpr NoSecret +-- > fromRight $ encrypt bCtx [aPubKey] NoFlag plain +-- > +-- >-- decrypt +-- >dec <- withCtx "test/alice" "C" OpenPGP $ \aCtx -> +-- > decrypt aCtx enc -- > --- >-- decrypt --- >dec <- withCtx "test/alice" "C" openPGP $ \aCtx -> --- > decrypt aCtx (fromJustAndRight enc) -- module Crypto.Gpgme ( @@ -37,7 +37,11 @@ , newCtx , freeCtx , withCtx - , withArmor + , setArmor + -- ** Passphrase callbacks + , isPassphraseCbSupported + , PassphraseCb + , setPassphraseCallback -- currently not exported as it does not work as expected: -- , withPWCtx @@ -45,8 +49,16 @@ -- * Keys , Key , getKey - , freeKey - , withKey + , listKeys + -- * Information about keys + , Validity (..) + , PubKeyAlgo (..) + , KeySignature (..) + , UserId (..) + , KeyUserId (..) + , keyUserIds + , SubKey (..) + , keySubKeys -- * Encryption , encrypt @@ -58,7 +70,12 @@ , decryptVerify , decryptVerify' - -- * Other Types + -- * Error handling + , GpgmeError + , errorString + , sourceString + + -- * Other Types , Fpr , Encrypted , Plain 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 @@ -13,7 +13,10 @@ import Bindings.Gpgme import qualified Data.ByteString as BS +import Control.Monad (liftM) +import Control.Monad.Trans.Either import Foreign +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import GHC.Ptr import Crypto.Gpgme.Ctx @@ -36,17 +39,16 @@ encryptSign' :: String -> Fpr -> Plain -> IO (Either String Encrypted) encryptSign' = encryptIntern' encryptSign +orElse :: Monad m => m (Maybe a) -> e -> EitherT e m a +orElse action err = EitherT $ maybe (Left err) return `liftM` action + encryptIntern' :: (Ctx -> [Key] -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) ) -> String -> Fpr -> Plain -> IO (Either String Encrypted) encryptIntern' encrFun gpgDir recFpr plain = - withCtx gpgDir locale OpenPGP $ \ctx -> - do mbRes <- withKey ctx recFpr NoSecret $ \pubKey -> - encrFun ctx [pubKey] NoFlag plain - return $ mapErr mbRes - where mapErr Nothing = Left $ "no such key: " ++ show recFpr - mapErr (Just (Left err)) = Left (show err) - mapErr (Just (Right res)) = Right res + withCtx gpgDir locale OpenPGP $ \ctx -> runEitherT $ + do pubKey <- getKey ctx recFpr NoSecret `orElse` ("no such key: " ++ show recFpr) + bimapEitherT show id $ EitherT $ encrFun ctx [pubKey] NoFlag plain -- | encrypt for a list of recipients encrypt :: Ctx -> [Key] -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) @@ -68,7 +70,7 @@ -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) -encryptIntern enc_op (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 @@ -82,17 +84,12 @@ resultBufPtr <- newDataBuffer resultBuf <- peek resultBufPtr - -- null terminated array of recipients - recArray <- if null recPtrs - then return nullPtr - else do keys <- mapM (peek . unKey) recPtrs - newArray (keys ++ [nullPtr]) - ctx <- peek ctxPtr -- encrypt - checkError "op_encrypt" =<< enc_op ctx recArray (fromFlag flag) - plainBuf resultBuf + withKeyPtrArray recPtrs $ \recArray -> + checkError "op_encrypt" =<< enc_op ctx recArray (fromFlag flag) + plainBuf resultBuf free plainBufPtr -- check whether all keys could be used for encryption @@ -108,6 +105,13 @@ return res +-- | Build a null-terminated array of pointers from a list of 'Key's +withKeyPtrArray :: [Key] -> (Ptr C'gpgme_key_t -> IO a) -> IO a +withKeyPtrArray [] f = f nullPtr +withKeyPtrArray keys f = do + arr <- newArray0 nullPtr =<< mapM (peek . unsafeForeignPtrToPtr . unKey) keys + f arr + -- | Convenience wrapper around 'withCtx' and 'withKey' to -- decrypt a single ciphertext with its homedirectory. decrypt' :: String -> Encrypted -> IO (Either DecryptError Plain) @@ -143,7 +147,7 @@ -> Ctx -> Encrypted -> IO (Either DecryptError Plain) -decryptIntern dec_op (Ctx ctxPtr _) cipher = do +decryptIntern dec_op (Ctx {_ctx=ctxPtr}) cipher = do -- init buffer with cipher cipherBufPtr <- malloc BS.useAsCString cipher $ \bs -> do 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 @@ -1,6 +1,8 @@ module Crypto.Gpgme.Ctx where import Bindings.Gpgme +import Control.Monad (when) +import Data.List (isPrefixOf) import Foreign import Foreign.C.String import Foreign.C.Types @@ -22,11 +24,15 @@ version <- c'gpgme_check_version nullPtr >>= peekCString -- create context - ctxPtr <- malloc + ctxPtr <- malloc checkError "gpgme_new" =<< c'gpgme_new ctxPtr ctx <- peek ctxPtr + -- find engine version + engInfo <- c'gpgme_ctx_get_engine_info ctx >>= peek + engVersion <- peekCString $ c'_gpgme_engine_info'version engInfo + -- set locale locale <- newCString localeStr checkError "set_locale" =<< c'gpgme_set_locale ctx lcCtype locale @@ -39,13 +45,13 @@ checkError "set_engine_info" =<< c'gpgme_ctx_set_engine_info ctx (fromProtocol protocol) nullPtr homedirPtr - return (Ctx ctxPtr version) + return (Ctx ctxPtr version protocol engVersion) where lcCtype :: CInt lcCtype = 0 -- | Free a previously created 'Ctx' freeCtx :: Ctx -> IO () -freeCtx (Ctx ctxPtr _) = +freeCtx (Ctx {_ctx=ctxPtr}) = do ctx <- peek ctxPtr c'gpgme_release ctx free ctxPtr @@ -64,16 +70,74 @@ freeCtx ctx return res --- | Sets the produced output to be ASCII armored --- --- Inject between `withCtx' and your 'IO a' like +-- | Sets armor output on ctx +setArmor :: Bool -> Ctx -> IO () +setArmor armored (Ctx {_ctx = ctxPtr}) = do + ctx <- peek ctxPtr + c'gpgme_set_armor ctx (if armored then 1 else 0) + +-- | Are passphrase callbacks supported? -- --- > withCtx homedir locale OpenPGP $ withArmor $ \ctx -> --- > withKey ctx fpr NoSecret $ \pubkey -> --- > encrypt ctx [pubkey] NoFlag plaintext +-- This functionality is known to be broken in some gpg versions, +-- see 'setPassphraseCb' for details. +isPassphraseCbSupported :: Ctx -> Bool +isPassphraseCbSupported ctx + | OpenPGP <- _protocol ctx = + case () of + _ | "2.0" `isPrefixOf` ver -> False + | "1." `isPrefixOf` ver -> False + | otherwise -> True + | otherwise = True -- give the user the benefit of a doubt + where + ver = _engineVersion ctx -withArmor :: (Ctx -> IO a) -> Ctx -> IO a -withArmor f ctx = do - cctx <- peek $ _ctx ctx - c'gpgme_set_armor cctx 1 - f ctx +-- | A callback invoked when the engine requires a passphrase to +-- proceed. The callback should return @Just@ the requested passphrase, +-- or @Nothing@ to cancel the operation. +type PassphraseCb = + String -- ^ user ID hint + -> String -- ^ passphrase info + -> Bool -- ^ @True@ if the previous attempt was bad + -> IO (Maybe String) + +-- | Construct a passphrase callback, handling reporting of the +-- passphrase back to gpgme. +passphraseCb :: PassphraseCb -> IO C'gpgme_passphrase_cb_t +passphraseCb callback = do + let go _ hint info prev_bad fd = do + hint' <- peekCString hint + info' <- peekCString info + result <- callback hint' info' (prev_bad /= 0) + let phrase = maybe "" id result + err <- withCStringLen (phrase++"\n") $ \(s,len) -> + c'gpgme_io_writen fd (castPtr s) (fromIntegral len) + when (err /= 0) $ checkError "passphraseCb" (fromIntegral err) + return $ maybe errCanceled (const 0) result + errCanceled = 99 -- TODO: Use constant + mk'gpgme_passphrase_cb_t go + +-- | Set the callback invoked when a passphrase is required from the user. +-- +-- Note that the operation of this feature is a bit inconsistent between +-- GPG versions. GPG 1.4 using the @use-agent@ option and GPG >= 2.1 require +-- that the @gpg-agent@ for the session has the @allow-loopback-pinentry@ +-- option enabled (this can be achieved by adding @allow-loopback-pinentry@ +-- to @gpg-agent.conf@. GPG versions between 2.0 and 2.1 do not support the +-- @--pinentry-mode@ option necessary for this support. +-- +-- See +-- and the @gpgme-tool@ example included in the @gpgme@ tree for details. +setPassphraseCallback :: Ctx -- ^ context + -> Maybe PassphraseCb -- ^ a callback, or Nothing to disable + -> IO () +setPassphraseCallback (Ctx {_ctx=ctxPtr}) callback = do + ctx <- peek ctxPtr + let mode = case callback of + Nothing -> c'GPGME_PINENTRY_MODE_DEFAULT + Just _ -> c'GPGME_PINENTRY_MODE_LOOPBACK + -- With GPG 1.4 using the use-agent option and >= GPG 2.0 the passphrase + -- callback won't have an opportunity to execute unless the loopback + -- pinentry-mode is used + c'gpgme_set_pinentry_mode ctx mode >>= checkError "setPassphraseCallback" + cb <- maybe (return nullFunPtr) passphraseCb callback + c'gpgme_set_passphrase_cb ctx cb nullPtr 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 @@ -25,7 +25,7 @@ _ <- c'gpgme_data_seek dat' 0 seekSet go dat' where go :: C'gpgme_data_t -> IO BS.ByteString - go dat = allocaBytes 1 $ \buf -> + go dat = allocaBytes 1 $ \buf -> do read_bytes <- c'gpgme_data_read dat buf 1 if read_bytes == 1 then do byte <- peek (castPtr buf) @@ -42,7 +42,7 @@ srcstr <- c'gpgme_strsource gpgme_err src <- peekCString srcstr error ("Fun: " ++ fun ++ - ", Error: " ++ str ++ + ", Error: " ++ str ++ ", Source: " ++ show src) noError :: Num a => a @@ -61,3 +61,23 @@ fromFlag :: Flag -> CUInt fromFlag AlwaysTrust = c'GPGME_ENCRYPT_ALWAYS_TRUST fromFlag NoFlag = 0 + +toValidity :: C'gpgme_validity_t -> Validity +toValidity n + | n == c'GPGME_VALIDITY_UNKNOWN = ValidityUnknown + | n == c'GPGME_VALIDITY_UNDEFINED = ValidityUndefined + | n == c'GPGME_VALIDITY_NEVER = ValidityNever + | n == c'GPGME_VALIDITY_MARGINAL = ValidityMarginal + | n == c'GPGME_VALIDITY_FULL = ValidityFull + | n == c'GPGME_VALIDITY_ULTIMATE = ValidityUltimate + | otherwise = error "validityFromInt: Unrecognized trust validity" + +toPubKeyAlgo :: C'gpgme_pubkey_algo_t -> PubKeyAlgo +toPubKeyAlgo n + | n == c'GPGME_PK_RSA = Rsa + | n == c'GPGME_PK_RSA_E = RsaE + | n == c'GPGME_PK_RSA_S = RsaS + | n == c'GPGME_PK_ELG_E = ElgE + | n == c'GPGME_PK_DSA = Dsa + | n == c'GPGME_PK_ELG = Elg + | otherwise = error "toPubKeyAlgo: Unrecognized public key algorithm" 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,52 +1,166 @@ module Crypto.Gpgme.Key ( getKey - , freeKey - , withKey + , listKeys + -- * Information about keys + , Validity (..) + , PubKeyAlgo (..) + , KeySignature (..) + , UserId (..) + , KeyUserId (..) + , keyUserIds + , SubKey (..) + , keySubKeys ) where import Bindings.Gpgme +import Control.Applicative import qualified Data.ByteString as BS +import Data.Time.Clock +import Data.Time.Clock.POSIX import Foreign +import Foreign.C +import System.IO.Unsafe import Crypto.Gpgme.Types import Crypto.Gpgme.Internal +-- | Returns a list of known 'Key's from the @context@. +listKeys :: Ctx -- ^ context to operate in + -> IncludeSecret -- ^ whether to include the secrets + -> IO [Key] +listKeys (Ctx {_ctx=ctxPtr}) secret = do + peek ctxPtr >>= \ctx -> + c'gpgme_op_keylist_start ctx nullPtr (fromSecret secret) >>= checkError "listKeys" + let eof = 16383 + go accum = do + key <- allocKey + ret <- peek ctxPtr >>= \ctx -> + withKeyPtr key $ c'gpgme_op_keylist_next ctx + code <- c'gpgme_err_code ret + case ret of + _ | ret == noError -> go (key : accum) + | code == eof -> return accum + | otherwise -> checkError "listKeys" ret >> return [] + go [] + -- | Returns a 'Key' from the @context@ based on its @fingerprint@. --- As a 'Key' returned from the function needs to be freed --- with 'freeKey', the use of 'withKey' is encouraged. Returns --- Nothing if no 'Key' with this 'Fpr' exists. +-- Returns 'Nothing' if no 'Key' with this 'Fpr' exists. getKey :: Ctx -- ^ context to operate in -> Fpr -- ^ fingerprint -> IncludeSecret -- ^ whether to include secrets when searching for the key -> IO (Maybe Key) -getKey (Ctx ctxPtr _) fpr secret = do - keyPtr <- malloc +getKey (Ctx {_ctx=ctxPtr}) fpr secret = do + key <- allocKey ret <- BS.useAsCString fpr $ \cFpr -> peek ctxPtr >>= \ctx -> - c'gpgme_get_key ctx cFpr keyPtr (fromSecret secret) + withKeyPtr key $ \keyPtr -> + c'gpgme_get_key ctx cFpr keyPtr (fromSecret secret) if ret == noError - then return . Just . Key $ keyPtr - else free keyPtr >> return Nothing + then return . Just $ key + else return Nothing --- | Frees a key previously created with 'getKey' -freeKey :: Key -> IO () -freeKey (Key keyPtr) = free keyPtr +-- | A key signature +data KeySignature = KeySig { keysigAlgorithm :: PubKeyAlgo + , keysigKeyId :: String + , keysigTimestamp :: Maybe UTCTime + , keysigExpires :: Maybe UTCTime + , keysigUserId :: UserId + -- TODO: Notations + } --- | Conveniently runs the @action@ with the 'Key' associated --- with the 'Fpr' in the 'Ctx' and frees it afterwards. --- If no 'Key' with this 'Fpr' exists, Nothing is returned. +readTime :: CLong -> Maybe UTCTime +readTime (-1) = Nothing +readTime 0 = Nothing +readTime t = Just $ posixSecondsToUTCTime $ realToFrac t -withKey :: Ctx -- ^ context to operate in - -> Fpr -- ^ fingerprint - -> IncludeSecret -- ^ whether to include secrets when searching for the key - -> (Key -> IO a) -- ^ action to be run with key - -> IO (Maybe a) -withKey ctx fpr is f = do - mbkey <- getKey ctx fpr is - case mbkey of - Just key -> do res <- f key - freeKey key - return (Just res) - Nothing -> return Nothing +readKeySignatures :: C'gpgme_key_sig_t -> IO [KeySignature] +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) + <*> pure (readTime $ c'_gpgme_key_sig'timestamp sig) + <*> pure (readTime $ c'_gpgme_key_sig'expires sig) + <*> signerId + where + signerId :: IO UserId + signerId = + UserId <$> peekCString (c'_gpgme_key_sig'uid sig) + <*> peekCString (c'_gpgme_key_sig'name sig) + <*> peekCString (c'_gpgme_key_sig'email sig) + <*> peekCString (c'_gpgme_key_sig'comment sig) +-- | A user ID consisting of a name, comment, and email address. +data UserId = UserId { userId :: String + , userName :: String + , userEmail :: String + , userComment :: String + } + deriving (Ord, Eq, Show) +-- | A user ID +data KeyUserId = KeyUserId { keyuserValidity :: Validity + , keyuserId :: UserId + , keyuserSignatures :: [KeySignature] + } + +peekList :: Storable a => (a -> Ptr a) -> Ptr a -> IO [a] +peekList nextFunc = go [] + where + go accum p + | p == nullPtr = return accum + | otherwise = do v <- peek p + go (v : accum) (nextFunc v) + +keyUserIds' :: Key -> IO [KeyUserId] +keyUserIds' key = withForeignPtr (unKey key) $ \keyPtr -> do + key' <- peek keyPtr >>= peek + peekList c'_gpgme_user_id'next (c'_gpgme_key'uids key') >>= mapM readKeyUserId + where + readKeyUserId :: C'_gpgme_user_id -> IO KeyUserId + readKeyUserId uid = + KeyUserId <$> pure (toValidity $ c'_gpgme_user_id'validity uid) + <*> userId' + <*> readKeySignatures (c'_gpgme_user_id'signatures uid) + where + userId' :: IO UserId + userId' = + UserId <$> peekCString (c'_gpgme_user_id'uid uid) + <*> peekCString (c'_gpgme_user_id'name uid) + <*> peekCString (c'_gpgme_user_id'email uid) + <*> peekCString (c'_gpgme_user_id'comment uid) + +keyUserIds :: Key -> [KeyUserId] +keyUserIds = unsafePerformIO . keyUserIds' + +data SubKey = SubKey { subkeyAlgorithm :: PubKeyAlgo + , subkeyLength :: Int + , subkeyKeyId :: String + , subkeyFpr :: Fpr + , subkeyTimestamp :: Maybe UTCTime + , subkeyExpires :: Maybe UTCTime + , subkeyCardNumber :: Maybe String + } + +keySubKeys' :: Key -> IO [SubKey] +keySubKeys' key = withForeignPtr (unKey key) $ \keyPtr -> do + key' <- peek keyPtr >>= peek + peekList c'_gpgme_subkey'next (c'_gpgme_key'subkeys key') >>= mapM readSubKey + where + readSubKey :: C'_gpgme_subkey -> IO SubKey + readSubKey sub = + SubKey <$> pure (toPubKeyAlgo $ c'_gpgme_subkey'pubkey_algo sub) + <*> pure (fromIntegral $ c'_gpgme_subkey'length sub) + <*> peekCString (c'_gpgme_subkey'keyid sub) + <*> BS.packCString (c'_gpgme_subkey'keyid sub) + <*> pure (readTime $ c'_gpgme_subkey'timestamp sub) + <*> pure (readTime $ c'_gpgme_subkey'expires sub) + <*> orNull peekCString (c'_gpgme_subkey'card_number sub) + +orNull :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) +orNull f ptr + | ptr == nullPtr = return Nothing + | otherwise = Just <$> f ptr + +keySubKeys :: Key -> [SubKey] +keySubKeys = unsafePerformIO . keySubKeys' 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 @@ -3,6 +3,9 @@ import Bindings.Gpgme import qualified Data.ByteString as BS import Foreign +import qualified Foreign.Concurrent as FC +import Foreign.C.String (peekCString) +import System.IO.Unsafe (unsafePerformIO) -- | the protocol to be used in the crypto engine data Protocol = @@ -10,15 +13,18 @@ | GPGCONF | OpenPGP | UNKNOWN + deriving (Show, Eq, Ord) -- | Context to be passed around with operations. Use 'newCtx' or -- 'withCtx' in order to obtain an instance. data Ctx = Ctx { - _ctx :: Ptr C'gpgme_ctx_t - , _version :: String + _ctx :: Ptr C'gpgme_ctx_t -- ^ context + , _version :: String -- ^ GPGME version + , _protocol :: Protocol -- ^ context protocol + , _engineVersion :: String -- ^ engine version } --- | a fingerprint +-- | a fingerprint type Fpr = BS.ByteString -- | a plaintext @@ -32,27 +38,81 @@ -- TODO map intot better error code -- | A key from the context -newtype Key = Key { unKey :: Ptr C'gpgme_key_t } +newtype Key = Key { unKey :: ForeignPtr C'gpgme_key_t } +-- | Allocate a key +allocKey :: IO Key +allocKey = do + keyPtr <- malloc + let finalize = do + peek keyPtr >>= c'gpgme_key_unref + free keyPtr + Key `fmap` FC.newForeignPtr keyPtr finalize + +-- | Perform an action with the pointer to a 'Key' +withKeyPtr :: Key -> (Ptr C'gpgme_key_t -> IO a) -> IO a +withKeyPtr (Key fPtr) f = withForeignPtr fPtr f + -- | Whether to include secret keys when searching data IncludeSecret = WithSecret -- ^ do not include secret keys | NoSecret -- ^ include secret keys + deriving (Show, Eq, Ord) data Flag = AlwaysTrust | NoFlag + deriving (Show, Eq, Ord) +-- | A GPGME error. +-- +-- Errors in GPGME consist of two parts: a code indicating the nature of the fault, +-- and a source indicating from which subsystem the error originated. +newtype GpgmeError = GpgmeError C'gpgme_error_t + deriving (Show, Ord, Eq) + +-- | An explanatory string for a GPGME error. +errorString :: GpgmeError -> String +errorString (GpgmeError n) = + unsafePerformIO $ c'gpgme_strerror n >>= peekCString + +-- | An explanatory string describing the source of a GPGME error +sourceString :: GpgmeError -> String +sourceString (GpgmeError n) = + unsafePerformIO $ c'gpgme_strsource n >>= peekCString + -- | error indicating what went wrong in decryption data DecryptError = - NoData -- ^ no data to decrypt - | Failed -- ^ not a valid cipher - | BadPass -- ^ passphrase for secret was wrong - | Unknown Int -- ^ something else went wrong - deriving (Eq, Show) + NoData -- ^ no data to decrypt + | Failed -- ^ not a valid cipher + | BadPass -- ^ passphrase for secret was wrong + | Unknown GpgmeError -- ^ something else went wrong + deriving (Show, Eq, Ord) -toDecryptError :: C'gpgme_err_code_t -> DecryptError -toDecryptError 58 = NoData -toDecryptError 152 = Failed -toDecryptError 11 = BadPass -toDecryptError x = Unknown (fromIntegral x) +toDecryptError :: C'gpgme_error_t -> DecryptError +toDecryptError n = + case unsafePerformIO $ c'gpgme_err_code n of + 58 -> NoData + 152 -> Failed + 11 -> BadPass + x -> Unknown (GpgmeError x) + +-- | The validity of a user identity +data Validity = + ValidityUnknown + | ValidityUndefined + | ValidityNever + | ValidityMarginal + | ValidityFull + | ValidityUltimate + deriving (Show, Ord, Eq) + +-- | A public-key encryption algorithm +data PubKeyAlgo = + Rsa + | RsaE + | RsaS + | ElgE + | Dsa + | Elg + deriving (Show, Ord, Eq) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,14 +1,17 @@ module Main where -import Test.Framework (defaultMain, testGroup) +import Test.Tasty (defaultMain, testGroup) import KeyTest import CtxTest import CryptoTest main :: IO () -main = defaultMain - [ testGroup "key" KeyTest.tests - , testGroup "ctx" CtxTest.tests - , testGroup "crypto" CryptoTest.tests - ] +main = do + passphraseCbTests <- CryptoTest.cbTests + defaultMain $ testGroup "tests" + [ testGroup "key" KeyTest.tests + , testGroup "ctx" CtxTest.tests + , CryptoTest.tests + , passphraseCbTests + ]