    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE ForeignFunctionInterface #-}

    -- 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           Control.Applicative (Applicative, pure, (<*>))
    import qualified Control.Exception as E
    import           Control.Monad (ap, when, unless)
    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           Data.Typeable (Typeable)
    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 = (major, minor, patch) where
    	major = toInteger hsgsasl_VERSION_MAJOR
    	minor = toInteger hsgsasl_VERSION_MINOR
    	patch = toInteger hsgsasl_VERSION_PATCH

    -- | Which version of @libgsasl.so@ is loaded
    libraryVersion :: IO (Integer, Integer, Integer)
    libraryVersion = io where
    	parseVersion str = case P.readP_to_S parser str of
    		[] -> Nothing
    		((parsed, _):_) -> Just parsed
    	parser = do
    		majorS <- P.munch1 isDigit
    		_ <- P.char '.'
    		minorS <- P.munch1 isDigit
    		_ <- P.char '.'
    		patchS <- P.munch1 isDigit
    		eof
    		return (read majorS, read minorS, read patchS)
    	io = do
    		cstr <- gsasl_check_version F.nullPtr
    		maybeStr <- F.maybePeek F.peekCString cstr
    		return $ case maybeStr >>= parseVersion of
    			Just version -> version
    			Nothing -> error $ "Invalid version string: " ++ show maybeStr

    	eof = do
    		s <- P.look
    		unless (null s) P.pfail

    -- | Whether the header and library versions are compatible
    checkVersion :: IO Bool
    checkVersion = fmap (== 1) hsgsasl_check_version

    -- }}}

    -- SASL Contexts {{{

    newtype Context = Context (F.Ptr Context)
    newtype SASL a = SASL { unSASL :: R.ReaderT Context IO a }

    instance Functor SASL where
    	fmap f = SASL . fmap f . unSASL

    instance Applicative SASL where
            pure = SASL . pure
            (<*>) = ap

    instance Monad SASL where
    	return = SASL . return
    	(>>=) sasl f = SASL $ unSASL sasl >>= unSASL . f

    instance MonadIO SASL where
    	liftIO = SASL . liftIO

    -- TODO: more instances

    runSASL :: SASL a -> IO a
    runSASL = withContext . R.runReaderT . unSASL

    withContext :: (Context -> IO a) -> IO a
    withContext = E.bracket newContext freeContext where
    	newContext = F.alloca $ \pCtxt -> do
    		gsasl_init pCtxt >>= checkRC
    		Context `fmap` F.peek pCtxt
    	freeContext (Context ctx) = do
    		hook <- gsasl_callback_hook_get ctx
    		gsasl_done ctx
    		freeCallbackHook hook

    getContext :: SASL (F.Ptr Context)
    getContext = SASL $ do
    	Context ptr <- R.ask
    	return ptr

    bracketSASL :: (F.Ptr Context -> IO a) -> (a -> IO b) -> (a -> IO c) -> SASL c
    bracketSASL before after thing = do
    	ctx <- getContext
    	liftIO $ E.bracket (before ctx) after thing

    -- }}}

    -- Mechanisms {{{

    newtype Mechanism = Mechanism B.ByteString
    	deriving (Show, Eq)

    instance IsString Mechanism where
    	fromString = Mechanism . fromString

    -- | A list of 'Mechanism's supported by the @libgsasl@ client.
    clientMechanisms :: SASL [Mechanism]
    clientMechanisms = bracketSASL io gsasl_free splitMechListPtr where
    	io ctx = F.alloca $ \pStr -> do
    		gsasl_client_mechlist ctx pStr >>= checkRC
    		F.peek pStr

    -- | Whether there is client-side support for a specified 'Mechanism'.
    clientSupports :: Mechanism -> SASL Bool
    clientSupports (Mechanism name) = do
    	ctx <- getContext
    	liftIO $ B.useAsCString name $ \pName -> do
    		cres <- gsasl_client_support_p ctx pName
    		return $ cres == 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 mechs = do
    	let bytes = B.intercalate (Char8.pack " ") [x | Mechanism x <- mechs]
    	ctx <- getContext
    	liftIO $ B.useAsCString bytes $ \pMechlist ->
    		gsasl_client_suggest_mechanism ctx pMechlist >>=
    		F.maybePeek (fmap Mechanism . B.packCString)

    -- | A list of 'Mechanism's supported by the @libgsasl@ server.
    serverMechanisms :: SASL [Mechanism]
    serverMechanisms = bracketSASL io gsasl_free splitMechListPtr where
    	io ctx = F.alloca $ \pStr -> do
    		gsasl_server_mechlist ctx pStr >>= checkRC
    		F.peek pStr

    -- | Whether there is server-side support for a specified 'Mechanism'.
    serverSupports :: Mechanism -> SASL Bool
    serverSupports (Mechanism name) = do
    	ctx <- getContext
    	liftIO $ B.useAsCString name $ \pName -> do
    		cres <- gsasl_server_support_p ctx pName
    		return $ cres == 1

    splitMechListPtr :: F.CString -> IO [Mechanism]
    splitMechListPtr ptr = unfoldrM step' (ptr, ptr, 0, True) where
    	step' (_, _, _, False) = return Nothing
    	step' (p_0, p_i, i, _) = F.peek p_i >>= \chr -> let
    		p_i' = F.plusPtr p_i 1
    		peek continue = if i == 0
    			then step' (p_i', p_i', 0, continue)
    			else do
    				bytes <- B.packCStringLen (p_0, i)
    				return $ Just (Mechanism bytes, (p_i', p_i', 0, continue))
    		in case chr of
    			0x00 -> peek False
    			0x20 -> peek True
    			_    -> step' (p_0, p_i', i + 1, True)

    -- }}}

    -- SASL Sessions {{{

    newtype SessionCtx = SessionCtx (F.Ptr SessionCtx)
    newtype Session a = Session { unSession :: R.ReaderT SessionCtx IO a }

    instance Functor Session where
    	fmap f = Session . fmap f . unSession

    instance Applicative Session where
            pure = Session . pure
            (<*>) = ap

    instance Monad Session where
    	return = Session . return
    	(>>=) m f = Session $ unSession m >>= unSession . f

    instance MonadIO Session where
    	liftIO = Session . 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 start (Mechanism mech) session = bracketSASL newSession freeSession io where
    	newSession ctx =
    		B.useAsCString mech $ \pMech ->
    		F.alloca $ \pSessionCtx -> E.handle noSession $ do
    		start ctx pMech pSessionCtx >>= checkRC
    		fmap (Right . SessionCtx) $ F.peek pSessionCtx
    	noSession (SASLException err) = return $ Left err

    	freeSession (Left _) = return ()
    	freeSession (Right (SessionCtx ptr)) = gsasl_finish ptr

    	io (Left err) = return $ Left err
    	io (Right sctx) = E.catch
    		(fmap Right $ R.runReaderT (unSession session) sctx)
    		(\(SASLException err) -> return $ Left err)

    -- | Run a session using the @libgsasl@ client.
    runClient :: Mechanism -> Session a -> SASL (Either Error a)
    runClient = runSession gsasl_client_start

    -- | Run a session using the @libgsasl@ server.
    runServer :: Mechanism -> Session a -> SASL (Either Error a)
    runServer = runSession gsasl_server_start

    getSessionContext :: Session (F.Ptr SessionCtx)
    getSessionContext = Session $ do
    	SessionCtx sctx <- R.ask
    	return sctx

    -- | The name of the session's SASL mechanism.
    mechanismName :: Session Mechanism
    mechanismName = do
    	sctx <- getSessionContext
    	liftIO $ do
    		cstr <- gsasl_mechanism_name sctx
    		Mechanism `fmap` B.packCString cstr

    bracketSession :: (F.Ptr SessionCtx -> IO a) -> (a -> IO b) -> (a -> IO c) -> Session c
    bracketSession before after thing = do
    	sctx <- getSessionContext
    	liftIO $ E.bracket (before sctx) after 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 = 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 err = unsafePerformIO $ gsasl_strerror (cFromError err) >>= F.peekCString

    data SASLException = SASLException Error
    	deriving (Show, Typeable)

    instance E.Exception SASLException

    cFromError :: Error -> F.CInt
    cFromError e = case e of
    	UnknownMechanism -> 2
    	MechanismCalledTooManyTimes -> 3
    	MallocError -> 7
    	Base64Error -> 8
    	CryptoError -> 9
    	SASLPrepError -> 29
    	MechanismParseError -> 30
    	AuthenticationError -> 31
    	IntegrityError -> 33
    	NoClientCode -> 35
    	NoServerCode -> 36
    	NoCallback -> 51
    	NoAnonymousToken -> 52
    	NoAuthID -> 53
    	NoAuthzID -> 54
    	NoPassword -> 55
    	NoPasscode -> 56
    	NoPIN -> 57
    	NoService -> 58
    	NoHostname -> 59
    	GSSAPI_ReleaseBufferError -> 37
    	GSSAPI_ImportNameError -> 38
    	GSSAPI_InitSecContextError -> 39
    	GSSAPI_AcceptSecContextError -> 40
    	GSSAPI_UnwrapError -> 41
    	GSSAPI_WrapError -> 42
    	GSSAPI_AquireCredError -> 43
    	GSSAPI_DisplayNameError -> 44
    	GSSAPI_UnsupportedProtectionError -> 45
    	GSSAPI_EncapsulateTokenError -> 60
    	GSSAPI_DecapsulateTokenError -> 61
    	GSSAPI_InquireMechForSASLNameError -> 62
    	GSSAPI_TestOIDSetMemberError -> 63
    	GSSAPI_ReleaseOIDSetError -> 64
    	KerberosV5_InitError -> 46
    	KerberosV5_InternalError -> 47
    	SecurID_ServerNeedAdditionalPasscode -> 48
    	SecurID_ServerNeedNewPIN -> 49

    cToError :: F.CInt -> Error
    cToError x = case x of
    	2 -> UnknownMechanism
    	3 -> MechanismCalledTooManyTimes
    	7 -> MallocError
    	8 -> Base64Error
    	9 -> CryptoError
    	29 -> SASLPrepError
    	30 -> MechanismParseError
    	31 -> AuthenticationError
    	33 -> IntegrityError
    	35 -> NoClientCode
    	36 -> NoServerCode
    	51 -> NoCallback
    	52 -> NoAnonymousToken
    	53 -> NoAuthID
    	54 -> NoAuthzID
    	55 -> NoPassword
    	56 -> NoPasscode
    	57 -> NoPIN
    	58 -> NoService
    	59 -> NoHostname
    	37 -> GSSAPI_ReleaseBufferError
    	38 -> GSSAPI_ImportNameError
    	39 -> GSSAPI_InitSecContextError
    	40 -> GSSAPI_AcceptSecContextError
    	41 -> GSSAPI_UnwrapError
    	42 -> GSSAPI_WrapError
    	43 -> GSSAPI_AquireCredError
    	44 -> GSSAPI_DisplayNameError
    	45 -> GSSAPI_UnsupportedProtectionError
    	60 -> GSSAPI_EncapsulateTokenError
    	61 -> GSSAPI_DecapsulateTokenError
    	62 -> GSSAPI_InquireMechForSASLNameError
    	63 -> GSSAPI_TestOIDSetMemberError
    	64 -> GSSAPI_ReleaseOIDSetError
    	46 -> KerberosV5_InitError
    	47 -> KerberosV5_InternalError
    	48 -> SecurID_ServerNeedAdditionalPasscode
    	49 -> SecurID_ServerNeedNewPIN
    	_ -> error $ "Unknown GNU SASL return code: " ++ show x

    throw :: Error -> Session a
    throw = liftIO . E.throwIO . SASLException

    catch :: Session a -> (Error -> Session a) -> Session a
    catch m f = do
    	sctx <- SessionCtx `fmap` getSessionContext
    	Session . liftIO $ E.catch
    		(R.runReaderT (unSession m) sctx)
    		(\(SASLException err) -> R.runReaderT (unSession (f err)) sctx)

    handle :: (Error -> Session a) -> Session a -> Session a
    handle = flip catch

    try :: Session a -> Session (Either Error a)
    try m = catch (fmap Right m) (return . 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 (Show, Eq)

    cFromProperty :: Property -> F.CInt
    cFromProperty x = case x of
    	PropertyAuthID -> 1
    	PropertyAuthzID -> 2
    	PropertyPassword -> 3
    	PropertyAnonymousToken -> 4
    	PropertyService -> 5
    	PropertyHostname -> 6
    	PropertyGSSAPIDisplayName -> 7
    	PropertyPasscode -> 8
    	PropertySuggestedPIN -> 9
    	PropertyPIN -> 10
    	PropertyRealm -> 11
    	PropertyDigestMD5HashedPassword -> 12
    	PropertyQOPS -> 13
    	PropertyQOP -> 14
    	PropertyScramIter -> 15
    	PropertyScramSalt -> 16
    	PropertyScramSaltedPassword -> 17
    	ValidateSimple -> 500
    	ValidateExternal -> 501
    	ValidateAnonymous -> 502
    	ValidateGSSAPI -> 503
    	ValidateSecurID -> 504

    cToProperty :: F.CInt -> Property
    cToProperty x = case x of
    	1 -> PropertyAuthID
    	2 -> PropertyAuthzID
    	3 -> PropertyPassword
    	4 -> PropertyAnonymousToken
    	5 -> PropertyService
    	6 -> PropertyHostname
    	7 -> PropertyGSSAPIDisplayName
    	8 -> PropertyPasscode
    	9 -> PropertySuggestedPIN
    	10 -> PropertyPIN
    	11 -> PropertyRealm
    	12 -> PropertyDigestMD5HashedPassword
    	13 -> PropertyQOPS
    	14 -> PropertyQOP
    	15 -> PropertyScramIter
    	16 -> PropertyScramSalt
    	17 -> PropertyScramSaltedPassword
    	500 -> ValidateSimple
    	501 -> ValidateExternal
    	502 -> ValidateAnonymous
    	503 -> ValidateGSSAPI
    	504 -> ValidateSecurID
    	_   -> error $ "Unknown GNU SASL property code: " ++ show x

    -- | Store some data in the session for the given property. The data must
    -- be @NULL@-terminated.
    setProperty :: Property -> B.ByteString -> Session ()
    setProperty prop bytes = do
    	sctx <- getSessionContext
    	liftIO $
    		B.useAsCString bytes $
    		gsasl_property_set sctx (cFromProperty 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 prop = do
    	sctx <- getSessionContext
    	liftIO $ do
    		cstr <- gsasl_property_get sctx (cFromProperty prop)
    		if cstr /= F.nullPtr
    			then fmap Just $ B.packCString cstr
    			else do
    				liftIO $ checkCallbackException sctx
    				return Nothing

    -- | Retrieve the data stored in the session for the given property,
    -- without invoking the current callback.
    getPropertyFast :: Property -> Session (Maybe B.ByteString)
    getPropertyFast prop = do
    	sctx <- getSessionContext
    	liftIO $
    		gsasl_property_fast sctx (cFromProperty prop) >>=
    		F.maybePeek 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 cb = E.bracketOnError
    	(wrapCallbackImpl (callbackImpl cb))
    	F.freeHaskellFunPtr
    	(\funPtr -> let hook = CallbackHook funPtr cb in E.bracketOnError
    		(F.newStablePtr hook)
    		F.freeStablePtr
    		(\stablePtr -> let
    			hookPtr = F.castPtr (F.castStablePtrToPtr stablePtr)
    			in return (hookPtr, funPtr)))

    freeCallbackHook :: F.Ptr CallbackHook -> IO ()
    freeCallbackHook ptr = unless (ptr == F.nullPtr) $ do
    	let stablePtr = F.castPtrToStablePtr $ F.castPtr ptr
    	hook <- F.deRefStablePtr stablePtr
    	F.freeStablePtr stablePtr
    	let (CallbackHook funPtr _) = hook
    	F.freeHaskellFunPtr funPtr

    callbackImpl :: (Property -> Session Progress) -> CallbackFn
    callbackImpl cb _ sctx cProp = let
    	globalIO = error "globalIO is not implemented"

    	sessionIO = do
    		let session = cb $ cToProperty cProp
    		fmap cFromProgress $ R.runReaderT (unSession session) (SessionCtx sctx)

    	onError :: SASLException -> IO F.CInt
    	onError (SASLException err) = return $ cFromError err

    	onException :: E.SomeException -> IO F.CInt
    	onException exc = do
    		-- A bit ugly; session hooks aren't used anywhere else in
    		-- the binding, so the exception is stashed here.
    		stablePtr <- F.newStablePtr exc
    		gsasl_session_hook_set sctx $ F.castStablePtrToPtr 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.
    		return (-1)

    	catchErrors io = E.catches io [E.Handler onError, E.Handler onException]

    	in catchErrors $ if sctx == F.nullPtr then globalIO else 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 sctx = do
    	hook <- gsasl_session_hook_get sctx
    	when (hook /= F.nullPtr) $ do
    		let stable = F.castPtrToStablePtr hook
    		exc <- F.deRefStablePtr stable
    		F.freeStablePtr stable
    		E.throwIO (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 cb = do
    	ctx <- getContext
    	liftIO $ do
    		freeCallbackHook =<< gsasl_callback_hook_get ctx
    		(hook, cbPtr) <- newCallbackHook cb
    		gsasl_callback_hook_set ctx hook
    		gsasl_callback_set ctx cbPtr

    -- | Run the current callback; the property indicates what action the
    -- callback is expected to perform.
    runCallback :: Property -> Session Progress
    runCallback 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).
    	ctx <- fmap F.castPtr getSessionContext
    	hookPtr <- liftIO $ gsasl_callback_hook_get ctx
    	when (hookPtr == F.nullPtr) $ throw NoCallback
    	hook <- liftIO $ F.deRefStablePtr $ F.castPtrToStablePtr hookPtr
    	let (CallbackHook _ cb) = hook
    	cb prop

    -- }}}

    -- Session IO {{{

    data Progress = Complete | NeedsMore
    	deriving (Show, Eq)

    cFromProgress :: Progress -> F.CInt
    cFromProgress x = case x of
    	Complete -> 0
    	NeedsMore -> 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 input = bracketSession get free peek where
    	get sctx =
    		B.unsafeUseAsCStringLen input $ \(pInput, inputLen) ->
    		F.alloca $ \pOutput ->
    		F.alloca $ \pOutputLen -> do
    		rc <- gsasl_step sctx pInput (fromIntegral inputLen) pOutput pOutputLen
    		when (rc /= 0) $ checkCallbackException sctx
    		progress <- checkStepRC rc
    		cstr <- F.peek pOutput
    		cstrLen <- F.peek pOutputLen
    		return (cstr, cstrLen, progress)

    	free (cstr, _, _) = gsasl_free cstr
    	peek (cstr, cstrLen, progress) = do
    		output <- B.packCStringLen (cstr, fromIntegral cstrLen)
    		return (output, 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 input = bracketSession get free peek where
    	get sctx =
    		B.useAsCString input $ \pInput ->
    		F.alloca $ \pOutput -> do
    		rc <- gsasl_step64 sctx pInput pOutput
    		when (rc /= 0) $ checkCallbackException sctx
    		progress <- checkStepRC rc
    		cstr <- F.peek pOutput
    		return (cstr, progress)

    	free (cstr, _) = gsasl_free cstr
    	peek (cstr, progress) = do
    		output <- B.packCString cstr
    		return (output, progress)

    checkStepRC :: F.CInt -> IO Progress
    checkStepRC x = case x of
    	0 -> return Complete
    	1 -> return NeedsMore
    	_ -> E.throwIO (SASLException (cToError x))

    -- | 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 input = do
    	sctx <- getSessionContext
    	liftIO $
    		B.unsafeUseAsCStringLen input $ \(cstr, cstrLen) ->
    		F.alloca $ \pOutput ->
    		F.alloca $ \pOutputLen -> do
    			rc <- gsasl_encode sctx cstr (fromIntegral cstrLen) pOutput pOutputLen
    			when (rc /= 0) $ checkCallbackException sctx
    			checkRC rc
    			output <- F.peek pOutput
    			outputLen <- fromIntegral `fmap` F.peek pOutputLen
    			outBytes <- B.packCStringLen (output, outputLen)
    			gsasl_free output
    			return outBytes

    -- | 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 input = do
    	sctx <- getSessionContext
    	liftIO $
    		B.unsafeUseAsCStringLen input $ \(cstr, cstrLen) ->
    		F.alloca $ \pOutput ->
    		F.alloca $ \pOutputLen -> do
    			rc <- gsasl_decode sctx cstr (fromIntegral cstrLen) pOutput pOutputLen
    			when (rc /= 0) $ checkCallbackException sctx
    			checkRC rc
    			output <- F.peek pOutput
    			outputLen <- fromIntegral `fmap` F.peek pOutputLen
    			outputBytes <- B.packCStringLen (output, outputLen)
    			gsasl_free output
    			return outputBytes

    -- }}}

    -- Bundled codecs {{{

    toBase64 :: B.ByteString -> B.ByteString
    toBase64 input = unsafePerformIO $
    	B.unsafeUseAsCStringLen input $ \(pIn, inLen) ->
    	F.alloca $ \pOut ->
    	F.alloca $ \pOutLen -> do
    	gsasl_base64_to pIn (fromIntegral inLen) pOut pOutLen >>= checkRC
    	outLen <- F.peek pOutLen
    	outPtr <- F.peek pOut
    	B.packCStringLen (outPtr, fromIntegral outLen)

    fromBase64 :: B.ByteString -> B.ByteString
    fromBase64 input = unsafePerformIO $
    	B.unsafeUseAsCStringLen input $ \(pIn, inLen) ->
    	F.alloca $ \pOut ->
    	F.alloca $ \pOutLen -> do
    	gsasl_base64_from pIn (fromIntegral inLen) pOut pOutLen >>= checkRC
    	outLen <- F.peek pOutLen
    	outPtr <- F.peek pOut
    	B.packCStringLen (outPtr, fromIntegral outLen)

    md5 :: B.ByteString -> B.ByteString
    md5 input = unsafePerformIO $
    	B.unsafeUseAsCStringLen input $ \(pIn, inLen) ->
    	F.alloca $ \pOut ->
    	F.allocaBytes 16 $ \outBuf -> do
    	F.poke pOut outBuf
    	gsasl_md5 pIn (fromIntegral inLen) pOut >>= checkRC
    	B.packCStringLen (outBuf, 16)

    sha1 :: B.ByteString -> B.ByteString
    sha1 input = unsafePerformIO $
    	B.unsafeUseAsCStringLen input $ \(pIn, inLen) ->
    	F.alloca $ \pOut ->
    	F.allocaBytes 20 $ \outBuf -> do
    	F.poke pOut outBuf
    	gsasl_sha1 pIn (fromIntegral inLen) pOut >>= checkRC
    	B.packCStringLen (outBuf, 20)

    hmacMD5 :: B.ByteString -- ^ Key
            -> B.ByteString -- ^ Input data
            -> B.ByteString
    hmacMD5 key input = unsafePerformIO $
    	B.unsafeUseAsCStringLen key $ \(pKey, keyLen) ->
    	B.unsafeUseAsCStringLen input $ \(pIn, inLen) ->
    	F.alloca $ \pOut ->
    	F.allocaBytes 16 $ \outBuf -> do
    	F.poke pOut outBuf
    	gsasl_hmac_md5 pKey (fromIntegral keyLen) pIn (fromIntegral inLen) pOut >>= checkRC
    	B.packCStringLen (outBuf, 16)

    hmacSHA1 :: B.ByteString -- ^ Key
             -> B.ByteString -- ^ Input data
             -> B.ByteString
    hmacSHA1 key input = unsafePerformIO $
    	B.unsafeUseAsCStringLen key $ \(pKey, keyLen) ->
    	B.unsafeUseAsCStringLen input $ \(pIn, inLen) ->
    	F.alloca $ \pOut ->
    	F.allocaBytes 20 $ \outBuf -> do
    	F.poke pOut outBuf
    	gsasl_hmac_sha1 pKey (fromIntegral keyLen) pIn (fromIntegral inLen) pOut >>= checkRC
    	B.packCStringLen (outBuf, 20)

    -- | Returns unpredictable data of a given size
    nonce :: Integer -> IO B.ByteString
    nonce size = F.allocaBytes (fromInteger size) $ \buf -> do
    	gsasl_nonce buf (fromIntegral size) >>= checkRC
    	B.packCStringLen (buf, fromIntegral size)

    -- | Returns cryptographically strong random data of a given size
    random :: Integer -> IO B.ByteString
    random size = F.allocaBytes (fromInteger size) $ \buf -> do
    	gsasl_random buf (fromIntegral size) >>= checkRC
    	B.packCStringLen (buf, fromIntegral size)

    -- }}}

    -- Miscellaneous {{{

    checkRC :: F.CInt -> IO ()
    checkRC x = case x of
    	0 -> return ()
    	_ -> E.throwIO (SASLException (cToError x))

    unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a]
    unfoldrM m b = m b >>= \x -> case x of
    	Just (a, new_b) -> do
    		as <- unfoldrM m new_b
    		return $ a : as
    	Nothing -> return []

    -- }}}

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

    -- }}}