module Crypto.Gpgme.Ctx where

import Bindings.Gpgme
import Control.Monad (when)
import Control.Exception (SomeException(SomeException), catch, throwIO, toException)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import Foreign
import Foreign.C.String
import Foreign.C.Types

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 :: String -> String -> Protocol -> IO Ctx
newCtx String
homedir String
localeStr Protocol
protocol =
    do CString
homedirPtr <- String -> IO CString
newCString String
homedir

       -- check version: necessary for initialization!!
       String
version <- CString -> IO CString
c'gpgme_check_version CString
forall a. Ptr a
nullPtr IO CString -> (CString -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString

       -- create context
       Ptr C'gpgme_ctx_t
ctxPtr <- IO (Ptr C'gpgme_ctx_t)
forall a. Storable a => IO (Ptr a)
malloc
       String -> C'gpgme_error_t -> IO ()
checkError String
"gpgme_new" (C'gpgme_error_t -> IO ()) -> IO C'gpgme_error_t -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr C'gpgme_ctx_t -> IO C'gpgme_error_t
c'gpgme_new Ptr C'gpgme_ctx_t
ctxPtr

       C'gpgme_ctx_t
ctx <- Ptr C'gpgme_ctx_t -> IO C'gpgme_ctx_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'gpgme_ctx_t
ctxPtr

       -- find engine version
       C'_gpgme_engine_info
engInfo <- C'gpgme_ctx_t -> IO C'gpgme_engine_info_t
c'gpgme_ctx_get_engine_info C'gpgme_ctx_t
ctx IO C'gpgme_engine_info_t
-> (C'gpgme_engine_info_t -> IO C'_gpgme_engine_info)
-> IO C'_gpgme_engine_info
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= C'gpgme_engine_info_t -> IO C'_gpgme_engine_info
forall a. Storable a => Ptr a -> IO a
peek
       String
engVersion <- CString -> IO String
peekCString (CString -> IO String) -> CString -> IO String
forall a b. (a -> b) -> a -> b
$ C'_gpgme_engine_info -> CString
c'_gpgme_engine_info'version C'_gpgme_engine_info
engInfo

       -- set locale
       CString
locale <- String -> IO CString
newCString String
localeStr
       String -> C'gpgme_error_t -> IO ()
checkError String
"set_locale" (C'gpgme_error_t -> IO ()) -> IO C'gpgme_error_t -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< C'gpgme_ctx_t -> CInt -> CString -> IO C'gpgme_error_t
c'gpgme_set_locale C'gpgme_ctx_t
ctx CInt
lcCtype CString
locale

       -- set protocol in ctx
       String -> C'gpgme_error_t -> IO ()
checkError String
"set_protocol" (C'gpgme_error_t -> IO ()) -> IO C'gpgme_error_t -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< C'gpgme_ctx_t -> C'gpgme_error_t -> IO C'gpgme_error_t
c'gpgme_set_protocol C'gpgme_ctx_t
ctx
                                        (Protocol -> C'gpgme_error_t
forall a. Num a => Protocol -> a
fromProtocol Protocol
protocol)

       -- set homedir in ctx
       String -> C'gpgme_error_t -> IO ()
checkError String
"set_engine_info" (C'gpgme_error_t -> IO ()) -> IO C'gpgme_error_t -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< C'gpgme_ctx_t
-> C'gpgme_error_t -> CString -> CString -> IO C'gpgme_error_t
c'gpgme_ctx_set_engine_info C'gpgme_ctx_t
ctx
                            (Protocol -> C'gpgme_error_t
forall a. Num a => Protocol -> a
fromProtocol Protocol
protocol) CString
forall a. Ptr a
nullPtr CString
homedirPtr

       Ctx -> IO Ctx
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr C'gpgme_ctx_t -> String -> Protocol -> String -> Ctx
Ctx Ptr C'gpgme_ctx_t
ctxPtr String
version Protocol
protocol String
engVersion)
    where lcCtype :: CInt
          lcCtype :: CInt
lcCtype = CInt
0

-- | Free a previously created 'Ctx'
freeCtx :: Ctx -> IO ()
freeCtx :: Ctx -> IO ()
freeCtx Ctx {_ctx :: Ctx -> Ptr C'gpgme_ctx_t
_ctx=Ptr C'gpgme_ctx_t
ctxPtr} =
    do C'gpgme_ctx_t
ctx <- Ptr C'gpgme_ctx_t -> IO C'gpgme_ctx_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'gpgme_ctx_t
ctxPtr
       C'gpgme_ctx_t -> IO ()
c'gpgme_release C'gpgme_ctx_t
ctx
       Ptr C'gpgme_ctx_t -> IO ()
forall a. Ptr a -> IO ()
free Ptr C'gpgme_ctx_t
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 :: String -> String -> Protocol -> (Ctx -> IO a) -> IO a
withCtx String
homedir String
localeStr Protocol
prot Ctx -> IO a
f = do
    Ctx
ctx <- String -> String -> Protocol -> IO Ctx
newCtx String
homedir String
localeStr Protocol
prot
    IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
      ( do
        a
res <- Ctx -> IO a
f Ctx
ctx
        Ctx -> IO ()
freeCtx Ctx
ctx
        a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
      )
      -- If an exception occurs, first free the GPG context
      -- and then throw our own exception to signal that
      -- the exception was caught and accounted for.
      ( \(SomeException e
e) -> do
        Ctx -> IO ()
freeCtx Ctx
ctx
        HgpgmeException -> IO a
forall e a. Exception e => e -> IO a
throwIO (HgpgmeException -> IO a) -> HgpgmeException -> IO a
forall a b. (a -> b) -> a -> b
$ SomeException -> HgpgmeException
HgpgmeException (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e)
      )

-- | Sets armor output on ctx
setArmor :: Bool -> Ctx -> IO ()
setArmor :: Bool -> Ctx -> IO ()
setArmor Bool
armored Ctx {_ctx :: Ctx -> Ptr C'gpgme_ctx_t
_ctx = Ptr C'gpgme_ctx_t
ctxPtr} = do
    C'gpgme_ctx_t
ctx <- Ptr C'gpgme_ctx_t -> IO C'gpgme_ctx_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'gpgme_ctx_t
ctxPtr
    C'gpgme_ctx_t -> CInt -> IO ()
c'gpgme_set_armor C'gpgme_ctx_t
ctx (if Bool
armored then CInt
1 else CInt
0)

-- | Sets the key listing mode on ctx
setKeyListingMode :: [KeyListingMode] -> Ctx -> IO ()
setKeyListingMode :: [KeyListingMode] -> Ctx -> IO ()
setKeyListingMode [KeyListingMode]
modes Ctx {_ctx :: Ctx -> Ptr C'gpgme_ctx_t
_ctx = Ptr C'gpgme_ctx_t
ctxPtr} = do
    let m :: C'gpgme_error_t
m = (C'gpgme_error_t -> KeyListingMode -> C'gpgme_error_t)
-> C'gpgme_error_t -> [KeyListingMode] -> C'gpgme_error_t
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\C'gpgme_error_t
memo -> (C'gpgme_error_t
memo C'gpgme_error_t -> C'gpgme_error_t -> C'gpgme_error_t
forall a. Bits a => a -> a -> a
.|.) (C'gpgme_error_t -> C'gpgme_error_t)
-> (KeyListingMode -> C'gpgme_error_t)
-> KeyListingMode
-> C'gpgme_error_t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyListingMode -> C'gpgme_error_t
fromKeyListingMode) C'gpgme_error_t
0 [KeyListingMode]
modes
    C'gpgme_ctx_t
ctx <- Ptr C'gpgme_ctx_t -> IO C'gpgme_ctx_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'gpgme_ctx_t
ctxPtr
    String -> C'gpgme_error_t -> IO ()
checkError String
"set_keylist_mode" (C'gpgme_error_t -> IO ()) -> IO C'gpgme_error_t -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< C'gpgme_ctx_t -> C'gpgme_error_t -> IO C'gpgme_error_t
c'gpgme_set_keylist_mode C'gpgme_ctx_t
ctx C'gpgme_error_t
m

-- | Are passphrase callbacks supported?
--
-- This functionality is known to be broken in some gpg versions,
-- see 'setPassphraseCb' for details.
isPassphraseCbSupported :: Ctx -> Bool
isPassphraseCbSupported :: Ctx -> Bool
isPassphraseCbSupported Ctx
ctx
  | Protocol
OpenPGP <- Ctx -> Protocol
_protocol Ctx
ctx =
    case () of
      ()
_ | String
"2.0" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
ver  -> Bool
False
        | String
"1." String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
ver   -> Bool
False
        | Bool
otherwise               -> Bool
True
  | Bool
otherwise = Bool
True   -- give the user the benefit of a doubt
  where
    ver :: String
ver = Ctx -> String
_engineVersion Ctx
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 :: PassphraseCb -> IO C'gpgme_passphrase_cb_t
passphraseCb PassphraseCb
callback = do
    let go :: p -> CString -> CString -> a -> CInt -> IO C'gpgme_error_t
go p
_ CString
hint CString
info a
prev_bad CInt
fd = do
            String
hint' <- CString -> IO String
peekCString CString
hint
            String
info' <- CString -> IO String
peekCString CString
info
            Maybe String
result <- PassphraseCb
callback String
hint' String
info' (a
prev_bad a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0)
            let phrase :: String
phrase = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
result
            CSize
err <- String -> (CStringLen -> IO CSize) -> IO CSize
forall a. String -> (CStringLen -> IO a) -> IO a
withCStringLen (String
phraseString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n") ((CStringLen -> IO CSize) -> IO CSize)
-> (CStringLen -> IO CSize) -> IO CSize
forall a b. (a -> b) -> a -> b
$ \(CString
s,Int
len) ->
                CInt -> Ptr () -> CSize -> IO CSize
c'gpgme_io_writen CInt
fd (CString -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr CString
s) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CSize
err CSize -> CSize -> Bool
forall a. Eq a => a -> a -> Bool
/= CSize
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> C'gpgme_error_t -> IO ()
checkError String
"passphraseCb" (CSize -> C'gpgme_error_t
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
err)
            C'gpgme_error_t -> IO C'gpgme_error_t
forall (m :: * -> *) a. Monad m => a -> m a
return (C'gpgme_error_t -> IO C'gpgme_error_t)
-> C'gpgme_error_t -> IO C'gpgme_error_t
forall a b. (a -> b) -> a -> b
$ C'gpgme_error_t
-> (String -> C'gpgme_error_t) -> Maybe String -> C'gpgme_error_t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe C'gpgme_error_t
errCanceled (C'gpgme_error_t -> String -> C'gpgme_error_t
forall a b. a -> b -> a
const C'gpgme_error_t
0) Maybe String
result
        errCanceled :: C'gpgme_error_t
errCanceled = C'gpgme_error_t
99 -- TODO: Use constant
    (Ptr ()
 -> CString -> CString -> CInt -> CInt -> IO C'gpgme_error_t)
-> IO C'gpgme_passphrase_cb_t
mk'gpgme_passphrase_cb_t Ptr () -> CString -> CString -> CInt -> CInt -> IO C'gpgme_error_t
forall a p.
(Eq a, Num a) =>
p -> CString -> CString -> a -> CInt -> IO C'gpgme_error_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 -> Maybe PassphraseCb -> IO ()
setPassphraseCallback Ctx {_ctx :: Ctx -> Ptr C'gpgme_ctx_t
_ctx=Ptr C'gpgme_ctx_t
ctxPtr} Maybe PassphraseCb
callback = do
    C'gpgme_ctx_t
ctx <- Ptr C'gpgme_ctx_t -> IO C'gpgme_ctx_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'gpgme_ctx_t
ctxPtr
    let mode :: C'gpgme_error_t
mode = case Maybe PassphraseCb
callback of
                   Maybe PassphraseCb
Nothing -> C'gpgme_error_t
forall a. Num a => a
c'GPGME_PINENTRY_MODE_DEFAULT
                   Just PassphraseCb
_  -> C'gpgme_error_t
forall a. Num a => a
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_ctx_t -> C'gpgme_error_t -> IO C'gpgme_error_t
c'gpgme_set_pinentry_mode C'gpgme_ctx_t
ctx C'gpgme_error_t
mode IO C'gpgme_error_t -> (C'gpgme_error_t -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> C'gpgme_error_t -> IO ()
checkError String
"setPassphraseCallback"
    C'gpgme_passphrase_cb_t
cb <- IO C'gpgme_passphrase_cb_t
-> (PassphraseCb -> IO C'gpgme_passphrase_cb_t)
-> Maybe PassphraseCb
-> IO C'gpgme_passphrase_cb_t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (C'gpgme_passphrase_cb_t -> IO C'gpgme_passphrase_cb_t
forall (m :: * -> *) a. Monad m => a -> m a
return C'gpgme_passphrase_cb_t
forall a. FunPtr a
nullFunPtr) PassphraseCb -> IO C'gpgme_passphrase_cb_t
passphraseCb Maybe PassphraseCb
callback
    C'gpgme_ctx_t -> C'gpgme_passphrase_cb_t -> Ptr () -> IO ()
c'gpgme_set_passphrase_cb C'gpgme_ctx_t
ctx C'gpgme_passphrase_cb_t
cb Ptr ()
forall a. Ptr a
nullPtr

-- | A callback invoked when the engine uses a progress notification.
-- See the PROGRESS section of docs/DETAILS in gnupg repository.
type ProgressCb =
       String     -- ^ WHAT type of progress
    -> Char       -- ^ CHAR is the character displayed with no --status-fd enabled, with the linefeed replaced by an 'X'
    -> Integer    -- ^ CUR is the current progress
    -> Integer    -- ^ TOTAL is the total possible progress
    -> IO ()

-- | Construct a progress callback
progressCb :: ProgressCb -> IO C'gpgme_progress_cb_t
progressCb :: ProgressCb -> IO C'gpgme_progress_cb_t
progressCb ProgressCb
callback = do
  let go :: p -> CString -> a -> a -> a -> IO ()
go p
_ CString
what a
char a
cur a
total = do
        String
what' <- CString -> IO String
peekCString CString
what
        let charChar :: Char
charChar = Int -> Char
forall a. Enum a => Int -> a
toEnum (Integer -> Int
forall a. Enum a => a -> Int
fromEnum (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a. Integral a => a -> Integer
toInteger a
char)::Char
        ProgressCb
callback String
what' Char
charChar (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
cur) (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
total)
  (Ptr () -> CString -> CInt -> CInt -> CInt -> IO ())
-> IO C'gpgme_progress_cb_t
mk'gpgme_progress_cb_t Ptr () -> CString -> CInt -> CInt -> CInt -> IO ()
forall a a a p.
(Integral a, Integral a, Integral a) =>
p -> CString -> a -> a -> a -> IO ()
go

-- | Set the callback invoked when a progress feedback is available.
setProgressCallback :: Ctx        -- ^ context
                    -> Maybe ProgressCb
                    -> IO ()
setProgressCallback :: Ctx -> Maybe ProgressCb -> IO ()
setProgressCallback Ctx {_ctx :: Ctx -> Ptr C'gpgme_ctx_t
_ctx=Ptr C'gpgme_ctx_t
ctxPtr} Maybe ProgressCb
callback = do
  C'gpgme_ctx_t
ctx <- Ptr C'gpgme_ctx_t -> IO C'gpgme_ctx_t
forall a. Storable a => Ptr a -> IO a
peek Ptr C'gpgme_ctx_t
ctxPtr
  C'gpgme_progress_cb_t
cb <- IO C'gpgme_progress_cb_t
-> (ProgressCb -> IO C'gpgme_progress_cb_t)
-> Maybe ProgressCb
-> IO C'gpgme_progress_cb_t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (C'gpgme_progress_cb_t -> IO C'gpgme_progress_cb_t
forall (m :: * -> *) a. Monad m => a -> m a
return C'gpgme_progress_cb_t
forall a. FunPtr a
nullFunPtr) ProgressCb -> IO C'gpgme_progress_cb_t
progressCb Maybe ProgressCb
callback
  C'gpgme_ctx_t -> C'gpgme_progress_cb_t -> Ptr () -> IO ()
c'gpgme_set_progress_cb C'gpgme_ctx_t
ctx C'gpgme_progress_cb_t
cb Ptr ()
forall a. Ptr a
nullPtr