h-gpgme 0.2.0.0 → 0.3.0.0
raw patch · 8 files changed
+392/−105 lines, 8 filesdep +eitherdep +tastydep +tasty-hunitdep −test-frameworkdep −test-framework-hunitdep −test-framework-quickcheck2dep ~bindings-gpgme
Dependencies added: either, tasty, tasty-hunit, tasty-quickcheck, time, transformers
Dependencies removed: test-framework, test-framework-hunit, test-framework-quickcheck2
Dependency ranges changed: bindings-gpgme
Files
- h-gpgme.cabal +15/−10
- src/Crypto/Gpgme.hs +31/−14
- src/Crypto/Gpgme/Crypto.hs +21/−17
- src/Crypto/Gpgme/Ctx.hs +78/−14
- src/Crypto/Gpgme/Internal.hs +22/−2
- src/Crypto/Gpgme/Key.hs +142/−28
- src/Crypto/Gpgme/Types.hs +74/−14
- test/Main.hs +9/−6
h-gpgme.cabal view
@@ -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
src/Crypto/Gpgme.hs view
@@ -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
src/Crypto/Gpgme/Crypto.hs view
@@ -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
src/Crypto/Gpgme/Ctx.hs view
@@ -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 <http://lists.gnupg.org/pipermail/gnupg-devel/2013-February/027345.html>+-- 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
src/Crypto/Gpgme/Internal.hs view
@@ -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"
src/Crypto/Gpgme/Key.hs view
@@ -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'
src/Crypto/Gpgme/Types.hs view
@@ -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)
test/Main.hs view
@@ -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+ ]