diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/h-gpgme.cabal b/h-gpgme.cabal new file mode 100644 --- /dev/null +++ b/h-gpgme.cabal @@ -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 diff --git a/src/Crypto/Gpgme.hs b/src/Crypto/Gpgme.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme.hs @@ -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: +-- +-- +-- == 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 diff --git a/src/Crypto/Gpgme/Crypto.hs b/src/Crypto/Gpgme/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Crypto.hs @@ -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 diff --git a/src/Crypto/Gpgme/Ctx.hs b/src/Crypto/Gpgme/Ctx.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Ctx.hs @@ -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)) diff --git a/src/Crypto/Gpgme/Internal.hs b/src/Crypto/Gpgme/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Internal.hs @@ -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 diff --git a/src/Crypto/Gpgme/Key.hs b/src/Crypto/Gpgme/Key.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Key.hs @@ -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 + + diff --git a/src/Crypto/Gpgme/Types.hs b/src/Crypto/Gpgme/Types.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Gpgme/Types.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ]