module Database.Memcache.SASL (
authenticate, Authentication(..), Username, Password
) where
import Database.Memcache.Errors
import Database.Memcache.Types
import Database.Memcache.Wire
import qualified Control.Exception as E (onException)
import Control.Monad
import Data.ByteString.Char8 as B8 (ByteString, pack, singleton)
import Data.Monoid
import Network.Socket (Socket)
authenticate :: Socket -> Authentication -> IO ()
authenticate _ NoAuth = return ()
authenticate s (Auth u p) = saslAuthPlain s u p
saslAuthPlain :: Socket -> Username -> Password -> IO ()
saslAuthPlain s u p = do
let credentials = singleton '\0' <> u <> singleton '\0' <> p
msg = emptyReq { reqOp = ReqSASLStart (B8.pack "PLAIN") credentials }
send s msg
r <- recv s `E.onException` throwStatus SaslAuthFail
when (resOp r /= ResSASLStart) $ throwIncorrectRes r "SASL_START"
case resStatus r of
NoError -> return ()
rs -> throwStatus rs
saslListMechs :: Socket -> IO B8.ByteString
saslListMechs s = do
let msg = emptyReq { reqOp = ReqSASLList }
send s msg
r <- recv s
v <- case resOp r of
ResSASLList v -> return v
_ -> throwIncorrectRes r "SASL_LIST"
case resStatus r of
NoError -> return v
rs -> throwStatus rs