-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Network.Protocol.SASL.GNU
	(
	-- * Library Information
	  headerVersion
	, libraryVersion
	, checkVersion

	-- * SASL Contexts
	, SASL
	, runSASL
	, setCallback
	, runCallback

	-- * Mechanisms
	, Mechanism (..)
	, clientMechanisms
	, clientSupports
	, clientSuggestMechanism
	, serverMechanisms
	, serverSupports

	-- * SASL Sessions
	, Session
	, runClient
	, runServer
	, mechanismName

	-- ** Session Properties
	, Property (..)
	, setProperty
	, getProperty
	, getPropertyFast

	-- ** Session IO
	, Progress (..)
	, step
	, step64
	, encode
	, decode

	-- ** Error handling
	, Error (..)
	, catch
	, handle
	, try
	, throw

	-- * Bundled codecs
	, toBase64
	, fromBase64
	, md5
	, sha1
	, hmacMD5
	, hmacSHA1
	, nonce
	, random
	) where

-- Imports {{{

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

-- }}}

-- Library Information {{{

-- | Which version of @gsasl.h@ this module was compiled against
headerVersion :: (Integer, Integer, Integer)
headerVersion :: (Integer, Integer, Integer)
headerVersion = (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

-- | Which version of @libgsasl.so@ is loaded
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

-- | Whether the header and library versions are compatible
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

-- }}}

-- SASL Contexts {{{

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

-- TODO: more instances

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

-- }}}

-- Mechanisms {{{

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

-- | A list of 'Mechanism's supported by the @libgsasl@ client.
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

-- | Whether there is client-side support for a specified 'Mechanism'.
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

-- | Given a list of 'Mechanism's, suggest which to use (or 'Nothing' if
-- no supported 'Mechanism' is found).
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

-- | A list of 'Mechanism's supported by the @libgsasl@ server.
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

-- | Whether there is server-side support for a specified 'Mechanism'.
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)

-- }}}

-- SASL Sessions {{{

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)

-- | Run a session using the @libgsasl@ client.
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

-- | Run a session using the @libgsasl@ server.
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

-- | The name of the session's SASL mechanism.
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

-- }}}

-- Error handling {{{

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

-- | Convert an error code to a human-readable string explanation for the
-- particular error code.
--
-- This string can be used to output a diagnostic message to the user.
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)

-- }}}

-- Session Properties {{{

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

-- | Store some data in the session for the given property. The data must
-- be @NULL@-terminated.
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)

-- | Retrieve the data stored in the session for the given property,
-- possibly invoking the current callback to get the value.
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

-- | Retrieve the data stored in the session for the given property,
-- without invoking the current callback.
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

-- }}}

-- Callbacks {{{

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
		-- A bit ugly; session hooks aren't used anywhere else in
		-- the binding, so the exception is stashed here.
		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

		-- standard libgsasl return codes are all >= 0, so using -1
		-- provides an easy way to determine later whether the
		-- exception came from Haskell code.
		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)

-- Used to check whether a callback threw an exception
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)

-- | Set the current SASL callback. The callback will be used by mechanisms
-- to discover various parameters, such as usernames and passwords.
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

-- | Run the current callback; the property indicates what action the
-- callback is expected to perform.
runCallback :: Property -> Session Progress
runCallback :: Property -> Session Progress
runCallback Property
prop = do
	-- This is a bit evil; the first field in Gsasl_session is a Gsasl context,
	-- so it's safe to cast here (assuming they never change the layout).
	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

-- }}}

-- Session IO {{{

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

-- | Perform one step of SASL authentication. This reads data from the other
-- end, processes it (potentially running the callback), and returns data
-- to be sent back.
--
-- Also returns 'NeedsMore' if authentication is not yet complete.
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)

-- | A simple wrapper around 'step' which uses base64 to decode the input
-- and encode the output.
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 data according to the negotiated SASL mechanism. This might mean
-- the data is integrity or privacy protected.
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 data according to the negotiated SASL mechanism. This might mean
-- the data is integrity or privacy protected.
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

-- }}}

-- Bundled codecs {{{

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 -- ^ Key
        -> B.ByteString -- ^ Input data
        -> 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 -- ^ Key
         -> B.ByteString -- ^ Input data
         -> 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)

-- | Returns unpredictable data of a given size
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)

-- | Returns cryptographically strong random data of a given 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)


-- }}}

-- Miscellaneous {{{

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))

-- }}}

-- FFI imports {{{

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 ()

-- }}}