module Network.Protocol.SASL.GNU
(
headerVersion
, libraryVersion
, checkVersion
, SASL
, runSASL
, setCallback
, runCallback
, Mechanism (..)
, clientMechanisms
, clientSupports
, clientSuggestMechanism
, serverMechanisms
, serverSupports
, Session
, runClient
, runServer
, mechanismName
, Property (..)
, setProperty
, getProperty
, getPropertyFast
, Progress (..)
, step
, step64
, encode
, decode
, Error (..)
, catch
, handle
, try
, throw
, toBase64
, fromBase64
, md5
, sha1
, hmacMD5
, hmacSHA1
, nonce
, random
) where
import Prelude hiding (catch)
import Data.Maybe (fromMaybe)
import Control.Applicative (Applicative, pure, (<*>), (<$>))
import qualified Control.Exception as E
import Control.Monad (ap, when, unless, (<=<))
import Control.Monad.Loops (unfoldrM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.Trans.Reader as R
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Char8 as Char8
import Data.Char (isDigit)
import Data.String (IsString, fromString)
import qualified Foreign as F
import qualified Foreign.C as F
import System.IO.Unsafe (unsafePerformIO)
import qualified Text.ParserCombinators.ReadP as P
headerVersion :: (Integer, Integer, Integer)
= (Integer
major, Integer
minor, Integer
patch) where
major :: Integer
major = CInt -> Integer
forall a. Integral a => a -> Integer
toInteger CInt
hsgsasl_VERSION_MAJOR
minor :: Integer
minor = CInt -> Integer
forall a. Integral a => a -> Integer
toInteger CInt
hsgsasl_VERSION_MINOR
patch :: Integer
patch = CInt -> Integer
forall a. Integral a => a -> Integer
toInteger CInt
hsgsasl_VERSION_PATCH
libraryVersion :: IO (Integer, Integer, Integer)
libraryVersion :: IO (Integer, Integer, Integer)
libraryVersion = IO (Integer, Integer, Integer)
io where
parseVersion :: String -> Maybe (Integer, Integer, Integer)
parseVersion String
str = case ReadP (Integer, Integer, Integer)
-> ReadS (Integer, Integer, Integer)
forall a. ReadP a -> ReadS a
P.readP_to_S ReadP (Integer, Integer, Integer)
parser String
str of
[] -> Maybe (Integer, Integer, Integer)
forall a. Maybe a
Nothing
(((Integer, Integer, Integer)
parsed, String
_):[((Integer, Integer, Integer), String)]
_) -> (Integer, Integer, Integer) -> Maybe (Integer, Integer, Integer)
forall a. a -> Maybe a
Just (Integer, Integer, Integer)
parsed
parser :: ReadP (Integer, Integer, Integer)
parser = do
String
majorS <- (Char -> Bool) -> ReadP String
P.munch1 Char -> Bool
isDigit
Char
_ <- Char -> ReadP Char
P.char Char
'.'
String
minorS <- (Char -> Bool) -> ReadP String
P.munch1 Char -> Bool
isDigit
Char
_ <- Char -> ReadP Char
P.char Char
'.'
String
patchS <- (Char -> Bool) -> ReadP String
P.munch1 Char -> Bool
isDigit
ReadP ()
eof
(Integer, Integer, Integer) -> ReadP (Integer, Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Integer
forall a. Read a => String -> a
read String
majorS, String -> Integer
forall a. Read a => String -> a
read String
minorS, String -> Integer
forall a. Read a => String -> a
read String
patchS)
io :: IO (Integer, Integer, Integer)
io = do
Ptr CChar
cstr <- Ptr CChar -> IO (Ptr CChar)
gsasl_check_version Ptr CChar
forall a. Ptr a
F.nullPtr
Maybe String
maybeStr <- (Ptr CChar -> IO String) -> Ptr CChar -> IO (Maybe String)
forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
F.maybePeek Ptr CChar -> IO String
F.peekCString Ptr CChar
cstr
(Integer, Integer, Integer) -> IO (Integer, Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, Integer, Integer) -> IO (Integer, Integer, Integer))
-> (Integer, Integer, Integer) -> IO (Integer, Integer, Integer)
forall a b. (a -> b) -> a -> b
$ (Integer, Integer, Integer)
-> Maybe (Integer, Integer, Integer) -> (Integer, Integer, Integer)
forall a. a -> Maybe a -> a
fromMaybe (String -> (Integer, Integer, Integer)
forall a. HasCallStack => String -> a
error (String -> (Integer, Integer, Integer))
-> String -> (Integer, Integer, Integer)
forall a b. (a -> b) -> a -> b
$ String
"Invalid version string: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show Maybe String
maybeStr)
(Maybe String
maybeStr Maybe String
-> (String -> Maybe (Integer, Integer, Integer))
-> Maybe (Integer, Integer, Integer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe (Integer, Integer, Integer)
parseVersion)
eof :: ReadP ()
eof = do
String
s <- ReadP String
P.look
Bool -> ReadP () -> ReadP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) ReadP ()
forall a. ReadP a
P.pfail
checkVersion :: IO Bool
checkVersion :: IO Bool
checkVersion = (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1) IO CInt
hsgsasl_check_version
newtype Context = Context (F.Ptr Context)
newtype SASL a = SASL { forall a. SASL a -> ReaderT Context IO a
unSASL :: R.ReaderT Context IO a }
instance Functor SASL where
fmap :: forall a b. (a -> b) -> SASL a -> SASL b
fmap a -> b
f = ReaderT Context IO b -> SASL b
forall a. ReaderT Context IO a -> SASL a
SASL (ReaderT Context IO b -> SASL b)
-> (SASL a -> ReaderT Context IO b) -> SASL a -> SASL b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> ReaderT Context IO a -> ReaderT Context IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ReaderT Context IO a -> ReaderT Context IO b)
-> (SASL a -> ReaderT Context IO a)
-> SASL a
-> ReaderT Context IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SASL a -> ReaderT Context IO a
forall a. SASL a -> ReaderT Context IO a
unSASL
instance Applicative SASL where
pure :: forall a. a -> SASL a
pure = ReaderT Context IO a -> SASL a
forall a. ReaderT Context IO a -> SASL a
SASL (ReaderT Context IO a -> SASL a)
-> (a -> ReaderT Context IO a) -> a -> SASL a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT Context IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
<*> :: forall a b. SASL (a -> b) -> SASL a -> SASL b
(<*>) = SASL (a -> b) -> SASL a -> SASL b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad SASL where
return :: forall a. a -> SASL a
return = ReaderT Context IO a -> SASL a
forall a. ReaderT Context IO a -> SASL a
SASL (ReaderT Context IO a -> SASL a)
-> (a -> ReaderT Context IO a) -> a -> SASL a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
>>= :: forall a b. SASL a -> (a -> SASL b) -> SASL b
(>>=) SASL a
sasl a -> SASL b
f = ReaderT Context IO b -> SASL b
forall a. ReaderT Context IO a -> SASL a
SASL (ReaderT Context IO b -> SASL b) -> ReaderT Context IO b -> SASL b
forall a b. (a -> b) -> a -> b
$ SASL a -> ReaderT Context IO a
forall a. SASL a -> ReaderT Context IO a
unSASL SASL a
sasl ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SASL b -> ReaderT Context IO b
forall a. SASL a -> ReaderT Context IO a
unSASL (SASL b -> ReaderT Context IO b)
-> (a -> SASL b) -> a -> ReaderT Context IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SASL b
f
instance MonadIO SASL where
liftIO :: forall a. IO a -> SASL a
liftIO = ReaderT Context IO a -> SASL a
forall a. ReaderT Context IO a -> SASL a
SASL (ReaderT Context IO a -> SASL a)
-> (IO a -> ReaderT Context IO a) -> IO a -> SASL a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ReaderT Context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
runSASL :: SASL a -> IO a
runSASL :: forall a. SASL a -> IO a
runSASL = (Context -> IO a) -> IO a
forall a. (Context -> IO a) -> IO a
withContext ((Context -> IO a) -> IO a)
-> (SASL a -> Context -> IO a) -> SASL a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Context IO a -> Context -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT (ReaderT Context IO a -> Context -> IO a)
-> (SASL a -> ReaderT Context IO a) -> SASL a -> Context -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SASL a -> ReaderT Context IO a
forall a. SASL a -> ReaderT Context IO a
unSASL
withContext :: (Context -> IO a) -> IO a
withContext :: forall a. (Context -> IO a) -> IO a
withContext = IO Context -> (Context -> IO ()) -> (Context -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO Context
newContext Context -> IO ()
freeContext where
newContext :: IO Context
newContext = (Ptr (Ptr Context) -> IO Context) -> IO Context
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr Context) -> IO Context) -> IO Context)
-> (Ptr (Ptr Context) -> IO Context) -> IO Context
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr Context)
pCtxt -> do
Ptr (Ptr Context) -> IO CInt
gsasl_init Ptr (Ptr Context)
pCtxt IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
Ptr Context -> Context
Context (Ptr Context -> Context) -> IO (Ptr Context) -> IO Context
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr (Ptr Context) -> IO (Ptr Context)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr Context)
pCtxt
freeContext :: Context -> IO ()
freeContext (Context Ptr Context
ctx) = do
Ptr CallbackHook
hook <- Ptr Context -> IO (Ptr CallbackHook)
forall a. Ptr Context -> IO (Ptr a)
gsasl_callback_hook_get Ptr Context
ctx
Ptr Context -> IO ()
gsasl_done Ptr Context
ctx
Ptr CallbackHook -> IO ()
freeCallbackHook Ptr CallbackHook
hook
getContext :: SASL (F.Ptr Context)
getContext :: SASL (Ptr Context)
getContext = ReaderT Context IO (Ptr Context) -> SASL (Ptr Context)
forall a. ReaderT Context IO a -> SASL a
SASL (ReaderT Context IO (Ptr Context) -> SASL (Ptr Context))
-> ReaderT Context IO (Ptr Context) -> SASL (Ptr Context)
forall a b. (a -> b) -> a -> b
$ do
Context Ptr Context
ptr <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
R.ask
Ptr Context -> ReaderT Context IO (Ptr Context)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Context
ptr
bracketSASL :: (F.Ptr Context -> IO a) -> (a -> IO b) -> (a -> IO c) -> SASL c
bracketSASL :: forall a b c.
(Ptr Context -> IO a) -> (a -> IO b) -> (a -> IO c) -> SASL c
bracketSASL Ptr Context -> IO a
before a -> IO b
after a -> IO c
thing = do
Ptr Context
ctx <- SASL (Ptr Context)
getContext
IO c -> SASL c
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO c -> SASL c) -> IO c -> SASL c
forall a b. (a -> b) -> a -> b
$ IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (Ptr Context -> IO a
before Ptr Context
ctx) a -> IO b
after a -> IO c
thing
newtype Mechanism = Mechanism B.ByteString
deriving (Int -> Mechanism -> String -> String
[Mechanism] -> String -> String
Mechanism -> String
(Int -> Mechanism -> String -> String)
-> (Mechanism -> String)
-> ([Mechanism] -> String -> String)
-> Show Mechanism
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Mechanism] -> String -> String
$cshowList :: [Mechanism] -> String -> String
show :: Mechanism -> String
$cshow :: Mechanism -> String
showsPrec :: Int -> Mechanism -> String -> String
$cshowsPrec :: Int -> Mechanism -> String -> String
Show, Mechanism -> Mechanism -> Bool
(Mechanism -> Mechanism -> Bool)
-> (Mechanism -> Mechanism -> Bool) -> Eq Mechanism
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mechanism -> Mechanism -> Bool
$c/= :: Mechanism -> Mechanism -> Bool
== :: Mechanism -> Mechanism -> Bool
$c== :: Mechanism -> Mechanism -> Bool
Eq)
instance IsString Mechanism where
fromString :: String -> Mechanism
fromString = ByteString -> Mechanism
Mechanism (ByteString -> Mechanism)
-> (String -> ByteString) -> String -> Mechanism
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a. IsString a => String -> a
fromString
clientMechanisms :: SASL [Mechanism]
clientMechanisms :: SASL [Mechanism]
clientMechanisms = (Ptr Context -> IO (Ptr CChar))
-> (Ptr CChar -> IO ())
-> (Ptr CChar -> IO [Mechanism])
-> SASL [Mechanism]
forall a b c.
(Ptr Context -> IO a) -> (a -> IO b) -> (a -> IO c) -> SASL c
bracketSASL Ptr Context -> IO (Ptr CChar)
io Ptr CChar -> IO ()
forall a. Ptr a -> IO ()
gsasl_free Ptr CChar -> IO [Mechanism]
splitMechListPtr where
io :: Ptr Context -> IO (Ptr CChar)
io Ptr Context
ctx = (Ptr (Ptr CChar) -> IO (Ptr CChar)) -> IO (Ptr CChar)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO (Ptr CChar)) -> IO (Ptr CChar))
-> (Ptr (Ptr CChar) -> IO (Ptr CChar)) -> IO (Ptr CChar)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pStr -> do
Ptr Context -> Ptr (Ptr CChar) -> IO CInt
gsasl_client_mechlist Ptr Context
ctx Ptr (Ptr CChar)
pStr IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr CChar)
pStr
clientSupports :: Mechanism -> SASL Bool
clientSupports :: Mechanism -> SASL Bool
clientSupports (Mechanism ByteString
name) = do
Ptr Context
ctx <- SASL (Ptr Context)
getContext
IO Bool -> SASL Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> SASL Bool) -> IO Bool -> SASL Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> (Ptr CChar -> IO Bool) -> IO Bool
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
B.useAsCString ByteString
name ((Ptr CChar -> IO Bool) -> IO Bool)
-> (Ptr CChar -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
pName -> do
CInt
cres <- Ptr Context -> Ptr CChar -> IO CInt
gsasl_client_support_p Ptr Context
ctx Ptr CChar
pName
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CInt
cres CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1
clientSuggestMechanism :: [Mechanism] -> SASL (Maybe Mechanism)
clientSuggestMechanism :: [Mechanism] -> SASL (Maybe Mechanism)
clientSuggestMechanism [Mechanism]
mechs = do
let bytes :: ByteString
bytes = ByteString -> [ByteString] -> ByteString
B.intercalate (String -> ByteString
Char8.pack String
" ") [ByteString
x | Mechanism ByteString
x <- [Mechanism]
mechs]
Ptr Context
ctx <- SASL (Ptr Context)
getContext
IO (Maybe Mechanism) -> SASL (Maybe Mechanism)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Mechanism) -> SASL (Maybe Mechanism))
-> IO (Maybe Mechanism) -> SASL (Maybe Mechanism)
forall a b. (a -> b) -> a -> b
$ ByteString
-> (Ptr CChar -> IO (Maybe Mechanism)) -> IO (Maybe Mechanism)
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
B.useAsCString ByteString
bytes ((Ptr CChar -> IO (Maybe Mechanism)) -> IO (Maybe Mechanism))
-> (Ptr CChar -> IO (Maybe Mechanism)) -> IO (Maybe Mechanism)
forall a b. (a -> b) -> a -> b
$
(Ptr CChar -> IO Mechanism) -> Ptr CChar -> IO (Maybe Mechanism)
forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
F.maybePeek ((ByteString -> Mechanism) -> IO ByteString -> IO Mechanism
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Mechanism
Mechanism (IO ByteString -> IO Mechanism)
-> (Ptr CChar -> IO ByteString) -> Ptr CChar -> IO Mechanism
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr CChar -> IO ByteString
B.packCString) (Ptr CChar -> IO (Maybe Mechanism))
-> (Ptr CChar -> IO (Ptr CChar))
-> Ptr CChar
-> IO (Maybe Mechanism)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
Ptr Context -> Ptr CChar -> IO (Ptr CChar)
gsasl_client_suggest_mechanism Ptr Context
ctx
serverMechanisms :: SASL [Mechanism]
serverMechanisms :: SASL [Mechanism]
serverMechanisms = (Ptr Context -> IO (Ptr CChar))
-> (Ptr CChar -> IO ())
-> (Ptr CChar -> IO [Mechanism])
-> SASL [Mechanism]
forall a b c.
(Ptr Context -> IO a) -> (a -> IO b) -> (a -> IO c) -> SASL c
bracketSASL Ptr Context -> IO (Ptr CChar)
io Ptr CChar -> IO ()
forall a. Ptr a -> IO ()
gsasl_free Ptr CChar -> IO [Mechanism]
splitMechListPtr where
io :: Ptr Context -> IO (Ptr CChar)
io Ptr Context
ctx = (Ptr (Ptr CChar) -> IO (Ptr CChar)) -> IO (Ptr CChar)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO (Ptr CChar)) -> IO (Ptr CChar))
-> (Ptr (Ptr CChar) -> IO (Ptr CChar)) -> IO (Ptr CChar)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pStr -> do
Ptr Context -> Ptr (Ptr CChar) -> IO CInt
gsasl_server_mechlist Ptr Context
ctx Ptr (Ptr CChar)
pStr IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr CChar)
pStr
serverSupports :: Mechanism -> SASL Bool
serverSupports :: Mechanism -> SASL Bool
serverSupports (Mechanism ByteString
name) = do
Ptr Context
ctx <- SASL (Ptr Context)
getContext
IO Bool -> SASL Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> SASL Bool) -> IO Bool -> SASL Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> (Ptr CChar -> IO Bool) -> IO Bool
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
B.useAsCString ByteString
name ((Ptr CChar -> IO Bool) -> IO Bool)
-> (Ptr CChar -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
pName -> do
CInt
cres <- Ptr Context -> Ptr CChar -> IO CInt
gsasl_server_support_p Ptr Context
ctx Ptr CChar
pName
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CInt
cres CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1
splitMechListPtr :: F.CString -> IO [Mechanism]
splitMechListPtr :: Ptr CChar -> IO [Mechanism]
splitMechListPtr Ptr CChar
ptr = ((Ptr CChar, Ptr CChar, Int, Bool)
-> IO (Maybe (Mechanism, (Ptr CChar, Ptr CChar, Int, Bool))))
-> (Ptr CChar, Ptr CChar, Int, Bool) -> IO [Mechanism]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe (b, a))) -> a -> m [b]
unfoldrM (Ptr CChar, Ptr CChar, Int, Bool)
-> IO (Maybe (Mechanism, (Ptr CChar, Ptr CChar, Int, Bool)))
forall {b} {c} {b} {b}.
(Storable b, Eq b, Num b, Num c) =>
(Ptr CChar, Ptr b, Int, Bool)
-> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
step' (Ptr CChar
ptr, Ptr CChar
ptr, Int
0, Bool
True) where
step' :: (Ptr CChar, Ptr b, Int, Bool)
-> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
step' (Ptr CChar
_, Ptr b
_, Int
_, Bool
False) = Maybe (Mechanism, (Ptr b, Ptr b, c, Bool))
-> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Mechanism, (Ptr b, Ptr b, c, Bool))
forall a. Maybe a
Nothing
step' (Ptr CChar
p_0, Ptr b
p_i, Int
i, Bool
_) = Ptr b -> IO b
forall a. Storable a => Ptr a -> IO a
F.peek Ptr b
p_i IO b
-> (b -> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool))))
-> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
chr -> let
p_i' :: Ptr b
p_i' = Ptr b -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
F.plusPtr Ptr b
p_i Int
1
peek :: Bool -> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
peek Bool
continue = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then (Ptr CChar, Ptr b, Int, Bool)
-> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
step' (Ptr CChar
forall a. Ptr a
p_i', Ptr b
forall a. Ptr a
p_i', Int
0, Bool
continue)
else do
ByteString
bytes <- CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
p_0, Int
i)
Maybe (Mechanism, (Ptr b, Ptr b, c, Bool))
-> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool))
-> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool))))
-> Maybe (Mechanism, (Ptr b, Ptr b, c, Bool))
-> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
forall a b. (a -> b) -> a -> b
$ (Mechanism, (Ptr b, Ptr b, c, Bool))
-> Maybe (Mechanism, (Ptr b, Ptr b, c, Bool))
forall a. a -> Maybe a
Just (ByteString -> Mechanism
Mechanism ByteString
bytes, (Ptr b
forall a. Ptr a
p_i', Ptr b
forall a. Ptr a
p_i', c
0, Bool
continue))
in case b
chr of
b
0x00 -> Bool -> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
peek Bool
False
b
0x20 -> Bool -> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
peek Bool
True
b
_ -> (Ptr CChar, Ptr b, Int, Bool)
-> IO (Maybe (Mechanism, (Ptr b, Ptr b, c, Bool)))
step' (Ptr CChar
p_0, Ptr b
forall a. Ptr a
p_i', Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Bool
True)
newtype SessionCtx = SessionCtx (F.Ptr SessionCtx)
newtype Session a = Session { forall a. Session a -> ReaderT SessionCtx IO a
unSession :: R.ReaderT SessionCtx IO a }
instance Functor Session where
fmap :: forall a b. (a -> b) -> Session a -> Session b
fmap a -> b
f = ReaderT SessionCtx IO b -> Session b
forall a. ReaderT SessionCtx IO a -> Session a
Session (ReaderT SessionCtx IO b -> Session b)
-> (Session a -> ReaderT SessionCtx IO b) -> Session a -> Session b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> ReaderT SessionCtx IO a -> ReaderT SessionCtx IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ReaderT SessionCtx IO a -> ReaderT SessionCtx IO b)
-> (Session a -> ReaderT SessionCtx IO a)
-> Session a
-> ReaderT SessionCtx IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Session a -> ReaderT SessionCtx IO a
forall a. Session a -> ReaderT SessionCtx IO a
unSession
instance Applicative Session where
pure :: forall a. a -> Session a
pure = ReaderT SessionCtx IO a -> Session a
forall a. ReaderT SessionCtx IO a -> Session a
Session (ReaderT SessionCtx IO a -> Session a)
-> (a -> ReaderT SessionCtx IO a) -> a -> Session a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT SessionCtx IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
<*> :: forall a b. Session (a -> b) -> Session a -> Session b
(<*>) = Session (a -> b) -> Session a -> Session b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Session where
return :: forall a. a -> Session a
return = ReaderT SessionCtx IO a -> Session a
forall a. ReaderT SessionCtx IO a -> Session a
Session (ReaderT SessionCtx IO a -> Session a)
-> (a -> ReaderT SessionCtx IO a) -> a -> Session a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT SessionCtx IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
>>= :: forall a b. Session a -> (a -> Session b) -> Session b
(>>=) Session a
m a -> Session b
f = ReaderT SessionCtx IO b -> Session b
forall a. ReaderT SessionCtx IO a -> Session a
Session (ReaderT SessionCtx IO b -> Session b)
-> ReaderT SessionCtx IO b -> Session b
forall a b. (a -> b) -> a -> b
$ Session a -> ReaderT SessionCtx IO a
forall a. Session a -> ReaderT SessionCtx IO a
unSession Session a
m ReaderT SessionCtx IO a
-> (a -> ReaderT SessionCtx IO b) -> ReaderT SessionCtx IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Session b -> ReaderT SessionCtx IO b
forall a. Session a -> ReaderT SessionCtx IO a
unSession (Session b -> ReaderT SessionCtx IO b)
-> (a -> Session b) -> a -> ReaderT SessionCtx IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Session b
f
instance MonadIO Session where
liftIO :: forall a. IO a -> Session a
liftIO = ReaderT SessionCtx IO a -> Session a
forall a. ReaderT SessionCtx IO a -> Session a
Session (ReaderT SessionCtx IO a -> Session a)
-> (IO a -> ReaderT SessionCtx IO a) -> IO a -> Session a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ReaderT SessionCtx IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
type SessionProc = F.Ptr Context -> F.CString -> F.Ptr (F.Ptr SessionCtx) -> IO F.CInt
runSession :: SessionProc -> Mechanism -> Session a -> SASL (Either Error a)
runSession :: forall a.
SessionProc -> Mechanism -> Session a -> SASL (Either Error a)
runSession SessionProc
start (Mechanism ByteString
mech) Session a
session = (Ptr Context -> IO (Either Error SessionCtx))
-> (Either Error SessionCtx -> IO ())
-> (Either Error SessionCtx -> IO (Either Error a))
-> SASL (Either Error a)
forall a b c.
(Ptr Context -> IO a) -> (a -> IO b) -> (a -> IO c) -> SASL c
bracketSASL Ptr Context -> IO (Either Error SessionCtx)
newSession Either Error SessionCtx -> IO ()
forall {a}. Either a SessionCtx -> IO ()
freeSession Either Error SessionCtx -> IO (Either Error a)
io where
newSession :: Ptr Context -> IO (Either Error SessionCtx)
newSession Ptr Context
ctx =
ByteString
-> (Ptr CChar -> IO (Either Error SessionCtx))
-> IO (Either Error SessionCtx)
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
B.useAsCString ByteString
mech ((Ptr CChar -> IO (Either Error SessionCtx))
-> IO (Either Error SessionCtx))
-> (Ptr CChar -> IO (Either Error SessionCtx))
-> IO (Either Error SessionCtx)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
pMech ->
(Ptr (Ptr SessionCtx) -> IO (Either Error SessionCtx))
-> IO (Either Error SessionCtx)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr SessionCtx) -> IO (Either Error SessionCtx))
-> IO (Either Error SessionCtx))
-> (Ptr (Ptr SessionCtx) -> IO (Either Error SessionCtx))
-> IO (Either Error SessionCtx)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr SessionCtx)
pSessionCtx -> (SASLException -> IO (Either Error SessionCtx))
-> IO (Either Error SessionCtx) -> IO (Either Error SessionCtx)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle SASLException -> IO (Either Error SessionCtx)
forall {m :: * -> *} {b}.
Monad m =>
SASLException -> m (Either Error b)
noSession (IO (Either Error SessionCtx) -> IO (Either Error SessionCtx))
-> IO (Either Error SessionCtx) -> IO (Either Error SessionCtx)
forall a b. (a -> b) -> a -> b
$ do
SessionProc
start Ptr Context
ctx Ptr CChar
pMech Ptr (Ptr SessionCtx)
pSessionCtx IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
SessionCtx -> Either Error SessionCtx
forall a b. b -> Either a b
Right (SessionCtx -> Either Error SessionCtx)
-> (Ptr SessionCtx -> SessionCtx)
-> Ptr SessionCtx
-> Either Error SessionCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr SessionCtx -> SessionCtx
SessionCtx (Ptr SessionCtx -> Either Error SessionCtx)
-> IO (Ptr SessionCtx) -> IO (Either Error SessionCtx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr (Ptr SessionCtx) -> IO (Ptr SessionCtx)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr SessionCtx)
pSessionCtx
noSession :: SASLException -> m (Either Error b)
noSession (SASLException Error
err) = Either Error b -> m (Either Error b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error b -> m (Either Error b))
-> Either Error b -> m (Either Error b)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error b
forall a b. a -> Either a b
Left Error
err
freeSession :: Either a SessionCtx -> IO ()
freeSession (Left a
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
freeSession (Right (SessionCtx Ptr SessionCtx
ptr)) = Ptr SessionCtx -> IO ()
gsasl_finish Ptr SessionCtx
ptr
io :: Either Error SessionCtx -> IO (Either Error a)
io (Left Error
err) = Either Error a -> IO (Either Error a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a -> IO (Either Error a))
-> Either Error a -> IO (Either Error a)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error a
forall a b. a -> Either a b
Left Error
err
io (Right SessionCtx
sctx) = IO (Either Error a)
-> (SASLException -> IO (Either Error a)) -> IO (Either Error a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
(a -> Either Error a
forall a b. b -> Either a b
Right (a -> Either Error a) -> IO a -> IO (Either Error a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SessionCtx IO a -> SessionCtx -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT (Session a -> ReaderT SessionCtx IO a
forall a. Session a -> ReaderT SessionCtx IO a
unSession Session a
session) SessionCtx
sctx)
(\(SASLException Error
err) -> Either Error a -> IO (Either Error a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a -> IO (Either Error a))
-> Either Error a -> IO (Either Error a)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error a
forall a b. a -> Either a b
Left Error
err)
runClient :: Mechanism -> Session a -> SASL (Either Error a)
runClient :: forall a. Mechanism -> Session a -> SASL (Either Error a)
runClient = SessionProc -> Mechanism -> Session a -> SASL (Either Error a)
forall a.
SessionProc -> Mechanism -> Session a -> SASL (Either Error a)
runSession SessionProc
gsasl_client_start
runServer :: Mechanism -> Session a -> SASL (Either Error a)
runServer :: forall a. Mechanism -> Session a -> SASL (Either Error a)
runServer = SessionProc -> Mechanism -> Session a -> SASL (Either Error a)
forall a.
SessionProc -> Mechanism -> Session a -> SASL (Either Error a)
runSession SessionProc
gsasl_server_start
getSessionContext :: Session (F.Ptr SessionCtx)
getSessionContext :: Session (Ptr SessionCtx)
getSessionContext = ReaderT SessionCtx IO (Ptr SessionCtx) -> Session (Ptr SessionCtx)
forall a. ReaderT SessionCtx IO a -> Session a
Session (ReaderT SessionCtx IO (Ptr SessionCtx)
-> Session (Ptr SessionCtx))
-> ReaderT SessionCtx IO (Ptr SessionCtx)
-> Session (Ptr SessionCtx)
forall a b. (a -> b) -> a -> b
$ do
SessionCtx Ptr SessionCtx
sctx <- ReaderT SessionCtx IO SessionCtx
forall (m :: * -> *) r. Monad m => ReaderT r m r
R.ask
Ptr SessionCtx -> ReaderT SessionCtx IO (Ptr SessionCtx)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr SessionCtx
sctx
mechanismName :: Session Mechanism
mechanismName :: Session Mechanism
mechanismName = do
Ptr SessionCtx
sctx <- Session (Ptr SessionCtx)
getSessionContext
IO Mechanism -> Session Mechanism
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Mechanism -> Session Mechanism)
-> IO Mechanism -> Session Mechanism
forall a b. (a -> b) -> a -> b
$ do
Ptr CChar
cstr <- Ptr SessionCtx -> IO (Ptr CChar)
gsasl_mechanism_name Ptr SessionCtx
sctx
ByteString -> Mechanism
Mechanism (ByteString -> Mechanism) -> IO ByteString -> IO Mechanism
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr CChar -> IO ByteString
B.packCString Ptr CChar
cstr
bracketSession :: (F.Ptr SessionCtx -> IO a) -> (a -> IO b) -> (a -> IO c) -> Session c
bracketSession :: forall a b c.
(Ptr SessionCtx -> IO a) -> (a -> IO b) -> (a -> IO c) -> Session c
bracketSession Ptr SessionCtx -> IO a
before a -> IO b
after a -> IO c
thing = do
Ptr SessionCtx
sctx <- Session (Ptr SessionCtx)
getSessionContext
IO c -> Session c
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO c -> Session c) -> IO c -> Session c
forall a b. (a -> b) -> a -> b
$ IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (Ptr SessionCtx -> IO a
before Ptr SessionCtx
sctx) a -> IO b
after a -> IO c
thing
data Error
= UnknownMechanism
| MechanismCalledTooManyTimes
| MallocError
| Base64Error
| CryptoError
| SASLPrepError
| MechanismParseError
| AuthenticationError
| IntegrityError
| NoClientCode
| NoServerCode
| NoCallback
| NoAnonymousToken
| NoAuthID
| NoAuthzID
| NoPassword
| NoPasscode
| NoPIN
| NoService
| NoHostname
| GSSAPI_ReleaseBufferError
| GSSAPI_ImportNameError
| GSSAPI_InitSecContextError
| GSSAPI_AcceptSecContextError
| GSSAPI_UnwrapError
| GSSAPI_WrapError
| GSSAPI_AquireCredError
| GSSAPI_DisplayNameError
| GSSAPI_UnsupportedProtectionError
| GSSAPI_EncapsulateTokenError
| GSSAPI_DecapsulateTokenError
| GSSAPI_InquireMechForSASLNameError
| GSSAPI_TestOIDSetMemberError
| GSSAPI_ReleaseOIDSetError
| KerberosV5_InitError
| KerberosV5_InternalError
| SecurID_ServerNeedAdditionalPasscode
| SecurID_ServerNeedNewPIN
instance Show Error where
show :: Error -> String
show = Error -> String
strError
strError :: Error -> String
strError :: Error -> String
strError Error
err = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ CInt -> IO (Ptr CChar)
gsasl_strerror (Error -> CInt
cFromError Error
err) IO (Ptr CChar) -> (Ptr CChar -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr CChar -> IO String
F.peekCString
newtype SASLException = SASLException Error deriving (Int -> SASLException -> String -> String
[SASLException] -> String -> String
SASLException -> String
(Int -> SASLException -> String -> String)
-> (SASLException -> String)
-> ([SASLException] -> String -> String)
-> Show SASLException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SASLException] -> String -> String
$cshowList :: [SASLException] -> String -> String
show :: SASLException -> String
$cshow :: SASLException -> String
showsPrec :: Int -> SASLException -> String -> String
$cshowsPrec :: Int -> SASLException -> String -> String
Show)
instance E.Exception SASLException
cFromError :: Error -> F.CInt
cFromError :: Error -> CInt
cFromError Error
e = case Error
e of
Error
UnknownMechanism -> CInt
2
Error
MechanismCalledTooManyTimes -> CInt
3
Error
MallocError -> CInt
7
Error
Base64Error -> CInt
8
Error
CryptoError -> CInt
9
Error
SASLPrepError -> CInt
29
Error
MechanismParseError -> CInt
30
Error
AuthenticationError -> CInt
31
Error
IntegrityError -> CInt
33
Error
NoClientCode -> CInt
35
Error
NoServerCode -> CInt
36
Error
NoCallback -> CInt
51
Error
NoAnonymousToken -> CInt
52
Error
NoAuthID -> CInt
53
Error
NoAuthzID -> CInt
54
Error
NoPassword -> CInt
55
Error
NoPasscode -> CInt
56
Error
NoPIN -> CInt
57
Error
NoService -> CInt
58
Error
NoHostname -> CInt
59
Error
GSSAPI_ReleaseBufferError -> CInt
37
Error
GSSAPI_ImportNameError -> CInt
38
Error
GSSAPI_InitSecContextError -> CInt
39
Error
GSSAPI_AcceptSecContextError -> CInt
40
Error
GSSAPI_UnwrapError -> CInt
41
Error
GSSAPI_WrapError -> CInt
42
Error
GSSAPI_AquireCredError -> CInt
43
Error
GSSAPI_DisplayNameError -> CInt
44
Error
GSSAPI_UnsupportedProtectionError -> CInt
45
Error
GSSAPI_EncapsulateTokenError -> CInt
60
Error
GSSAPI_DecapsulateTokenError -> CInt
61
Error
GSSAPI_InquireMechForSASLNameError -> CInt
62
Error
GSSAPI_TestOIDSetMemberError -> CInt
63
Error
GSSAPI_ReleaseOIDSetError -> CInt
64
Error
KerberosV5_InitError -> CInt
46
Error
KerberosV5_InternalError -> CInt
47
Error
SecurID_ServerNeedAdditionalPasscode -> CInt
48
Error
SecurID_ServerNeedNewPIN -> CInt
49
cToError :: F.CInt -> Error
cToError :: CInt -> Error
cToError CInt
x = case CInt
x of
CInt
2 -> Error
UnknownMechanism
CInt
3 -> Error
MechanismCalledTooManyTimes
CInt
7 -> Error
MallocError
CInt
8 -> Error
Base64Error
CInt
9 -> Error
CryptoError
CInt
29 -> Error
SASLPrepError
CInt
30 -> Error
MechanismParseError
CInt
31 -> Error
AuthenticationError
CInt
33 -> Error
IntegrityError
CInt
35 -> Error
NoClientCode
CInt
36 -> Error
NoServerCode
CInt
51 -> Error
NoCallback
CInt
52 -> Error
NoAnonymousToken
CInt
53 -> Error
NoAuthID
CInt
54 -> Error
NoAuthzID
CInt
55 -> Error
NoPassword
CInt
56 -> Error
NoPasscode
CInt
57 -> Error
NoPIN
CInt
58 -> Error
NoService
CInt
59 -> Error
NoHostname
CInt
37 -> Error
GSSAPI_ReleaseBufferError
CInt
38 -> Error
GSSAPI_ImportNameError
CInt
39 -> Error
GSSAPI_InitSecContextError
CInt
40 -> Error
GSSAPI_AcceptSecContextError
CInt
41 -> Error
GSSAPI_UnwrapError
CInt
42 -> Error
GSSAPI_WrapError
CInt
43 -> Error
GSSAPI_AquireCredError
CInt
44 -> Error
GSSAPI_DisplayNameError
CInt
45 -> Error
GSSAPI_UnsupportedProtectionError
CInt
60 -> Error
GSSAPI_EncapsulateTokenError
CInt
61 -> Error
GSSAPI_DecapsulateTokenError
CInt
62 -> Error
GSSAPI_InquireMechForSASLNameError
CInt
63 -> Error
GSSAPI_TestOIDSetMemberError
CInt
64 -> Error
GSSAPI_ReleaseOIDSetError
CInt
46 -> Error
KerberosV5_InitError
CInt
47 -> Error
KerberosV5_InternalError
CInt
48 -> Error
SecurID_ServerNeedAdditionalPasscode
CInt
49 -> Error
SecurID_ServerNeedNewPIN
CInt
_ -> String -> Error
forall a. HasCallStack => String -> a
error (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ String
"Unknown GNU SASL return code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
x
throw :: Error -> Session a
throw :: forall a. Error -> Session a
throw = IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Session a) -> (Error -> IO a) -> Error -> Session a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SASLException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (SASLException -> IO a)
-> (Error -> SASLException) -> Error -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> SASLException
SASLException
catch :: Session a -> (Error -> Session a) -> Session a
catch :: forall a. Session a -> (Error -> Session a) -> Session a
catch Session a
m Error -> Session a
f = do
SessionCtx
sctx <- Ptr SessionCtx -> SessionCtx
SessionCtx (Ptr SessionCtx -> SessionCtx)
-> Session (Ptr SessionCtx) -> Session SessionCtx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Session (Ptr SessionCtx)
getSessionContext
ReaderT SessionCtx IO a -> Session a
forall a. ReaderT SessionCtx IO a -> Session a
Session (ReaderT SessionCtx IO a -> Session a)
-> (IO a -> ReaderT SessionCtx IO a) -> IO a -> Session a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ReaderT SessionCtx IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Session a) -> IO a -> Session a
forall a b. (a -> b) -> a -> b
$ IO a -> (SASLException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
(ReaderT SessionCtx IO a -> SessionCtx -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT (Session a -> ReaderT SessionCtx IO a
forall a. Session a -> ReaderT SessionCtx IO a
unSession Session a
m) SessionCtx
sctx)
(\(SASLException Error
err) -> ReaderT SessionCtx IO a -> SessionCtx -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT (Session a -> ReaderT SessionCtx IO a
forall a. Session a -> ReaderT SessionCtx IO a
unSession (Error -> Session a
f Error
err)) SessionCtx
sctx)
handle :: (Error -> Session a) -> Session a -> Session a
handle :: forall a. (Error -> Session a) -> Session a -> Session a
handle = (Session a -> (Error -> Session a) -> Session a)
-> (Error -> Session a) -> Session a -> Session a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Session a -> (Error -> Session a) -> Session a
forall a. Session a -> (Error -> Session a) -> Session a
catch
try :: Session a -> Session (Either Error a)
try :: forall a. Session a -> Session (Either Error a)
try Session a
m = Session (Either Error a)
-> (Error -> Session (Either Error a)) -> Session (Either Error a)
forall a. Session a -> (Error -> Session a) -> Session a
catch ((a -> Either Error a) -> Session a -> Session (Either Error a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either Error a
forall a b. b -> Either a b
Right Session a
m) (Either Error a -> Session (Either Error a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a -> Session (Either Error a))
-> (Error -> Either Error a) -> Error -> Session (Either Error a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Either Error a
forall a b. a -> Either a b
Left)
data Property
= PropertyAuthID
| PropertyAuthzID
| PropertyPassword
| PropertyAnonymousToken
| PropertyService
| PropertyHostname
| PropertyGSSAPIDisplayName
| PropertyPasscode
| PropertySuggestedPIN
| PropertyPIN
| PropertyRealm
| PropertyDigestMD5HashedPassword
| PropertyQOPS
| PropertyQOP
| PropertyScramIter
| PropertyScramSalt
| PropertyScramSaltedPassword
| ValidateSimple
| ValidateExternal
| ValidateAnonymous
| ValidateGSSAPI
| ValidateSecurID
deriving (Int -> Property -> String -> String
[Property] -> String -> String
Property -> String
(Int -> Property -> String -> String)
-> (Property -> String)
-> ([Property] -> String -> String)
-> Show Property
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Property] -> String -> String
$cshowList :: [Property] -> String -> String
show :: Property -> String
$cshow :: Property -> String
showsPrec :: Int -> Property -> String -> String
$cshowsPrec :: Int -> Property -> String -> String
Show, Property -> Property -> Bool
(Property -> Property -> Bool)
-> (Property -> Property -> Bool) -> Eq Property
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Property -> Property -> Bool
$c/= :: Property -> Property -> Bool
== :: Property -> Property -> Bool
$c== :: Property -> Property -> Bool
Eq)
cFromProperty :: Property -> F.CInt
cFromProperty :: Property -> CInt
cFromProperty Property
x = case Property
x of
Property
PropertyAuthID -> CInt
1
Property
PropertyAuthzID -> CInt
2
Property
PropertyPassword -> CInt
3
Property
PropertyAnonymousToken -> CInt
4
Property
PropertyService -> CInt
5
Property
PropertyHostname -> CInt
6
Property
PropertyGSSAPIDisplayName -> CInt
7
Property
PropertyPasscode -> CInt
8
Property
PropertySuggestedPIN -> CInt
9
Property
PropertyPIN -> CInt
10
Property
PropertyRealm -> CInt
11
Property
PropertyDigestMD5HashedPassword -> CInt
12
Property
PropertyQOPS -> CInt
13
Property
PropertyQOP -> CInt
14
Property
PropertyScramIter -> CInt
15
Property
PropertyScramSalt -> CInt
16
Property
PropertyScramSaltedPassword -> CInt
17
Property
ValidateSimple -> CInt
500
Property
ValidateExternal -> CInt
501
Property
ValidateAnonymous -> CInt
502
Property
ValidateGSSAPI -> CInt
503
Property
ValidateSecurID -> CInt
504
cToProperty :: F.CInt -> Property
cToProperty :: CInt -> Property
cToProperty CInt
x = case CInt
x of
CInt
1 -> Property
PropertyAuthID
CInt
2 -> Property
PropertyAuthzID
CInt
3 -> Property
PropertyPassword
CInt
4 -> Property
PropertyAnonymousToken
CInt
5 -> Property
PropertyService
CInt
6 -> Property
PropertyHostname
CInt
7 -> Property
PropertyGSSAPIDisplayName
CInt
8 -> Property
PropertyPasscode
CInt
9 -> Property
PropertySuggestedPIN
CInt
10 -> Property
PropertyPIN
CInt
11 -> Property
PropertyRealm
CInt
12 -> Property
PropertyDigestMD5HashedPassword
CInt
13 -> Property
PropertyQOPS
CInt
14 -> Property
PropertyQOP
CInt
15 -> Property
PropertyScramIter
CInt
16 -> Property
PropertyScramSalt
CInt
17 -> Property
PropertyScramSaltedPassword
CInt
500 -> Property
ValidateSimple
CInt
501 -> Property
ValidateExternal
CInt
502 -> Property
ValidateAnonymous
CInt
503 -> Property
ValidateGSSAPI
CInt
504 -> Property
ValidateSecurID
CInt
_ -> String -> Property
forall a. HasCallStack => String -> a
error (String -> Property) -> String -> Property
forall a b. (a -> b) -> a -> b
$ String
"Unknown GNU SASL property code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
x
setProperty :: Property -> B.ByteString -> Session ()
setProperty :: Property -> ByteString -> Session ()
setProperty Property
prop ByteString
bytes = do
Ptr SessionCtx
sctx <- Session (Ptr SessionCtx)
getSessionContext
IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$
ByteString -> (Ptr CChar -> IO ()) -> IO ()
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
B.useAsCString ByteString
bytes ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
Ptr SessionCtx -> CInt -> Ptr CChar -> IO ()
gsasl_property_set Ptr SessionCtx
sctx (Property -> CInt
cFromProperty Property
prop)
getProperty :: Property -> Session (Maybe B.ByteString)
getProperty :: Property -> Session (Maybe ByteString)
getProperty Property
prop = do
Ptr SessionCtx
sctx <- Session (Ptr SessionCtx)
getSessionContext
IO (Maybe ByteString) -> Session (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> Session (Maybe ByteString))
-> IO (Maybe ByteString) -> Session (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ do
Ptr CChar
cstr <- Ptr SessionCtx -> CInt -> IO (Ptr CChar)
gsasl_property_get Ptr SessionCtx
sctx (Property -> CInt
cFromProperty Property
prop)
if Ptr CChar
cstr Ptr CChar -> Ptr CChar -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr CChar
forall a. Ptr a
F.nullPtr
then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CChar -> IO ByteString
B.packCString Ptr CChar
cstr
else do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr SessionCtx -> IO ()
checkCallbackException Ptr SessionCtx
sctx
Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
getPropertyFast :: Property -> Session (Maybe B.ByteString)
getPropertyFast :: Property -> Session (Maybe ByteString)
getPropertyFast Property
prop = do
Ptr SessionCtx
sctx <- Session (Ptr SessionCtx)
getSessionContext
IO (Maybe ByteString) -> Session (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> Session (Maybe ByteString))
-> IO (Maybe ByteString) -> Session (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
Ptr SessionCtx -> CInt -> IO (Ptr CChar)
gsasl_property_fast Ptr SessionCtx
sctx (Property -> CInt
cFromProperty Property
prop) IO (Ptr CChar)
-> (Ptr CChar -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(Ptr CChar -> IO ByteString) -> Ptr CChar -> IO (Maybe ByteString)
forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
F.maybePeek Ptr CChar -> IO ByteString
B.packCString
type CallbackFn = F.Ptr Context -> F.Ptr SessionCtx -> F.CInt -> IO F.CInt
data CallbackHook = CallbackHook (F.FunPtr CallbackFn) (Property -> Session Progress)
newCallbackHook :: (Property -> Session Progress) -> IO (F.Ptr CallbackHook, F.FunPtr CallbackFn)
newCallbackHook :: (Property -> Session Progress)
-> IO (Ptr CallbackHook, FunPtr CallbackFn)
newCallbackHook Property -> Session Progress
cb = IO (FunPtr CallbackFn)
-> (FunPtr CallbackFn -> IO ())
-> (FunPtr CallbackFn -> IO (Ptr CallbackHook, FunPtr CallbackFn))
-> IO (Ptr CallbackHook, FunPtr CallbackFn)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
(CallbackFn -> IO (FunPtr CallbackFn)
wrapCallbackImpl ((Property -> Session Progress) -> CallbackFn
callbackImpl Property -> Session Progress
cb))
FunPtr CallbackFn -> IO ()
forall a. FunPtr a -> IO ()
F.freeHaskellFunPtr
(\FunPtr CallbackFn
funPtr -> let hook :: CallbackHook
hook = FunPtr CallbackFn -> (Property -> Session Progress) -> CallbackHook
CallbackHook FunPtr CallbackFn
funPtr Property -> Session Progress
cb in IO (StablePtr CallbackHook)
-> (StablePtr CallbackHook -> IO ())
-> (StablePtr CallbackHook
-> IO (Ptr CallbackHook, FunPtr CallbackFn))
-> IO (Ptr CallbackHook, FunPtr CallbackFn)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
(CallbackHook -> IO (StablePtr CallbackHook)
forall a. a -> IO (StablePtr a)
F.newStablePtr CallbackHook
hook)
StablePtr CallbackHook -> IO ()
forall a. StablePtr a -> IO ()
F.freeStablePtr
(\StablePtr CallbackHook
stablePtr -> let
hookPtr :: Ptr b
hookPtr = Ptr () -> Ptr b
forall a b. Ptr a -> Ptr b
F.castPtr (StablePtr CallbackHook -> Ptr ()
forall a. StablePtr a -> Ptr ()
F.castStablePtrToPtr StablePtr CallbackHook
stablePtr)
in (Ptr CallbackHook, FunPtr CallbackFn)
-> IO (Ptr CallbackHook, FunPtr CallbackFn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr CallbackHook
forall a. Ptr a
hookPtr, FunPtr CallbackFn
funPtr)))
freeCallbackHook :: F.Ptr CallbackHook -> IO ()
freeCallbackHook :: Ptr CallbackHook -> IO ()
freeCallbackHook Ptr CallbackHook
ptr = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Ptr CallbackHook
ptr Ptr CallbackHook -> Ptr CallbackHook -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CallbackHook
forall a. Ptr a
F.nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let stablePtr :: StablePtr a
stablePtr = Ptr () -> StablePtr a
forall a. Ptr () -> StablePtr a
F.castPtrToStablePtr (Ptr () -> StablePtr a) -> Ptr () -> StablePtr a
forall a b. (a -> b) -> a -> b
$ Ptr CallbackHook -> Ptr ()
forall a b. Ptr a -> Ptr b
F.castPtr Ptr CallbackHook
ptr
CallbackHook
hook <- StablePtr CallbackHook -> IO CallbackHook
forall a. StablePtr a -> IO a
F.deRefStablePtr StablePtr CallbackHook
forall {a}. StablePtr a
stablePtr
StablePtr Any -> IO ()
forall a. StablePtr a -> IO ()
F.freeStablePtr StablePtr Any
forall {a}. StablePtr a
stablePtr
let (CallbackHook FunPtr CallbackFn
funPtr Property -> Session Progress
_) = CallbackHook
hook
FunPtr CallbackFn -> IO ()
forall a. FunPtr a -> IO ()
F.freeHaskellFunPtr FunPtr CallbackFn
funPtr
callbackImpl :: (Property -> Session Progress) -> CallbackFn
callbackImpl :: (Property -> Session Progress) -> CallbackFn
callbackImpl Property -> Session Progress
cb Ptr Context
_ Ptr SessionCtx
sctx CInt
cProp = let
globalIO :: a
globalIO = String -> a
forall a. HasCallStack => String -> a
error String
"globalIO is not implemented"
sessionIO :: IO CInt
sessionIO = do
let session :: Session Progress
session = Property -> Session Progress
cb (Property -> Session Progress) -> Property -> Session Progress
forall a b. (a -> b) -> a -> b
$ CInt -> Property
cToProperty CInt
cProp
Progress -> CInt
cFromProgress (Progress -> CInt) -> IO Progress -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SessionCtx IO Progress -> SessionCtx -> IO Progress
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
R.runReaderT (Session Progress -> ReaderT SessionCtx IO Progress
forall a. Session a -> ReaderT SessionCtx IO a
unSession Session Progress
session) (Ptr SessionCtx -> SessionCtx
SessionCtx Ptr SessionCtx
sctx)
onError :: SASLException -> IO F.CInt
onError :: SASLException -> IO CInt
onError (SASLException Error
err) = CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ Error -> CInt
cFromError Error
err
onException :: E.SomeException -> IO F.CInt
onException :: SomeException -> IO CInt
onException SomeException
exc = do
StablePtr SomeException
stablePtr <- SomeException -> IO (StablePtr SomeException)
forall a. a -> IO (StablePtr a)
F.newStablePtr SomeException
exc
Ptr SessionCtx -> Ptr () -> IO ()
forall a. Ptr SessionCtx -> Ptr a -> IO ()
gsasl_session_hook_set Ptr SessionCtx
sctx (Ptr () -> IO ()) -> Ptr () -> IO ()
forall a b. (a -> b) -> a -> b
$ StablePtr SomeException -> Ptr ()
forall a. StablePtr a -> Ptr ()
F.castStablePtrToPtr StablePtr SomeException
stablePtr
CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (-CInt
1)
catchErrors :: IO CInt -> IO CInt
catchErrors IO CInt
io = IO CInt -> [Handler CInt] -> IO CInt
forall a. IO a -> [Handler a] -> IO a
E.catches IO CInt
io [(SASLException -> IO CInt) -> Handler CInt
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler SASLException -> IO CInt
onError, (SomeException -> IO CInt) -> Handler CInt
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler SomeException -> IO CInt
onException]
in IO CInt -> IO CInt
catchErrors (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ if Ptr SessionCtx
sctx Ptr SessionCtx -> Ptr SessionCtx -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr SessionCtx
forall a. Ptr a
F.nullPtr then IO CInt
forall {a}. a
globalIO else IO CInt
sessionIO
foreign import ccall "wrapper"
wrapCallbackImpl :: CallbackFn -> IO (F.FunPtr CallbackFn)
checkCallbackException :: F.Ptr SessionCtx -> IO ()
checkCallbackException :: Ptr SessionCtx -> IO ()
checkCallbackException Ptr SessionCtx
sctx = do
Ptr ()
hook <- Ptr SessionCtx -> IO (Ptr ())
forall a. Ptr SessionCtx -> IO (Ptr a)
gsasl_session_hook_get Ptr SessionCtx
sctx
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr ()
hook Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr ()
forall a. Ptr a
F.nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let stable :: StablePtr a
stable = Ptr () -> StablePtr a
forall a. Ptr () -> StablePtr a
F.castPtrToStablePtr Ptr ()
hook
SomeException
exc <- StablePtr SomeException -> IO SomeException
forall a. StablePtr a -> IO a
F.deRefStablePtr StablePtr SomeException
forall {a}. StablePtr a
stable
StablePtr Any -> IO ()
forall a. StablePtr a -> IO ()
F.freeStablePtr StablePtr Any
forall {a}. StablePtr a
stable
SomeException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (SomeException
exc :: E.SomeException)
setCallback :: (Property -> Session Progress) -> SASL ()
setCallback :: (Property -> Session Progress) -> SASL ()
setCallback Property -> Session Progress
cb = do
Ptr Context
ctx <- SASL (Ptr Context)
getContext
IO () -> SASL ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SASL ()) -> IO () -> SASL ()
forall a b. (a -> b) -> a -> b
$ do
Ptr CallbackHook -> IO ()
freeCallbackHook (Ptr CallbackHook -> IO ()) -> IO (Ptr CallbackHook) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Context -> IO (Ptr CallbackHook)
forall a. Ptr Context -> IO (Ptr a)
gsasl_callback_hook_get Ptr Context
ctx
(Ptr CallbackHook
hook, FunPtr CallbackFn
cbPtr) <- (Property -> Session Progress)
-> IO (Ptr CallbackHook, FunPtr CallbackFn)
newCallbackHook Property -> Session Progress
cb
Ptr Context -> Ptr CallbackHook -> IO ()
forall a. Ptr Context -> Ptr a -> IO ()
gsasl_callback_hook_set Ptr Context
ctx Ptr CallbackHook
hook
Ptr Context -> FunPtr CallbackFn -> IO ()
gsasl_callback_set Ptr Context
ctx FunPtr CallbackFn
cbPtr
runCallback :: Property -> Session Progress
runCallback :: Property -> Session Progress
runCallback Property
prop = do
Ptr Context
ctx <- (Ptr SessionCtx -> Ptr Context)
-> Session (Ptr SessionCtx) -> Session (Ptr Context)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr SessionCtx -> Ptr Context
forall a b. Ptr a -> Ptr b
F.castPtr Session (Ptr SessionCtx)
getSessionContext
Ptr ()
hookPtr <- IO (Ptr ()) -> Session (Ptr ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr ()) -> Session (Ptr ()))
-> IO (Ptr ()) -> Session (Ptr ())
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr ())
forall a. Ptr Context -> IO (Ptr a)
gsasl_callback_hook_get Ptr Context
ctx
Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr ()
hookPtr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
F.nullPtr) (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ Error -> Session ()
forall a. Error -> Session a
throw Error
NoCallback
CallbackHook
hook <- IO CallbackHook -> Session CallbackHook
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CallbackHook -> Session CallbackHook)
-> IO CallbackHook -> Session CallbackHook
forall a b. (a -> b) -> a -> b
$ StablePtr CallbackHook -> IO CallbackHook
forall a. StablePtr a -> IO a
F.deRefStablePtr (StablePtr CallbackHook -> IO CallbackHook)
-> StablePtr CallbackHook -> IO CallbackHook
forall a b. (a -> b) -> a -> b
$ Ptr () -> StablePtr CallbackHook
forall a. Ptr () -> StablePtr a
F.castPtrToStablePtr Ptr ()
hookPtr
let (CallbackHook FunPtr CallbackFn
_ Property -> Session Progress
cb) = CallbackHook
hook
Property -> Session Progress
cb Property
prop
data Progress = Complete | NeedsMore
deriving (Int -> Progress -> String -> String
[Progress] -> String -> String
Progress -> String
(Int -> Progress -> String -> String)
-> (Progress -> String)
-> ([Progress] -> String -> String)
-> Show Progress
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Progress] -> String -> String
$cshowList :: [Progress] -> String -> String
show :: Progress -> String
$cshow :: Progress -> String
showsPrec :: Int -> Progress -> String -> String
$cshowsPrec :: Int -> Progress -> String -> String
Show, Progress -> Progress -> Bool
(Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool) -> Eq Progress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c== :: Progress -> Progress -> Bool
Eq)
cFromProgress :: Progress -> F.CInt
cFromProgress :: Progress -> CInt
cFromProgress Progress
x = case Progress
x of
Progress
Complete -> CInt
0
Progress
NeedsMore -> CInt
1
step :: B.ByteString -> Session (B.ByteString, Progress)
step :: ByteString -> Session (ByteString, Progress)
step ByteString
input = (Ptr SessionCtx -> IO (Ptr CChar, CSize, Progress))
-> ((Ptr CChar, CSize, Progress) -> IO ())
-> ((Ptr CChar, CSize, Progress) -> IO (ByteString, Progress))
-> Session (ByteString, Progress)
forall a b c.
(Ptr SessionCtx -> IO a) -> (a -> IO b) -> (a -> IO c) -> Session c
bracketSession Ptr SessionCtx -> IO (Ptr CChar, CSize, Progress)
get (Ptr CChar, CSize, Progress) -> IO ()
forall {a} {b} {c}. (Ptr a, b, c) -> IO ()
free (Ptr CChar, CSize, Progress) -> IO (ByteString, Progress)
forall {a} {b}.
Integral a =>
(Ptr CChar, a, b) -> IO (ByteString, b)
peek where
get :: Ptr SessionCtx -> IO (Ptr CChar, CSize, Progress)
get Ptr SessionCtx
sctx =
ByteString
-> (CStringLen -> IO (Ptr CChar, CSize, Progress))
-> IO (Ptr CChar, CSize, Progress)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
input ((CStringLen -> IO (Ptr CChar, CSize, Progress))
-> IO (Ptr CChar, CSize, Progress))
-> (CStringLen -> IO (Ptr CChar, CSize, Progress))
-> IO (Ptr CChar, CSize, Progress)
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
pInput, Int
inputLen) ->
(Ptr (Ptr CChar) -> IO (Ptr CChar, CSize, Progress))
-> IO (Ptr CChar, CSize, Progress)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO (Ptr CChar, CSize, Progress))
-> IO (Ptr CChar, CSize, Progress))
-> (Ptr (Ptr CChar) -> IO (Ptr CChar, CSize, Progress))
-> IO (Ptr CChar, CSize, Progress)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pOutput ->
(Ptr CSize -> IO (Ptr CChar, CSize, Progress))
-> IO (Ptr CChar, CSize, Progress)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr CSize -> IO (Ptr CChar, CSize, Progress))
-> IO (Ptr CChar, CSize, Progress))
-> (Ptr CSize -> IO (Ptr CChar, CSize, Progress))
-> IO (Ptr CChar, CSize, Progress)
forall a b. (a -> b) -> a -> b
$ \Ptr CSize
pOutputLen -> do
CInt
rc <- Ptr SessionCtx
-> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt
gsasl_step Ptr SessionCtx
sctx Ptr CChar
pInput (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
inputLen) Ptr (Ptr CChar)
pOutput Ptr CSize
pOutputLen
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr SessionCtx -> IO ()
checkCallbackException Ptr SessionCtx
sctx
Progress
progress <- CInt -> IO Progress
checkStepRC CInt
rc
CSize
cstrLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
F.peek Ptr CSize
pOutputLen
Ptr CChar
cstr <- Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr CChar)
pOutput
(Ptr CChar, CSize, Progress) -> IO (Ptr CChar, CSize, Progress)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr CChar
cstr, CSize
cstrLen, Progress
progress)
free :: (Ptr a, b, c) -> IO ()
free (Ptr a
cstr, b
_, c
_) = Ptr a -> IO ()
forall a. Ptr a -> IO ()
gsasl_free Ptr a
cstr
peek :: (Ptr CChar, a, b) -> IO (ByteString, b)
peek (Ptr CChar
cstr, a
cstrLen, b
progress) = do
ByteString
output <- CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
cstr, a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
cstrLen)
(ByteString, b) -> IO (ByteString, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
output, b
progress)
step64 :: B.ByteString -> Session (B.ByteString, Progress)
step64 :: ByteString -> Session (ByteString, Progress)
step64 ByteString
input = (Ptr SessionCtx -> IO (Ptr CChar, Progress))
-> ((Ptr CChar, Progress) -> IO ())
-> ((Ptr CChar, Progress) -> IO (ByteString, Progress))
-> Session (ByteString, Progress)
forall a b c.
(Ptr SessionCtx -> IO a) -> (a -> IO b) -> (a -> IO c) -> Session c
bracketSession Ptr SessionCtx -> IO (Ptr CChar, Progress)
get (Ptr CChar, Progress) -> IO ()
forall {a} {b}. (Ptr a, b) -> IO ()
free (Ptr CChar, Progress) -> IO (ByteString, Progress)
forall {b}. (Ptr CChar, b) -> IO (ByteString, b)
peek where
get :: Ptr SessionCtx -> IO (Ptr CChar, Progress)
get Ptr SessionCtx
sctx =
ByteString
-> (Ptr CChar -> IO (Ptr CChar, Progress))
-> IO (Ptr CChar, Progress)
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
B.useAsCString ByteString
input ((Ptr CChar -> IO (Ptr CChar, Progress))
-> IO (Ptr CChar, Progress))
-> (Ptr CChar -> IO (Ptr CChar, Progress))
-> IO (Ptr CChar, Progress)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
pInput ->
(Ptr (Ptr CChar) -> IO (Ptr CChar, Progress))
-> IO (Ptr CChar, Progress)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO (Ptr CChar, Progress))
-> IO (Ptr CChar, Progress))
-> (Ptr (Ptr CChar) -> IO (Ptr CChar, Progress))
-> IO (Ptr CChar, Progress)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pOutput -> do
CInt
rc <- Ptr SessionCtx -> Ptr CChar -> Ptr (Ptr CChar) -> IO CInt
gsasl_step64 Ptr SessionCtx
sctx Ptr CChar
pInput Ptr (Ptr CChar)
pOutput
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr SessionCtx -> IO ()
checkCallbackException Ptr SessionCtx
sctx
Progress
progress <- CInt -> IO Progress
checkStepRC CInt
rc
Ptr CChar
cstr <- Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr CChar)
pOutput
(Ptr CChar, Progress) -> IO (Ptr CChar, Progress)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr CChar
cstr, Progress
progress)
free :: (Ptr a, b) -> IO ()
free (Ptr a
cstr, b
_) = Ptr a -> IO ()
forall a. Ptr a -> IO ()
gsasl_free Ptr a
cstr
peek :: (Ptr CChar, b) -> IO (ByteString, b)
peek (Ptr CChar
cstr, b
progress) = do
ByteString
output <- Ptr CChar -> IO ByteString
B.packCString Ptr CChar
cstr
(ByteString, b) -> IO (ByteString, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
output, b
progress)
checkStepRC :: F.CInt -> IO Progress
checkStepRC :: CInt -> IO Progress
checkStepRC CInt
x = case CInt
x of
CInt
0 -> Progress -> IO Progress
forall (m :: * -> *) a. Monad m => a -> m a
return Progress
Complete
CInt
1 -> Progress -> IO Progress
forall (m :: * -> *) a. Monad m => a -> m a
return Progress
NeedsMore
CInt
_ -> SASLException -> IO Progress
forall e a. Exception e => e -> IO a
E.throwIO (Error -> SASLException
SASLException (CInt -> Error
cToError CInt
x))
encodeDecodeHelper :: (F.Storable a, Integral a, Num t) =>
(F.Ptr SessionCtx -> F.Ptr F.CChar -> t -> F.Ptr (F.Ptr F.CChar) -> F.Ptr a -> IO F.CInt)
-> B.ByteString
-> Session B.ByteString
encodeDecodeHelper :: forall a t.
(Storable a, Integral a, Num t) =>
(Ptr SessionCtx
-> Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt)
-> ByteString -> Session ByteString
encodeDecodeHelper Ptr SessionCtx
-> Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt
f ByteString
input = do
Ptr SessionCtx
sctx <- Session (Ptr SessionCtx)
getSessionContext
IO ByteString -> Session ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Session ByteString)
-> IO ByteString -> Session ByteString
forall a b. (a -> b) -> a -> b
$
ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
input ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstr, Int
cstrLen) ->
(Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString)
-> (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pOutput ->
(Ptr a -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr a -> IO ByteString) -> IO ByteString)
-> (Ptr a -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr a
pOutputLen -> do
CInt
rc <- Ptr SessionCtx
-> Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt
f Ptr SessionCtx
sctx Ptr CChar
cstr (Int -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cstrLen) Ptr (Ptr CChar)
pOutput Ptr a
pOutputLen
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rc CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr SessionCtx -> IO ()
checkCallbackException Ptr SessionCtx
sctx
CInt -> IO ()
checkRC CInt
rc
Ptr CChar
output <- Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr CChar)
pOutput
Int
outputLen <- a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int) -> IO a -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
F.peek Ptr a
pOutputLen
ByteString
outputBytes <- CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
output, Int
outputLen)
Ptr CChar -> IO ()
forall a. Ptr a -> IO ()
gsasl_free Ptr CChar
output
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
outputBytes
encode :: B.ByteString -> Session B.ByteString
encode :: ByteString -> Session ByteString
encode = (Ptr SessionCtx
-> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt)
-> ByteString -> Session ByteString
forall a t.
(Storable a, Integral a, Num t) =>
(Ptr SessionCtx
-> Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt)
-> ByteString -> Session ByteString
encodeDecodeHelper Ptr SessionCtx
-> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt
gsasl_encode
decode :: B.ByteString -> Session B.ByteString
decode :: ByteString -> Session ByteString
decode = (Ptr SessionCtx
-> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt)
-> ByteString -> Session ByteString
forall a t.
(Storable a, Integral a, Num t) =>
(Ptr SessionCtx
-> Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt)
-> ByteString -> Session ByteString
encodeDecodeHelper Ptr SessionCtx
-> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt
gsasl_decode
base64Helper :: (F.Storable a, Integral a, Num t) =>
(F.Ptr F.CChar -> t -> F.Ptr (F.Ptr F.CChar) -> F.Ptr a -> IO F.CInt)
-> B.ByteString
-> B.ByteString
base64Helper :: forall a t.
(Storable a, Integral a, Num t) =>
(Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt)
-> ByteString -> ByteString
base64Helper Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt
f ByteString
input = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
input ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
pIn, Int
inLen) ->
(Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString)
-> (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pOut ->
(Ptr a -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr a -> IO ByteString) -> IO ByteString)
-> (Ptr a -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr a
pOutLen -> do
Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt
f Ptr CChar
pIn (Int -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
inLen) Ptr (Ptr CChar)
pOut Ptr a
pOutLen IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
a
outLen <- Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
F.peek Ptr a
pOutLen
Ptr CChar
outPtr <- Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr CChar)
pOut
CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
outPtr, a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
outLen)
toBase64 :: B.ByteString -> B.ByteString
toBase64 :: ByteString -> ByteString
toBase64 = (Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt)
-> ByteString -> ByteString
forall a t.
(Storable a, Integral a, Num t) =>
(Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt)
-> ByteString -> ByteString
base64Helper Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt
gsasl_base64_to
fromBase64 :: B.ByteString -> B.ByteString
fromBase64 :: ByteString -> ByteString
fromBase64 = (Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt)
-> ByteString -> ByteString
forall a t.
(Storable a, Integral a, Num t) =>
(Ptr CChar -> t -> Ptr (Ptr CChar) -> Ptr a -> IO CInt)
-> ByteString -> ByteString
base64Helper Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt
gsasl_base64_from
md5 :: B.ByteString -> B.ByteString
md5 :: ByteString -> ByteString
md5 ByteString
input = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
input ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
pIn, Int
inLen) ->
(Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString)
-> (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pOut ->
Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
F.allocaBytes Int
16 ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
outBuf -> do
Ptr (Ptr CChar) -> Ptr CChar -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
F.poke Ptr (Ptr CChar)
pOut Ptr CChar
outBuf
Ptr CChar -> CSize -> Ptr (Ptr CChar) -> IO CInt
gsasl_md5 Ptr CChar
pIn (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
inLen) Ptr (Ptr CChar)
pOut IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
outBuf, Int
16)
sha1 :: B.ByteString -> B.ByteString
sha1 :: ByteString -> ByteString
sha1 ByteString
input = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
input ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
pIn, Int
inLen) ->
(Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString)
-> (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pOut -> do
Ptr CChar -> CSize -> Ptr (Ptr CChar) -> IO CInt
gsasl_sha1 Ptr CChar
pIn (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
inLen) Ptr (Ptr CChar)
pOut IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
Ptr CChar
outBuf <- Ptr (Ptr CChar) -> IO (Ptr CChar)
forall a. Storable a => Ptr a -> IO a
F.peek Ptr (Ptr CChar)
pOut
ByteString
ret <- CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
outBuf, Int
20)
Ptr CChar -> IO ()
forall a. Ptr a -> IO ()
F.free Ptr CChar
outBuf
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
ret
hmacMD5 :: B.ByteString
-> B.ByteString
-> B.ByteString
hmacMD5 :: ByteString -> ByteString -> ByteString
hmacMD5 ByteString
key ByteString
input = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
key ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
pKey, Int
keyLen) ->
ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
input ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
pIn, Int
inLen) ->
(Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString)
-> (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pOut ->
Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
F.allocaBytes Int
16 ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
outBuf -> do
Ptr (Ptr CChar) -> Ptr CChar -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
F.poke Ptr (Ptr CChar)
pOut Ptr CChar
outBuf
Ptr CChar
-> CSize -> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> IO CInt
gsasl_hmac_md5 Ptr CChar
pKey (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
keyLen) Ptr CChar
pIn (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
inLen) Ptr (Ptr CChar)
pOut IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
outBuf, Int
16)
hmacSHA1 :: B.ByteString
-> B.ByteString
-> B.ByteString
hmacSHA1 :: ByteString -> ByteString -> ByteString
hmacSHA1 ByteString
key ByteString
input = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
key ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
pKey, Int
keyLen) ->
ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
input ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
pIn, Int
inLen) ->
(Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString)
-> (Ptr (Ptr CChar) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
pOut ->
Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
F.allocaBytes Int
20 ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
outBuf -> do
Ptr (Ptr CChar) -> Ptr CChar -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
F.poke Ptr (Ptr CChar)
pOut Ptr CChar
outBuf
Ptr CChar
-> CSize -> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> IO CInt
gsasl_hmac_sha1 Ptr CChar
pKey (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
keyLen) Ptr CChar
pIn (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
inLen) Ptr (Ptr CChar)
pOut IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
outBuf, Int
20)
nonce :: Integer -> IO B.ByteString
nonce :: Integer -> IO ByteString
nonce Integer
size = Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
F.allocaBytes (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
size) ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buf -> do
Ptr CChar -> CSize -> IO CInt
gsasl_nonce Ptr CChar
buf (Integer -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
size) IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
buf, Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
size)
random :: Integer -> IO B.ByteString
random :: Integer -> IO ByteString
random Integer
size = Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. Int -> (Ptr a -> IO b) -> IO b
F.allocaBytes (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
size) ((Ptr CChar -> IO ByteString) -> IO ByteString)
-> (Ptr CChar -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buf -> do
Ptr CChar -> CSize -> IO CInt
gsasl_random Ptr CChar
buf (Integer -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
size) IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO ()
checkRC
CStringLen -> IO ByteString
B.packCStringLen (Ptr CChar
buf, Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
size)
checkRC :: F.CInt -> IO ()
checkRC :: CInt -> IO ()
checkRC CInt
x = case CInt
x of
CInt
0 -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CInt
_ -> SASLException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (Error -> SASLException
SASLException (CInt -> Error
cToError CInt
x))
foreign import ccall "hsgsasl_VERSION_MAJOR"
hsgsasl_VERSION_MAJOR :: F.CInt
foreign import ccall "hsgsasl_VERSION_MINOR"
hsgsasl_VERSION_MINOR :: F.CInt
foreign import ccall "hsgsasl_VERSION_PATCH"
hsgsasl_VERSION_PATCH :: F.CInt
foreign import ccall "hsgsasl_check_version"
hsgsasl_check_version :: IO F.CInt
foreign import ccall "gsasl.h gsasl_init"
gsasl_init :: F.Ptr (F.Ptr Context) -> IO F.CInt
foreign import ccall "gsasl.h gsasl_done"
gsasl_done :: F.Ptr Context -> IO ()
foreign import ccall "gsasl.h gsasl_check_version"
gsasl_check_version :: F.CString -> IO F.CString
foreign import ccall "gsasl.h gsasl_callback_set"
gsasl_callback_set :: F.Ptr Context -> F.FunPtr CallbackFn -> IO ()
foreign import ccall "gsasl.h gsasl_callback_hook_get"
gsasl_callback_hook_get :: F.Ptr Context -> IO (F.Ptr a)
foreign import ccall "gsasl.h gsasl_callback_hook_set"
gsasl_callback_hook_set :: F.Ptr Context -> F.Ptr a -> IO ()
foreign import ccall "gsasl.h gsasl_session_hook_get"
gsasl_session_hook_get :: F.Ptr SessionCtx -> IO (F.Ptr a)
foreign import ccall "gsasl.h gsasl_session_hook_set"
gsasl_session_hook_set :: F.Ptr SessionCtx -> F.Ptr a -> IO ()
foreign import ccall "gsasl.h gsasl_property_set"
gsasl_property_set :: F.Ptr SessionCtx -> F.CInt -> F.CString -> IO ()
foreign import ccall safe "gsasl.h gsasl_property_get"
gsasl_property_get :: F.Ptr SessionCtx -> F.CInt -> IO F.CString
foreign import ccall "gsasl.h gsasl_property_fast"
gsasl_property_fast :: F.Ptr SessionCtx -> F.CInt -> IO F.CString
foreign import ccall "gsasl.h gsasl_client_mechlist"
gsasl_client_mechlist :: F.Ptr Context -> F.Ptr F.CString -> IO F.CInt
foreign import ccall "gsasl.h gsasl_client_support_p"
gsasl_client_support_p :: F.Ptr Context -> F.CString -> IO F.CInt
foreign import ccall "gsasl.h gsasl_client_suggest_mechanism"
gsasl_client_suggest_mechanism :: F.Ptr Context -> F.CString -> IO F.CString
foreign import ccall "gsasl.h gsasl_server_mechlist"
gsasl_server_mechlist :: F.Ptr Context -> F.Ptr F.CString -> IO F.CInt
foreign import ccall "gsasl.h gsasl_server_support_p"
gsasl_server_support_p :: F.Ptr Context -> F.CString -> IO F.CInt
foreign import ccall safe "gsasl.h gsasl_client_start"
gsasl_client_start :: SessionProc
foreign import ccall safe "gsasl.h gsasl_server_start"
gsasl_server_start :: SessionProc
foreign import ccall safe "gsasl.h gsasl_step"
gsasl_step :: F.Ptr SessionCtx -> F.CString -> F.CSize -> F.Ptr F.CString -> F.Ptr F.CSize -> IO F.CInt
foreign import ccall safe "gsasl.h gsasl_step64"
gsasl_step64 :: F.Ptr SessionCtx -> F.CString -> F.Ptr F.CString -> IO F.CInt
foreign import ccall safe "gsasl.h gsasl_finish"
gsasl_finish :: F.Ptr SessionCtx -> IO ()
foreign import ccall safe "gsasl.h gsasl_encode"
gsasl_encode :: F.Ptr SessionCtx -> F.CString -> F.CSize -> F.Ptr F.CString -> F.Ptr F.CSize -> IO F.CInt
foreign import ccall safe "gsasl.h gsasl_decode"
gsasl_decode :: F.Ptr SessionCtx -> F.CString -> F.CSize -> F.Ptr F.CString -> F.Ptr F.CSize -> IO F.CInt
foreign import ccall "gsasl.h gsasl_mechanism_name"
gsasl_mechanism_name :: F.Ptr SessionCtx -> IO F.CString
foreign import ccall "gsasl.h gsasl_strerror"
gsasl_strerror :: F.CInt -> IO F.CString
foreign import ccall "gsasl.h gsasl_base64_to"
gsasl_base64_to :: F.CString -> F.CSize -> F.Ptr F.CString -> F.Ptr F.CSize -> IO F.CInt
foreign import ccall "gsasl.h gsasl_base64_from"
gsasl_base64_from :: F.CString -> F.CSize -> F.Ptr F.CString -> F.Ptr F.CSize -> IO F.CInt
foreign import ccall "gsasl.h gsasl_md5"
gsasl_md5 :: F.CString -> F.CSize -> F.Ptr F.CString -> IO F.CInt
foreign import ccall "gsasl.h gsasl_sha1"
gsasl_sha1 :: F.CString -> F.CSize -> F.Ptr F.CString -> IO F.CInt
foreign import ccall "gsasl.h gsasl_hmac_md5"
gsasl_hmac_md5 :: F.CString -> F.CSize -> F.CString -> F.CSize -> F.Ptr F.CString -> IO F.CInt
foreign import ccall "gsasl.h gsasl_hmac_sha1"
gsasl_hmac_sha1 :: F.CString -> F.CSize -> F.CString -> F.CSize -> F.Ptr F.CString -> IO F.CInt
foreign import ccall "gsasl.h gsasl_nonce"
gsasl_nonce :: F.CString -> F.CSize -> IO F.CInt
foreign import ccall "gsasl.h gsasl_random"
gsasl_random :: F.CString -> F.CSize -> IO F.CInt
foreign import ccall "gsasl.h gsasl_free"
gsasl_free :: F.Ptr a -> IO ()