diff --git a/h-gpgme.cabal b/h-gpgme.cabal --- a/h-gpgme.cabal +++ b/h-gpgme.cabal @@ -1,5 +1,5 @@ Name: h-gpgme -Version: 0.1.0.0 +Version: 0.2.0.0 Description: High Level Binding for GnuPG Made Easy (gpgme) License: MIT License-file: LICENSE @@ -38,6 +38,8 @@ test-suite tests type: exitcode-stdio-1.0 default-language: Haskell2010 + ghc-options: -Wall + -fhpc hs-source-dirs: src, test main-is: Main.hs build-depends: base == 4.* diff --git a/src/Crypto/Gpgme.hs b/src/Crypto/Gpgme.hs --- a/src/Crypto/Gpgme.hs +++ b/src/Crypto/Gpgme.hs @@ -37,6 +37,7 @@ , newCtx , freeCtx , withCtx + , withArmor -- currently not exported as it does not work as expected: -- , withPWCtx @@ -58,18 +59,17 @@ , decryptVerify' -- * Other Types - , Protocol - , openPGP + , Fpr + , Encrypted + , Plain + , Protocol(..) + , InvalidKey - , IncludeSecret - , noSecret - , secret + , IncludeSecret(..) - , Flag - , alwaysTrust - , noFlag + , Flag(..) , DecryptError(..) 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 @@ -39,10 +39,10 @@ encryptIntern' :: (Ctx -> [Key] -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) ) -> String -> Fpr -> Plain -> IO (Either String Encrypted) -encryptIntern' encrFun gpgDir recFpr plain = do - withCtx gpgDir locale openPGP $ \ctx -> - do mbRes <- withKey ctx recFpr noSecret $ \pubKey -> - encrFun ctx [pubKey] noFlag plain +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) @@ -68,19 +68,18 @@ -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) -encryptIntern enc_op (Ctx ctxPtr _) recPtrs (Flag flag) plain = do +encryptIntern enc_op (Ctx ctxPtr _) recPtrs flag plain = do -- init buffer with plaintext plainBufPtr <- malloc BS.useAsCString plain $ \bs -> do let copyData = 1 -- gpgme shall copy data, as bytestring will free it let plainlen = fromIntegral (BS.length plain) ret <- c'gpgme_data_new_from_mem plainBufPtr bs plainlen copyData - check_error "data_new_from_mem" ret + checkError "data_new_from_mem" ret plainBuf <- peek plainBufPtr -- init buffer for result - resultBufPtr <- malloc - check_error "data_new" =<< c'gpgme_data_new resultBufPtr + resultBufPtr <- newDataBuffer resultBuf <- peek resultBufPtr -- null terminated array of recipients @@ -92,7 +91,8 @@ ctx <- peek ctxPtr -- encrypt - check_error "op_encrypt" =<< enc_op ctx recArray flag plainBuf resultBuf + checkError "op_encrypt" =<< enc_op ctx recArray (fromFlag flag) + plainBuf resultBuf free plainBufPtr -- check whether all keys could be used for encryption @@ -123,7 +123,7 @@ -> Encrypted -> IO (Either DecryptError Plain) decryptInternal' decrFun gpgDir cipher = - withCtx gpgDir locale openPGP $ \ctx -> + withCtx gpgDir locale OpenPGP $ \ctx -> decrFun ctx cipher -- | Decrypts a ciphertext @@ -150,12 +150,11 @@ let copyData = 1 -- gpgme shall copy data, as bytestring will free it let cipherlen = fromIntegral (BS.length cipher) ret <- c'gpgme_data_new_from_mem cipherBufPtr bs cipherlen copyData - check_error "data_new_from_mem" ret + checkError "data_new_from_mem" ret cipherBuf <- peek cipherBufPtr -- init buffer for result - resultBufPtr <- malloc - check_error "data_new" =<< c'gpgme_data_new resultBufPtr + resultBufPtr <- newDataBuffer resultBuf <- peek resultBufPtr ctx <- peek ctxPtr @@ -171,3 +170,9 @@ free resultBufPtr 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,7 +4,6 @@ import Foreign import Foreign.C.String import Foreign.C.Types -import System.Posix.IO (fdWrite) import Crypto.Gpgme.Types import Crypto.Gpgme.Internal @@ -16,7 +15,7 @@ -> String -- ^ locale -> Protocol -- ^ protocol -> IO Ctx -newCtx homedir localeStr (Protocol protocol) = +newCtx homedir localeStr protocol = do homedirPtr <- newCString homedir -- check version: necessary for initialization!! @@ -24,20 +23,21 @@ -- create context ctxPtr <- malloc - check_error "gpgme_new" =<< c'gpgme_new ctxPtr + checkError "gpgme_new" =<< c'gpgme_new ctxPtr ctx <- peek ctxPtr -- set locale locale <- newCString localeStr - check_error "set_locale" =<< c'gpgme_set_locale ctx lcCtype locale + checkError "set_locale" =<< c'gpgme_set_locale ctx lcCtype locale -- set protocol in ctx - check_error "set_protocol" =<< c'gpgme_set_protocol ctx (fromIntegral protocol) + checkError "set_protocol" =<< c'gpgme_set_protocol ctx + (fromProtocol protocol) -- set homedir in ctx - check_error "set_engine_info" =<< c'gpgme_ctx_set_engine_info ctx - (fromIntegral protocol) nullPtr homedirPtr + checkError "set_engine_info" =<< c'gpgme_ctx_set_engine_info ctx + (fromProtocol protocol) nullPtr homedirPtr return (Ctx ctxPtr version) where lcCtype :: CInt @@ -64,29 +64,16 @@ freeCtx ctx return res -withPWCtx :: String -> String -> String -> Protocol -> (Ctx -> IO a) -> IO a -withPWCtx pw homedir localeStr prot f = do - ctx <- newCtx homedir localeStr prot - setPassphrase ctx pw - res <- f ctx - freeCtx ctx - return res - -setPassphrase :: Ctx -> String -> IO () -setPassphrase (Ctx ctxPtr _) passphrase = - do ctx <- peek ctxPtr - passcb <- wrap (passphrase_cb passphrase) - c'gpgme_set_passphrase_cb ctx passcb nullPtr - -passphrase_cb :: String -> Ptr () -> CString -> CString -> CInt -> CInt -> IO C'gpgme_error_t -passphrase_cb passphrase _ uid_hint passphrase_info prev_was_bad fd = - do peekCString uid_hint >>= putStrLn - peekCString passphrase_info >>= putStrLn - putStrLn ("Prev was bad: " ++ show prev_was_bad) - _ <- fdWrite (fromIntegral fd) (passphrase ++ "\n") - return 0 +-- | Sets the produced output to be ASCII armored +-- +-- Inject between `withCtx' and your 'IO a' like +-- +-- > withCtx homedir locale OpenPGP $ withArmor $ \ctx -> +-- > withKey ctx fpr NoSecret $ \pubkey -> +-- > encrypt ctx [pubkey] NoFlag plaintext --- from: http://www.haskell.org/haskellwiki/GHC/Using_the_FFI#Callbacks_into_Haskell_from_foreign_code -foreign import ccall "wrapper" - wrap :: (Ptr () -> CString -> CString -> CInt -> CInt -> IO C'gpgme_error_t) - -> IO (FunPtr (Ptr () -> CString -> CString -> CInt -> CInt -> IO C'gpgme_error_t)) +withArmor :: (Ctx -> IO a) -> Ctx -> IO a +withArmor f ctx = do + cctx <- peek $ _ctx ctx + c'gpgme_set_armor cctx 1 + f ctx 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 @@ -5,6 +5,7 @@ import qualified Data.ByteString as BS import Foreign (allocaBytes, castPtr, peek) import Foreign.C.String (peekCString) +import Foreign.C.Types (CUInt, CInt) import System.IO.Unsafe (unsafePerformIO) import Crypto.Gpgme.Types @@ -33,8 +34,8 @@ else return BS.empty seekSet = 0 -check_error :: String -> C'gpgme_error_t -> IO () -check_error fun gpgme_err = +checkError :: String -> C'gpgme_error_t -> IO () +checkError fun gpgme_err = unless (gpgme_err == noError) $ do errstr <- c'gpgme_strerror gpgme_err str <- peekCString errstr @@ -46,3 +47,17 @@ noError :: Num a => a noError = 0 + +fromProtocol :: (Num a) => Protocol -> a +fromProtocol CMS = c'GPGME_PROTOCOL_CMS +fromProtocol GPGCONF = c'GPGME_PROTOCOL_GPGCONF +fromProtocol OpenPGP = c'GPGME_PROTOCOL_OpenPGP +fromProtocol UNKNOWN = c'GPGME_PROTOCOL_UNKNOWN + +fromSecret :: IncludeSecret -> CInt +fromSecret WithSecret = 1 +fromSecret NoSecret = 0 + +fromFlag :: Flag -> CUInt +fromFlag AlwaysTrust = c'GPGME_ENCRYPT_ALWAYS_TRUST +fromFlag NoFlag = 0 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 @@ -19,11 +19,11 @@ -> Fpr -- ^ fingerprint -> IncludeSecret -- ^ whether to include secrets when searching for the key -> IO (Maybe Key) -getKey (Ctx ctxPtr _) fpr (IncludeSecret is) = do +getKey (Ctx ctxPtr _) fpr secret = do keyPtr <- malloc ret <- BS.useAsCString fpr $ \cFpr -> peek ctxPtr >>= \ctx -> - c'gpgme_get_key ctx cFpr keyPtr is + c'gpgme_get_key ctx cFpr keyPtr (fromSecret secret) if ret == noError then return . Just . Key $ keyPtr else free keyPtr >> return Nothing 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,15 +2,14 @@ import Bindings.Gpgme import qualified Data.ByteString as BS -import Foreign.C.Types (CInt, CUInt) import Foreign -- | the protocol to be used in the crypto engine -newtype Protocol = Protocol Int - -openPGP :: Protocol -openPGP = Protocol c'GPGME_PROTOCOL_OpenPGP --- TODO other protocols +data Protocol = + CMS + | GPGCONF + | OpenPGP + | UNKNOWN -- | Context to be passed around with operations. Use 'newCtx' or -- 'withCtx' in order to obtain an instance. @@ -19,8 +18,13 @@ , _version :: String } +-- | a fingerprint type Fpr = BS.ByteString + +-- | a plaintext type Plain = BS.ByteString + +-- | an ciphertext type Encrypted = BS.ByteString -- | The fingerprint and an error code @@ -31,23 +35,13 @@ newtype Key = Key { unKey :: Ptr C'gpgme_key_t } -- | Whether to include secret keys when searching -newtype IncludeSecret = IncludeSecret CInt - --- | do not consider secret keys when searching -noSecret :: IncludeSecret -noSecret = IncludeSecret 0 - --- | consider secret keys when searching -secret :: IncludeSecret -secret = IncludeSecret 1 - -newtype Flag = Flag CUInt - -alwaysTrust :: Flag -alwaysTrust = Flag c'GPGME_ENCRYPT_ALWAYS_TRUST +data IncludeSecret = + WithSecret -- ^ do not include secret keys + | NoSecret -- ^ include secret keys -noFlag :: Flag -noFlag = Flag 0 +data Flag = + AlwaysTrust + | NoFlag -- | error indicating what went wrong in decryption data DecryptError = diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,6 +6,7 @@ import CtxTest import CryptoTest +main :: IO () main = defaultMain [ testGroup "key" KeyTest.tests , testGroup "ctx" CtxTest.tests