packages feed

h-gpgme (empty) → 0.1.0.0

raw patch · 10 files changed

+598/−0 lines, 10 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bindings-gpgme, bytestring, test-framework, test-framework-hunit, test-framework-quickcheck2, unix

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Reto Hablützel++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ h-gpgme.cabal view
@@ -0,0 +1,52 @@+Name:                h-gpgme+Version:             0.1.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+Homepage:            https://github.com/rethab/h-gpgme+Bug-reports:         https://github.com/rethab/h-gpgme/issues+Tested-With:         GHC==7.8.2+Category:            Cryptography+Build-Type:          Simple+Cabal-Version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/rethab/h-gpgme++library+  hs-source-dirs:      src+  ghc-options:         -Wall+                       -O2+                       -fno-warn-orphans+  exposed-modules:     Crypto.Gpgme+  other-modules:       Crypto.Gpgme.Key+                     , Crypto.Gpgme.Ctx+                     , Crypto.Gpgme.Crypto+                     , Crypto.Gpgme.Internal+                     , Crypto.Gpgme.Types+  build-depends:       base           == 4.*+                     , bindings-gpgme >= 0.1 && <0.2+                     , bytestring     >= 0.9+                     , unix           >= 2.5+  default-language:    Haskell2010++test-suite tests+  type:                exitcode-stdio-1.0+  default-language:    Haskell2010+  hs-source-dirs:      src, test+  main-is:             Main.hs+  build-depends:       base           == 4.*+                     , bindings-gpgme >= 0.1 && <0.2+                     , bytestring     >= 0.9+                     , unix           >= 2.5++                     , HUnit                      == 1.2.*+                     , test-framework             == 0.8.*+                     , test-framework-quickcheck2 == 0.3.*+                     , test-framework-hunit       == 0.3.*+                     , QuickCheck
+ src/Crypto/Gpgme.hs view
@@ -0,0 +1,82 @@++-- |+-- Module      : Crypto.Gpgme+-- Copyright   : (c) Reto Hablützel 2014+-- License     : MIT+--+-- Maintainer  : rethab@rethab.ch+-- Stability   : experimental+-- Portability : untested+--+-- High Level Binding for GnuPG Made Easy (gpgme)+-- +-- Most of these functions are a one-to-one translation+-- from GnuPG API with some Haskell idiomatics to make+-- the API more convenient.+--+-- See the GnuPG manual for more information: <https://www.gnupg.org/documentation/manuals/gpgme.pdf>+--+--+-- == 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+-- >+-- >-- decrypt+-- >dec <- withCtx "test/alice" "C" openPGP $ \aCtx ->+-- >        decrypt aCtx (fromJustAndRight enc)+--++module Crypto.Gpgme (+      -- * Context+      Ctx+    , newCtx+    , freeCtx+    , withCtx++    -- currently not exported as it does not work as expected:+    -- , withPWCtx+    +    -- * Keys+    , Key+    , getKey+    , freeKey+    , withKey++    -- * Encryption+    , encrypt+    , encryptSign+    , encrypt'+    , encryptSign'+    , decrypt+    , decrypt'+    , decryptVerify+    , decryptVerify'++      -- * Other Types+    , Protocol+    , openPGP++    , InvalidKey++    , IncludeSecret+    , noSecret+    , secret++    , Flag+    , alwaysTrust+    , noFlag++    , DecryptError(..)++) where+++import Crypto.Gpgme.Ctx+import Crypto.Gpgme.Crypto+import Crypto.Gpgme.Types+import Crypto.Gpgme.Key
+ src/Crypto/Gpgme/Crypto.hs view
@@ -0,0 +1,173 @@+module Crypto.Gpgme.Crypto (++      encrypt+    , encryptSign+    , encrypt'+    , encryptSign'+    , decrypt+    , decrypt'+    , decryptVerify+    , decryptVerify'++) where++import Bindings.Gpgme+import qualified Data.ByteString as BS+import Foreign+import GHC.Ptr++import Crypto.Gpgme.Ctx+import Crypto.Gpgme.Internal+import Crypto.Gpgme.Key+import Crypto.Gpgme.Types++locale :: String+locale = "C"++-- | Convenience wrapper around 'withCtx' and 'withKey' to+--   encrypt a single plaintext for a single recipient with+--   its homedirectory.+encrypt' :: String -> Fpr -> Plain -> IO (Either String Encrypted)+encrypt' = encryptIntern' encrypt++-- | Convenience wrapper around 'withCtx' and 'withKey' to+--   encrypt and sign a single plaintext for a single recipient+--   with its homedirectory.+encryptSign' :: String -> Fpr -> Plain -> IO (Either String Encrypted)+encryptSign' = encryptIntern' encryptSign++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+           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++-- | encrypt for a list of recipients+encrypt :: Ctx -> [Key] -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted)+encrypt = encryptIntern c'gpgme_op_encrypt++-- | encrypt and sign for a list of recipients+encryptSign :: Ctx -> [Key] -> Flag -> Plain -> IO (Either [InvalidKey] Encrypted) +encryptSign = encryptIntern c'gpgme_op_encrypt_sign++encryptIntern :: (C'gpgme_ctx_t+                    -> GHC.Ptr.Ptr C'gpgme_key_t+                    -> C'gpgme_encrypt_flags_t+                    -> C'gpgme_data_t+                    -> C'gpgme_data_t+                    -> IO C'gpgme_error_t+                  )+                  -> Ctx+                  -> [Key]+                  -> Flag+                  -> Plain+                  -> IO (Either [InvalidKey] Encrypted) +encryptIntern enc_op (Ctx ctxPtr _) recPtrs (Flag 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+    plainBuf <- peek plainBufPtr++    -- init buffer for result+    resultBufPtr <- malloc+    check_error "data_new" =<< c'gpgme_data_new resultBufPtr+    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+    check_error "op_encrypt" =<< enc_op ctx recArray flag plainBuf resultBuf+    free plainBufPtr++    -- check whether all keys could be used for encryption+    encResPtr <- c'gpgme_op_encrypt_result ctx+    encRes <- peek encResPtr+    let recPtr = c'_gpgme_op_encrypt_result'invalid_recipients encRes++    let res = if recPtr /= nullPtr+                then Left (collectFprs recPtr)+                else Right (collectResult resultBuf)++    free resultBufPtr++    return res++-- | Convenience wrapper around 'withCtx' and 'withKey' to+--   decrypt a single ciphertext with its homedirectory.+decrypt' :: String -> Encrypted -> IO (Either DecryptError Plain)+decrypt' = decryptInternal' decrypt++-- | Convenience wrapper around 'withCtx' and 'withKey' to+--   decrypt and verify a single ciphertext with its homedirectory.+decryptVerify' :: String -> Encrypted -> IO (Either DecryptError Plain)+decryptVerify' = decryptInternal' decryptVerify++decryptInternal' :: (Ctx -> Encrypted -> IO (Either DecryptError Plain))+                  -> String+                  -> Encrypted+                  -> IO (Either DecryptError Plain)+decryptInternal' decrFun gpgDir cipher =+    withCtx gpgDir locale openPGP $ \ctx ->+        decrFun ctx cipher++-- | Decrypts a ciphertext+decrypt :: Ctx -> Encrypted -> IO (Either DecryptError Plain)+decrypt = decryptIntern c'gpgme_op_decrypt++-- | Decrypts and verifies a ciphertext+decryptVerify :: Ctx -> Encrypted -> IO (Either DecryptError Plain)+decryptVerify = decryptIntern c'gpgme_op_decrypt_verify+++decryptIntern :: (C'gpgme_ctx_t+                    -> C'gpgme_data_t+                    -> C'gpgme_data_t+                    -> IO C'gpgme_error_t+                  )+                  -> Ctx+                  -> Encrypted+                  -> IO (Either DecryptError Plain)+decryptIntern dec_op (Ctx ctxPtr _) cipher = do+    -- init buffer with cipher+    cipherBufPtr <- malloc+    BS.useAsCString cipher $ \bs -> do+        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+    cipherBuf <- peek cipherBufPtr++    -- init buffer for result+    resultBufPtr <- malloc+    check_error "data_new" =<< c'gpgme_data_new resultBufPtr+    resultBuf <- peek resultBufPtr++    ctx <- peek ctxPtr++    -- decrypt+    errcode <- dec_op ctx cipherBuf resultBuf++    let res = if errcode /= noError+                then Left  (toDecryptError errcode)+                else Right (collectResult resultBuf)++    free cipherBufPtr+    free resultBufPtr++    return res
+ src/Crypto/Gpgme/Ctx.hs view
@@ -0,0 +1,92 @@+module Crypto.Gpgme.Ctx where++import Bindings.Gpgme+import Foreign+import Foreign.C.String+import Foreign.C.Types+import System.Posix.IO (fdWrite)++import Crypto.Gpgme.Types+import Crypto.Gpgme.Internal++-- | Creates a new 'Ctx' from a @homedirectory@, a @locale@+--   and a @protocol@. Needs to be freed with 'freeCtx', which+--   is why you are encouraged to use 'withCtx'.+newCtx :: String   -- ^ path to gpg homedirectory+       -> String   -- ^ locale+       -> Protocol -- ^ protocol+       -> IO Ctx+newCtx homedir localeStr (Protocol protocol) =+    do homedirPtr <- newCString homedir++       -- check version: necessary for initialization!!+       version <- c'gpgme_check_version nullPtr >>= peekCString++       -- create context+       ctxPtr <- malloc +       check_error "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++       -- set protocol in ctx+       check_error "set_protocol" =<< c'gpgme_set_protocol ctx (fromIntegral protocol)++       -- set homedir in ctx+       check_error "set_engine_info" =<< c'gpgme_ctx_set_engine_info ctx+                            (fromIntegral protocol) nullPtr homedirPtr++       return (Ctx ctxPtr version)+    where lcCtype :: CInt+          lcCtype = 0++-- | Free a previously created 'Ctx'+freeCtx :: Ctx -> IO ()+freeCtx (Ctx ctxPtr _) =+    do ctx <- peek ctxPtr+       c'gpgme_release ctx+       free ctxPtr++-- | Runs the action with a new 'Ctx' and frees it afterwards+--+--   See 'newCtx' for a descrption of the parameters.+withCtx :: String        -- ^ path to gpg homedirectory+        -> String        -- ^ locale+        -> Protocol      -- ^ protocol+        -> (Ctx -> IO a) -- ^ action to be run with ctx+        -> IO a+withCtx homedir localeStr prot f = do+    ctx <- newCtx homedir localeStr prot+    res <- f ctx+    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++-- 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))
+ src/Crypto/Gpgme/Internal.hs view
@@ -0,0 +1,48 @@+module Crypto.Gpgme.Internal where++import Bindings.Gpgme+import Control.Monad (unless)+import qualified Data.ByteString as BS+import Foreign (allocaBytes, castPtr, peek)+import Foreign.C.String (peekCString)+import System.IO.Unsafe (unsafePerformIO)++import Crypto.Gpgme.Types++collectFprs :: C'gpgme_invalid_key_t -> [InvalidKey]+collectFprs result = unsafePerformIO $ peek result >>= go+    where go :: C'_gpgme_invalid_key -> IO [InvalidKey]+          go invalid = do+            fpr <- peekCString (c'_gpgme_invalid_key'fpr invalid)+            let reason = fromIntegral (c'_gpgme_invalid_key'reason invalid)+            rest <- go (c'_gpgme_invalid_key'next invalid)+            return ((fpr, reason) : rest)++collectResult :: C'gpgme_data_t -> BS.ByteString+collectResult dat' = unsafePerformIO $ do+    -- make sure we start at the beginning+    _ <- c'gpgme_data_seek dat' 0 seekSet+    go dat'+  where go :: C'gpgme_data_t -> IO BS.ByteString+        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)+                                  rest <- go dat+                                  return (byte `BS.cons` rest)+                          else return BS.empty+        seekSet = 0++check_error :: String -> C'gpgme_error_t -> IO ()+check_error fun gpgme_err =+    unless (gpgme_err == noError) $+           do errstr <- c'gpgme_strerror gpgme_err+              str <- peekCString errstr+              srcstr <- c'gpgme_strsource gpgme_err+              src <- peekCString srcstr+              error ("Fun: " ++ fun +++                     ", Error: " ++ str ++ +                     ", Source: " ++ show src)++noError :: Num a => a+noError = 0
+ src/Crypto/Gpgme/Key.hs view
@@ -0,0 +1,52 @@+module Crypto.Gpgme.Key (+      getKey+    , freeKey+    , withKey+    ) where++import Bindings.Gpgme+import qualified Data.ByteString as BS+import Foreign++import Crypto.Gpgme.Types+import Crypto.Gpgme.Internal++-- | 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.+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 (IncludeSecret is) = do+    keyPtr <- malloc+    ret <- BS.useAsCString fpr $ \cFpr ->+        peek ctxPtr >>= \ctx ->+            c'gpgme_get_key ctx cFpr keyPtr is+    if ret == noError+        then return . Just . Key $ keyPtr+        else free keyPtr >> return Nothing++-- | Frees a key previously created with 'getKey'+freeKey :: Key -> IO ()+freeKey (Key keyPtr) = free keyPtr++-- | 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.++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++
+ src/Crypto/Gpgme/Types.hs view
@@ -0,0 +1,64 @@+module Crypto.Gpgme.Types where++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++-- | 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+}++type Fpr = BS.ByteString+type Plain = BS.ByteString+type Encrypted = BS.ByteString++-- | The fingerprint and an error code+type InvalidKey = (String, Int)+-- TODO map intot better error code++-- | A key from the context+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++noFlag :: Flag+noFlag = Flag 0++-- | 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)++toDecryptError :: C'gpgme_err_code_t -> DecryptError+toDecryptError 58  = NoData+toDecryptError 152 = Failed+toDecryptError 11  = BadPass+toDecryptError x   = Unknown (fromIntegral x)
+ test/Main.hs view
@@ -0,0 +1,13 @@+module Main where++import Test.Framework (defaultMain, testGroup)++import KeyTest +import CtxTest +import CryptoTest ++main = defaultMain+    [ testGroup "key"    KeyTest.tests+    , testGroup "ctx"    CtxTest.tests+    , testGroup "crypto" CryptoTest.tests+    ]