gsasl 0.2 → 0.3
raw patch · 4 files changed
+1003/−378 lines, 4 filesdep +bytestringdep +transformersPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring, transformers
API changes (from Hackage documentation)
- Network.Protocol.SASL.GSASL: GSASL_ANONYMOUS_TOKEN :: Property
- Network.Protocol.SASL.GSASL: GSASL_AUTHENTICATION_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_AUTHID :: Property
- Network.Protocol.SASL.GSASL: GSASL_AUTHZID :: Property
- Network.Protocol.SASL.GSASL: GSASL_BASE64_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_CRYPTO_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_DIGEST_MD5_HASHED_PASSWORD :: Property
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_ACCEPT_SEC_CONTEXT_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_ACQUIRE_CRED_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_DISPLAY_NAME :: Property
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_DISPLAY_NAME_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_IMPORT_NAME_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_INIT_SEC_CONTEXT_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_RELEASE_BUFFER_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_UNSUPPORTED_PROTECTION_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_UNWRAP_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_GSSAPI_WRAP_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_HOSTNAME :: Property
- Network.Protocol.SASL.GSASL: GSASL_INTEGRITY_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_KERBEROS_V5_INIT_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_KERBEROS_V5_INTERNAL_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_MALLOC_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_MECHANISM_CALLED_TOO_MANY_TIMES :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_MECHANISM_PARSE_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NEEDS_MORE :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_ANONYMOUS_TOKEN :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_AUTHID :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_AUTHZID :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_CALLBACK :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_CLIENT_CODE :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_HOSTNAME :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_PASSCODE :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_PASSWORD :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_PIN :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_SERVER_CODE :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_NO_SERVICE :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_OK :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_PASSCODE :: Property
- Network.Protocol.SASL.GSASL: GSASL_PASSWORD :: Property
- Network.Protocol.SASL.GSASL: GSASL_PIN :: Property
- Network.Protocol.SASL.GSASL: GSASL_QOP :: Property
- Network.Protocol.SASL.GSASL: GSASL_QOPS :: Property
- Network.Protocol.SASL.GSASL: GSASL_REALM :: Property
- Network.Protocol.SASL.GSASL: GSASL_SASLPREP_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_SCRAM_ITER :: Property
- Network.Protocol.SASL.GSASL: GSASL_SCRAM_SALT :: Property
- Network.Protocol.SASL.GSASL: GSASL_SCRAM_SALTED_PASSWORD :: Property
- Network.Protocol.SASL.GSASL: GSASL_SECURID_SERVER_NEED_ADDITIONAL_PASSCODE :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_SECURID_SERVER_NEED_NEW_PIN :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_SERVICE :: Property
- Network.Protocol.SASL.GSASL: GSASL_SHISHI_ERROR :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_SUGGESTED_PIN :: Property
- Network.Protocol.SASL.GSASL: GSASL_UNKNOWN_MECHANISM :: ReturnCode
- Network.Protocol.SASL.GSASL: GSASL_VALIDATE_ANONYMOUS :: Property
- Network.Protocol.SASL.GSASL: GSASL_VALIDATE_EXTERNAL :: Property
- Network.Protocol.SASL.GSASL: GSASL_VALIDATE_GSSAPI :: Property
- Network.Protocol.SASL.GSASL: GSASL_VALIDATE_SECURID :: Property
- Network.Protocol.SASL.GSASL: GSASL_VALIDATE_SIMPLE :: Property
- Network.Protocol.SASL.GSASL: callback :: Maybe Context -> Session -> Property -> IO (())
- Network.Protocol.SASL.GSASL: clientMechanisms :: Context -> IO [String]
- Network.Protocol.SASL.GSASL: clientStart :: Context -> String -> IO Session
- Network.Protocol.SASL.GSASL: clientSuggestMechanism :: Context -> [String] -> IO (Maybe String)
- Network.Protocol.SASL.GSASL: clientSupportP :: Context -> String -> IO (Bool)
- Network.Protocol.SASL.GSASL: data Context
- Network.Protocol.SASL.GSASL: data Property
- Network.Protocol.SASL.GSASL: data ReturnCode
- Network.Protocol.SASL.GSASL: data Session
- Network.Protocol.SASL.GSASL: decode :: Session -> String -> IO String
- Network.Protocol.SASL.GSASL: encode :: Session -> String -> IO String
- Network.Protocol.SASL.GSASL: freeContext :: Context -> IO ()
- Network.Protocol.SASL.GSASL: freeSession :: Session -> IO ()
- Network.Protocol.SASL.GSASL: instance Enum Property
- Network.Protocol.SASL.GSASL: instance Enum ReturnCode
- Network.Protocol.SASL.GSASL: instance Enum SaslPrepFlags
- Network.Protocol.SASL.GSASL: instance Show Property
- Network.Protocol.SASL.GSASL: instance Show ReturnCode
- Network.Protocol.SASL.GSASL: instance Show SaslPrepFlags
- Network.Protocol.SASL.GSASL: mkContext :: IO Context
- Network.Protocol.SASL.GSASL: propertyFast :: Session -> Property -> IO (Maybe String)
- Network.Protocol.SASL.GSASL: propertyGet :: Session -> Property -> IO (Maybe String)
- Network.Protocol.SASL.GSASL: propertySet :: Session -> Property -> String -> IO ()
- Network.Protocol.SASL.GSASL: serverMechanisms :: Context -> IO [String]
- Network.Protocol.SASL.GSASL: serverStart :: Context -> String -> IO Session
- Network.Protocol.SASL.GSASL: serverSupportP :: Context -> String -> IO (Bool)
- Network.Protocol.SASL.GSASL: step :: Session -> String -> IO (String, ReturnCode)
- Network.Protocol.SASL.GSASL: step64 :: Session -> String -> IO (String, ReturnCode)
- Network.Protocol.SASL.GSASL: type CallbackComputation = Context -> Session -> Property -> IO ReturnCode
- Network.Protocol.SASL.GSASL: withCallbackSet :: Context -> CallbackComputation -> IO a -> IO a
- Network.Protocol.SASL.GSASL: withContext :: (Context -> IO a) -> IO a
- Network.Protocol.SASL.GSASL: withSession :: IO Session -> (Session -> IO a) -> IO a
+ Network.Protocol.SASL.GNU: AuthenticationError :: Error
+ Network.Protocol.SASL.GNU: Base64Error :: Error
+ Network.Protocol.SASL.GNU: Complete :: Progress
+ Network.Protocol.SASL.GNU: CryptoError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_AcceptSecContextError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_AquireCredError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_DecapsulateTokenError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_DisplayNameError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_EncapsulateTokenError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_ImportNameError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_InitSecContextError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_InquireMechForSASLNameError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_ReleaseBufferError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_ReleaseOIDSetError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_TestOIDSetMemberError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_UnsupportedProtectionError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_UnwrapError :: Error
+ Network.Protocol.SASL.GNU: GSSAPI_WrapError :: Error
+ Network.Protocol.SASL.GNU: IntegrityError :: Error
+ Network.Protocol.SASL.GNU: KerberosV5_InitError :: Error
+ Network.Protocol.SASL.GNU: KerberosV5_InternalError :: Error
+ Network.Protocol.SASL.GNU: MallocError :: Error
+ Network.Protocol.SASL.GNU: Mechanism :: ByteString -> Mechanism
+ Network.Protocol.SASL.GNU: MechanismCalledTooManyTimes :: Error
+ Network.Protocol.SASL.GNU: MechanismParseError :: Error
+ Network.Protocol.SASL.GNU: NeedsMore :: Progress
+ Network.Protocol.SASL.GNU: NoAnonymousToken :: Error
+ Network.Protocol.SASL.GNU: NoAuthID :: Error
+ Network.Protocol.SASL.GNU: NoAuthzID :: Error
+ Network.Protocol.SASL.GNU: NoCallback :: Error
+ Network.Protocol.SASL.GNU: NoClientCode :: Error
+ Network.Protocol.SASL.GNU: NoHostname :: Error
+ Network.Protocol.SASL.GNU: NoPIN :: Error
+ Network.Protocol.SASL.GNU: NoPasscode :: Error
+ Network.Protocol.SASL.GNU: NoPassword :: Error
+ Network.Protocol.SASL.GNU: NoServerCode :: Error
+ Network.Protocol.SASL.GNU: NoService :: Error
+ Network.Protocol.SASL.GNU: PropertyAnonymousToken :: Property
+ Network.Protocol.SASL.GNU: PropertyAuthID :: Property
+ Network.Protocol.SASL.GNU: PropertyAuthzID :: Property
+ Network.Protocol.SASL.GNU: PropertyDigestMD5HashedPassword :: Property
+ Network.Protocol.SASL.GNU: PropertyGSSAPIDisplayName :: Property
+ Network.Protocol.SASL.GNU: PropertyHostname :: Property
+ Network.Protocol.SASL.GNU: PropertyPIN :: Property
+ Network.Protocol.SASL.GNU: PropertyPasscode :: Property
+ Network.Protocol.SASL.GNU: PropertyPassword :: Property
+ Network.Protocol.SASL.GNU: PropertyQOP :: Property
+ Network.Protocol.SASL.GNU: PropertyQOPS :: Property
+ Network.Protocol.SASL.GNU: PropertyRealm :: Property
+ Network.Protocol.SASL.GNU: PropertyScramIter :: Property
+ Network.Protocol.SASL.GNU: PropertyScramSalt :: Property
+ Network.Protocol.SASL.GNU: PropertyScramSaltedPassword :: Property
+ Network.Protocol.SASL.GNU: PropertyService :: Property
+ Network.Protocol.SASL.GNU: PropertySuggestedPIN :: Property
+ Network.Protocol.SASL.GNU: SASLPrepError :: Error
+ Network.Protocol.SASL.GNU: SecurID_ServerNeedAdditionalPasscode :: Error
+ Network.Protocol.SASL.GNU: SecurID_ServerNeedNewPIN :: Error
+ Network.Protocol.SASL.GNU: UnknownMechanism :: Error
+ Network.Protocol.SASL.GNU: ValidateAnonymous :: Property
+ Network.Protocol.SASL.GNU: ValidateExternal :: Property
+ Network.Protocol.SASL.GNU: ValidateGSSAPI :: Property
+ Network.Protocol.SASL.GNU: ValidateSecurID :: Property
+ Network.Protocol.SASL.GNU: ValidateSimple :: Property
+ Network.Protocol.SASL.GNU: catch :: Session a -> (Error -> Session a) -> Session a
+ Network.Protocol.SASL.GNU: checkVersion :: IO Bool
+ Network.Protocol.SASL.GNU: clientMechanisms :: SASL [Mechanism]
+ Network.Protocol.SASL.GNU: clientSuggestMechanism :: [Mechanism] -> SASL (Maybe Mechanism)
+ Network.Protocol.SASL.GNU: clientSupports :: Mechanism -> SASL Bool
+ Network.Protocol.SASL.GNU: data Error
+ Network.Protocol.SASL.GNU: data Progress
+ Network.Protocol.SASL.GNU: data Property
+ Network.Protocol.SASL.GNU: data SASL a
+ Network.Protocol.SASL.GNU: data Session a
+ Network.Protocol.SASL.GNU: decode :: ByteString -> Session ByteString
+ Network.Protocol.SASL.GNU: encode :: ByteString -> Session ByteString
+ Network.Protocol.SASL.GNU: fromBase64 :: ByteString -> ByteString
+ Network.Protocol.SASL.GNU: getProperty :: Property -> Session (Maybe ByteString)
+ Network.Protocol.SASL.GNU: getPropertyFast :: Property -> Session (Maybe ByteString)
+ Network.Protocol.SASL.GNU: handle :: (Error -> Session a) -> Session a -> Session a
+ Network.Protocol.SASL.GNU: headerVersion :: (Integer, Integer, Integer)
+ Network.Protocol.SASL.GNU: hmacMD5 :: ByteString -> ByteString -> ByteString
+ Network.Protocol.SASL.GNU: hmacSHA1 :: ByteString -> ByteString -> ByteString
+ Network.Protocol.SASL.GNU: instance Eq Mechanism
+ Network.Protocol.SASL.GNU: instance Eq Progress
+ Network.Protocol.SASL.GNU: instance Eq Property
+ Network.Protocol.SASL.GNU: instance Exception SASLException
+ Network.Protocol.SASL.GNU: instance Functor SASL
+ Network.Protocol.SASL.GNU: instance Functor Session
+ Network.Protocol.SASL.GNU: instance IsString Mechanism
+ Network.Protocol.SASL.GNU: instance Monad SASL
+ Network.Protocol.SASL.GNU: instance Monad Session
+ Network.Protocol.SASL.GNU: instance MonadIO SASL
+ Network.Protocol.SASL.GNU: instance MonadIO Session
+ Network.Protocol.SASL.GNU: instance Show Error
+ Network.Protocol.SASL.GNU: instance Show Mechanism
+ Network.Protocol.SASL.GNU: instance Show Progress
+ Network.Protocol.SASL.GNU: instance Show Property
+ Network.Protocol.SASL.GNU: instance Show SASLException
+ Network.Protocol.SASL.GNU: instance Typeable SASLException
+ Network.Protocol.SASL.GNU: libraryVersion :: IO (Integer, Integer, Integer)
+ Network.Protocol.SASL.GNU: md5 :: ByteString -> ByteString
+ Network.Protocol.SASL.GNU: mechanismName :: Session Mechanism
+ Network.Protocol.SASL.GNU: newtype Mechanism
+ Network.Protocol.SASL.GNU: nonce :: Integer -> IO ByteString
+ Network.Protocol.SASL.GNU: random :: Integer -> IO ByteString
+ Network.Protocol.SASL.GNU: runCallback :: Property -> Session Progress
+ Network.Protocol.SASL.GNU: runClient :: Mechanism -> Session a -> SASL (Either Error a)
+ Network.Protocol.SASL.GNU: runSASL :: SASL a -> IO a
+ Network.Protocol.SASL.GNU: runServer :: Mechanism -> Session a -> SASL (Either Error a)
+ Network.Protocol.SASL.GNU: serverMechanisms :: SASL [Mechanism]
+ Network.Protocol.SASL.GNU: serverSupports :: Mechanism -> SASL Bool
+ Network.Protocol.SASL.GNU: setCallback :: (Property -> Session Progress) -> SASL ()
+ Network.Protocol.SASL.GNU: setProperty :: Property -> ByteString -> Session ()
+ Network.Protocol.SASL.GNU: sha1 :: ByteString -> ByteString
+ Network.Protocol.SASL.GNU: step :: ByteString -> Session (ByteString, Progress)
+ Network.Protocol.SASL.GNU: step64 :: ByteString -> Session (ByteString, Progress)
+ Network.Protocol.SASL.GNU: throw :: Error -> Session a
+ Network.Protocol.SASL.GNU: toBase64 :: ByteString -> ByteString
+ Network.Protocol.SASL.GNU: try :: Session a -> Session (Either Error a)
Files
- Network/Protocol/SASL/GNU.hs +971/−0
- Network/Protocol/SASL/GSASL.chs +0/−369
- gsasl.cabal +19/−9
- hsgsasl-shim.c +13/−0
+ Network/Protocol/SASL/GNU.hs view
@@ -0,0 +1,971 @@+-- 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/>.++{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+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 qualified Control.Exception as E+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import Data.ByteString.Char8 ()+import Data.Char (isDigit)+import Data.Typeable (Typeable)+import Data.String (IsString, fromString)+import qualified Foreign as F+import qualified Foreign.C as F+import System.IO.Unsafe (unsafePerformIO)+import Control.Monad (when, unless)+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Control.Monad.Trans.Reader as R+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+ P.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++-- | 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 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 " " [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 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 unsafe "hsgsasl_VERSION_MAJOR"+ hsgsasl_VERSION_MAJOR :: F.CInt++foreign import ccall unsafe "hsgsasl_VERSION_MINOR"+ hsgsasl_VERSION_MINOR :: F.CInt++foreign import ccall unsafe "hsgsasl_VERSION_PATCH"+ hsgsasl_VERSION_PATCH :: F.CInt++foreign import ccall unsafe "hsgsasl_check_version"+ hsgsasl_check_version :: IO F.CInt++foreign import ccall unsafe "gsasl.h gsasl_init"+ gsasl_init :: F.Ptr (F.Ptr Context) -> IO F.CInt++foreign import ccall unsafe "gsasl.h gsasl_done"+ gsasl_done :: F.Ptr Context -> IO ()++foreign import ccall unsafe "gsasl.h gsasl_check_version"+ gsasl_check_version :: F.CString -> IO F.CString++foreign import ccall unsafe "gsasl.h gsasl_callback_set"+ gsasl_callback_set :: F.Ptr Context -> F.FunPtr CallbackFn -> IO ()++foreign import ccall unsafe "gsasl.h gsasl_callback_hook_get"+ gsasl_callback_hook_get :: F.Ptr Context -> IO (F.Ptr a)++foreign import ccall unsafe "gsasl.h gsasl_callback_hook_set"+ gsasl_callback_hook_set :: F.Ptr Context -> F.Ptr a -> IO ()++foreign import ccall unsafe "gsasl.h gsasl_session_hook_get"+ gsasl_session_hook_get :: F.Ptr SessionCtx -> IO (F.Ptr a)++foreign import ccall unsafe "gsasl.h gsasl_session_hook_set"+ gsasl_session_hook_set :: F.Ptr SessionCtx -> F.Ptr a -> IO ()++foreign import ccall unsafe "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 unsafe "gsasl.h gsasl_property_fast"+ gsasl_property_fast :: F.Ptr SessionCtx -> F.CInt -> IO F.CString++foreign import ccall unsafe "gsasl.h gsasl_client_mechlist"+ gsasl_client_mechlist :: F.Ptr Context -> F.Ptr F.CString -> IO F.CInt++foreign import ccall unsafe "gsasl.h gsasl_client_support_p"+ gsasl_client_support_p :: F.Ptr Context -> F.CString -> IO F.CInt++foreign import ccall unsafe "gsasl.h gsasl_client_suggest_mechanism"+ gsasl_client_suggest_mechanism :: F.Ptr Context -> F.CString -> IO F.CString++foreign import ccall unsafe "gsasl.h gsasl_server_mechlist"+ gsasl_server_mechlist :: F.Ptr Context -> F.Ptr F.CString -> IO F.CInt++foreign import ccall unsafe "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 unsafe "gsasl.h gsasl_mechanism_name"+ gsasl_mechanism_name :: F.Ptr SessionCtx -> IO F.CString++foreign import ccall unsafe "gsasl.h gsasl_strerror"+ gsasl_strerror :: F.CInt -> IO F.CString++foreign import ccall unsafe "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 unsafe "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 unsafe "gsasl.h gsasl_md5"+ gsasl_md5 :: F.CString -> F.CSize -> F.Ptr F.CString -> IO F.CInt++foreign import ccall unsafe "gsasl.h gsasl_sha1"+ gsasl_sha1 :: F.CString -> F.CSize -> F.Ptr F.CString -> IO F.CInt++foreign import ccall unsafe "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 unsafe "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 unsafe "gsasl.h gsasl_nonce"+ gsasl_nonce :: F.CString -> F.CSize -> IO F.CInt++foreign import ccall unsafe "gsasl.h gsasl_random"+ gsasl_random :: F.CString -> F.CSize -> IO F.CInt++foreign import ccall unsafe "gsasl.h gsasl_free"+ gsasl_free :: F.Ptr a -> IO ()++-- }}}
− Network/Protocol/SASL/GSASL.chs
@@ -1,369 +0,0 @@-{- Copyright (C) 2009 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/>.--}--{- |--Full documentation available for these functions at-<http://www.gnu.org/software/gsasl/>.---}--{-# LANGUAGE ForeignFunctionInterface #-}--#include <gsasl.h>--module Network.Protocol.SASL.GSASL (- -- * Data types- Context- ,Session- ,CallbackComputation- - -- * Context procedures- ,mkContext- ,freeContext- ,withContext- ,clientMechanisms- ,serverMechanisms- ,clientSupportP- ,serverSupportP- ,clientSuggestMechanism- - -- * Callback management- ,callback- ,withCallbackSet- - -- * Property set/get- ,propertySet- ,propertyFast- ,propertyGet- - -- * Session procedures- ,clientStart- ,serverStart- ,freeSession- ,withSession- ,step- ,step64- ,encode- ,decode- - -- * Enumerations- ,ReturnCode(..)- ,Property(..)- ) where--import Foreign-import Foreign.C-import Data.List (intercalate)-import Control.Exception (bracket)--{#enum Gsasl_rc as ReturnCode {} deriving (Show) #}-{#enum Gsasl_property as Property {} deriving (Show) #}-{#enum Gsasl_saslprep_flags as SaslPrepFlags {} deriving (Show) #}--{#pointer *Gsasl as ContextPtr -> Context #}-{#pointer *Gsasl_session as SessionPtr -> Session #}--data Context = Context { rawContext :: ContextPtr }-data Session = Session { rawSession :: SessionPtr }--type CallbackComputation = (Context -> Session -> Property -> IO ReturnCode)-type RawCallbackComputation = (ContextPtr -> SessionPtr -> CInt -> IO CInt)-----------------------------------------------------------------------------------cToEnum :: (Enum a) => CInt -> a-cToEnum = toEnum . fromIntegral--cFromEnum :: (Enum a) => a -> CInt-cFromEnum = fromIntegral . fromEnum--cSpacedStringFromList :: [String] -> (CString -> IO a) -> IO a-cSpacedStringFromList xs f = let spaced = intercalate " " xs in- withCString spaced f--cToMaybeString :: CString -> IO (Maybe String)-cToMaybeString s- | s == nullPtr = return Nothing- | otherwise = peekCString s >>= return . Just--cFromMaybe :: (a -> Ptr b) -> Maybe a -> Ptr b-cFromMaybe _ Nothing = nullPtr-cFromMaybe f (Just x) = f x--cFromMaybeContext = cFromMaybe rawContext--checkRC :: CInt -> IO ()-checkRC x = let rc = cToEnum x in do- message <- gsasl_strerror rc- case rc of- GSASL_OK -> return ()- _ -> error message--checkStepRC :: CInt -> IO ReturnCode-checkStepRC x = let rc = cToEnum x in do- message <- gsasl_strerror rc- case rc of- GSASL_OK -> return rc- GSASL_NEEDS_MORE -> return rc- _ -> error message------------------------------------------------------------------------------------- Context procedures-mkContext :: IO Context-mkContext =- alloca $ \pctxt -> do- gsasl_init pctxt- rawCtxt <- peek pctxt- let ctxt = Context rawCtxt- ctxtPtr <- newStablePtr ctxt- callbackHookSet rawCtxt (castStablePtrToPtr ctxtPtr)- return ctxt--{#fun gsasl_init {- id `Ptr ContextPtr'- } -> `()' checkRC* #}--freeContext :: Context -> IO ()-freeContext ctxt = do- hook <- callbackHookGet (rawContext ctxt)- freeStablePtr . castPtrToStablePtr $ hook- gsasl_done ctxt--{#fun gsasl_done {- rawContext `Context'- } -> `()' #}--withContext :: (Context -> IO a) -> IO a-withContext = bracket mkContext freeContext--clientMechanisms :: Context -> IO [String]-clientMechanisms ctxt =- alloca $ \pstrs -> do- gsasl_client_mechlist ctxt pstrs >>= checkRC- cstrs <- peek pstrs- strs <- peekCString cstrs- free cstrs- return $ split ' ' strs--{#fun gsasl_client_mechlist {- rawContext `Context'- ,id `Ptr CString'- } -> `CInt' id #}--serverMechanisms :: Context -> IO [String]-serverMechanisms ctxt =- alloca $ \pstrs -> do- gsasl_server_mechlist ctxt pstrs >>= checkRC- cstrs <- peek pstrs- strs <- peekCString cstrs- free cstrs- return $ split ' ' strs--{#fun gsasl_server_mechlist {- rawContext `Context'- ,id `Ptr CString'- } -> `CInt' id #}--{#fun gsasl_client_support_p as clientSupportP {- rawContext `Context'- ,`String'- } -> `Bool' toBool #}--{#fun gsasl_server_support_p as serverSupportP {- rawContext `Context'- ,`String'- } -> `Bool' toBool #}--{#fun gsasl_client_suggest_mechanism as clientSuggestMechanism {- rawContext `Context'- ,cSpacedStringFromList* `[String]'- } -> `Maybe String' cToMaybeString* #}---- Callback management-{#fun gsasl_callback_set as callbackSet {- rawContext `Context'- ,id `FunPtr RawCallbackComputation'- } -> `()' #}--{#fun gsasl_callback as callback {- cFromMaybeContext `Maybe Context'- ,rawSession `Session'- ,cFromEnum `Property'- } -> `()' checkRC* #}--withCallbackSet :: Context -> CallbackComputation -> IO a -> IO a-withCallbackSet ctxt comp block = bracket- (callbackWrapper $ mkCallbackWrapper comp)- (\funptr -> do- freeHaskellFunPtr funptr- callbackSet ctxt nullFunPtr)- (\funptr -> do- callbackSet ctxt funptr- block)--mkCallbackWrapper :: CallbackComputation -> RawCallbackComputation-mkCallbackWrapper comp pCtxt pSession cProp = do- callbackHook <- callbackHookGet pCtxt- let ctxtStablePtr = castPtrToStablePtr callbackHook- ctxt <- (deRefStablePtr ctxtStablePtr :: IO Context)- - sessionHook <- sessionHookGet pSession- let sessStablePtr = castPtrToStablePtr sessionHook- session <- (deRefStablePtr sessStablePtr :: IO Session)- - let prop = (cToEnum cProp :: Property)- return . cFromEnum =<< comp ctxt session prop--foreign import ccall "wrapper"- callbackWrapper :: RawCallbackComputation -> IO (FunPtr RawCallbackComputation)--{#fun gsasl_callback_hook_set as callbackHookSet {- id `ContextPtr'- ,id `Ptr ()'- } -> `()' #}--{#fun gsasl_callback_hook_get as callbackHookGet {- id `ContextPtr'- } -> `Ptr ()' id #}--{#fun gsasl_session_hook_set as sessionHookSet {- id `SessionPtr'- ,id `Ptr ()'- } -> `()' #}--{#fun gsasl_session_hook_get as sessionHookGet {- id `SessionPtr'- } -> `Ptr ()' id #}---- Property set/get-{#fun gsasl_property_set as propertySet {- rawSession `Session'- ,cFromEnum `Property'- , `String'- } -> `()' #}--{#fun gsasl_property_fast as propertyFast {- rawSession `Session'- ,cFromEnum `Property'- } -> `Maybe String' cToMaybeString* #}--{#fun gsasl_property_get as propertyGet {- rawSession `Session'- ,cFromEnum `Property'- } -> `Maybe String' cToMaybeString* #}---- Session procedures-clientStart :: Context -> String -> IO Session-clientStart ctxt s =- alloca $ \psess -> do- gsasl_client_start ctxt s psess- rawSession <- peek psess- let session = Session rawSession- sessionPtr <- newStablePtr session- sessionHookSet rawSession (castStablePtrToPtr sessionPtr)- return session--{#fun gsasl_client_start {- rawContext `Context'- ,`String'- ,id `Ptr SessionPtr'- } -> `()' checkRC* #}--serverStart :: Context -> String -> IO Session-serverStart ctxt s =- alloca $ \psess -> do- gsasl_server_start ctxt s psess- rawSession <- peek psess- let session = Session rawSession- sessionPtr <- newStablePtr session- sessionHookSet rawSession (castStablePtrToPtr sessionPtr)- return session--{#fun gsasl_server_start {- rawContext `Context'- ,`String'- ,id `Ptr SessionPtr'- } -> `()' checkRC* #}--freeSession :: Session -> IO ()-freeSession session = do- hook <- sessionHookGet (rawSession session)- freeStablePtr . castPtrToStablePtr $ hook- gsasl_finish session--{#fun gsasl_finish {- rawSession `Session'- } -> `()' #}--withSession :: IO Session -> (Session -> IO a) -> IO a-withSession getSession = bracket getSession freeSession--step :: Session -> String -> IO (String, ReturnCode)-step s input = let step' = {#call gsasl_step #} (rawSession s) in- withCStringLen input $ \(cInput, cInputLen) -> do- alloca $ \pOutChars -> do- alloca $ \pOutLen -> do- rc <- checkStepRC =<< step' cInput (fromIntegral cInputLen) pOutChars pOutLen- outChars <- peek pOutChars- outLen <- peek pOutLen- output <- peekCStringLen (outChars, fromIntegral outLen)- free outChars- return (output, rc)--step64 :: Session -> String -> IO (String, ReturnCode)-step64 s input = let step64' = {#call gsasl_step64 #} (rawSession s) in- withCString input $ \cInput -> do- alloca $ \pOutChars -> do- rc <- checkStepRC =<< step64' cInput pOutChars- outChars <- peek pOutChars- output <- peekCString outChars- free outChars- return (output, rc)--encode :: Session -> String -> IO String-encode = encodeDecodeImpl {#call gsasl_encode #}--decode :: Session -> String -> IO String-decode = encodeDecodeImpl {#call gsasl_decode #}--encodeDecodeImpl cfunc s input =- withCStringLen input $ \(cInput, cInputLen) -> do- alloca $ \pOutChars -> do- alloca $ \pOutLen -> do- checkRC =<< cfunc (rawSession s) cInput (fromIntegral cInputLen) pOutChars pOutLen- outChars <- peek pOutChars- outLen <- peek pOutLen- output <- peekCStringLen (outChars, fromIntegral outLen)- free outChars- return output---- Error information-{#fun gsasl_strerror {- cFromEnum `ReturnCode'- } -> `String' #}-----------------------------------------------------------------------------------split :: (Eq a) => a -> [a] -> [[a]]-split x ys = filter (not . null) $ split' [] [] x ys--split' :: (Eq a) => [a] -> [[a]] -> a -> [a] -> [[a]]-split' prev acc _ [] = acc ++ [prev]-split' prev acc x (y:ys)- | x == y = split' [] (acc ++ [prev]) x ys- | otherwise = split' (prev ++ [y]) acc x ys
gsasl.cabal view
@@ -1,21 +1,31 @@ name: gsasl-version: 0.2-stability: Alpha+version: 0.3 synopsis: Bindings for GNU SASL-license: GPL+license: GPL-3 license-file: License.txt author: John Millikin maintainer: jmillikin@gmail.com build-type: Simple-cabal-version: >=1.2+cabal-version: >=1.6 category: Network+stability: unstable+bug-reports: mailto:jmillikin@gmail.com+homepage: http://ianen.org/haskell/bindings/gsasl/+tested-with: GHC==6.12.1 +source-repository head+ type: darcs+ location: http://ianen.org/haskell/bindings/gsasl/+ library- build-depends: base >=3 && < 5- build-tools: c2hs- exposed-modules: Network.Protocol.SASL.GSASL+ build-depends:+ base >=3 && < 5+ , transformers >= 0.2 && < 0.3+ , bytestring >= 0.9 && < 0.10 + exposed-modules: Network.Protocol.SASL.GNU++ ghc-options: -Wall -fno-warn-unused-do-bind extra-libraries: gsasl pkgconfig-depends: libgsasl-- extensions: ForeignFunctionInterface+ c-sources: hsgsasl-shim.c
+ hsgsasl-shim.c view
@@ -0,0 +1,13 @@+#include <gsasl.h>++int hsgsasl_VERSION_MAJOR()+{ return GSASL_VERSION_MAJOR; }++int hsgsasl_VERSION_MINOR()+{ return GSASL_VERSION_MINOR; }++int hsgsasl_VERSION_PATCH()+{ return GSASL_VERSION_PATCH; }++int hsgsasl_check_version ()+{ return gsasl_check_version (GSASL_VERSION) != NULL; }