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
newCtx :: String
-> String
-> 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
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
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
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
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
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)
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
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
withCtx :: String
-> String
-> Protocol
-> (Ctx -> IO a)
-> 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
)
( \(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)
)
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)
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
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
where
ver :: String
ver = Ctx -> String
_engineVersion Ctx
ctx
type PassphraseCb =
String
-> String
-> Bool
-> IO (Maybe String)
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
(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
setPassphraseCallback :: Ctx
-> Maybe PassphraseCb
-> 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
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
type ProgressCb =
String
-> Char
-> Integer
-> Integer
-> IO ()
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
setProgressCallback :: Ctx
-> 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