{-# OPTIONS_GHC -fno-warn-unused-binds #-}

{-|
Module      : Database.Memcache.SASL
Description : SASL Authentication
Copyright   : (c) David Terei, 2016
License     : BSD
Maintainer  : code@davidterei.com
Stability   : stable
Portability : GHC

SASL authentication support for Memcached.
-}
module Database.Memcache.SASL (
        -- * Types
        Authentication(..), Username, Password,

        -- * Operations
        authenticate
    ) where

import Database.Memcache.Errors
import Database.Memcache.Socket
import Database.Memcache.Types

import Control.Exception (throwIO)
import Control.Monad
import Data.ByteString.Char8 as B8 (ByteString, pack, singleton)

-- | Perform SASL authentication with the server.
authenticate :: Socket -> Authentication -> IO ()
{-# INLINE authenticate #-}
authenticate :: Socket -> Authentication -> IO ()
authenticate Socket
_ Authentication
NoAuth     = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
authenticate Socket
s (Auth Username
u Username
p) = Socket -> Username -> Username -> IO ()
saslAuthPlain Socket
s Username
u Username
p
-- NOTE: For correctness really should check that PLAIN auth is supported first
-- but we'll just assume it is as that's all mainline and other implementations
-- support and one exception is nearly as good as another.

-- | Perform SASL PLAIN authentication.
saslAuthPlain :: Socket -> Username -> Password -> IO ()
{-# INLINE saslAuthPlain #-}
saslAuthPlain :: Socket -> Username -> Username -> IO ()
saslAuthPlain Socket
s Username
u Username
p = do
    let credentials :: Username
credentials = Char -> Username
singleton Char
'\0' Username -> Username -> Username
forall a. Semigroup a => a -> a -> a
<> Username
u Username -> Username -> Username
forall a. Semigroup a => a -> a -> a
<> Char -> Username
singleton Char
'\0' Username -> Username -> Username
forall a. Semigroup a => a -> a -> a
<> Username
p
        msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = Username -> Username -> OpRequest
ReqSASLStart (String -> Username
B8.pack String
"PLAIN") Username
credentials }
    Socket -> Request -> IO ()
send Socket
s Request
msg
    Response
r <- Socket -> IO Response
recv Socket
s
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response -> OpResponse
resOp Response
r OpResponse -> OpResponse -> Bool
forall a. Eq a => a -> a -> Bool
/= OpResponse
ResSASLStart) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"SASL_START"
    case Response -> Status
resStatus Response
r of
        Status
NoError -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Status
rs      -> MemcacheError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO ()) -> MemcacheError -> IO ()
forall a b. (a -> b) -> a -> b
$ Status -> MemcacheError
OpError Status
rs

-- | List available SASL authentication methods. We could call this but as we
-- only support PLAIN as does the Memcached server, we simply assume PLAIN
-- authentication is supprted and try that.
saslListMechs :: Socket -> IO B8.ByteString
{-# INLINE saslListMechs #-}
saslListMechs :: Socket -> IO Username
saslListMechs Socket
s = do
    let msg :: Request
msg = Request
emptyReq { reqOp :: OpRequest
reqOp = OpRequest
ReqSASLList }
    Socket -> Request -> IO ()
send Socket
s Request
msg
    Response
r <- Socket -> IO Response
recv Socket
s
    Username
v <- case Response -> OpResponse
resOp Response
r of
        ResSASLList Username
v -> Username -> IO Username
forall (m :: * -> *) a. Monad m => a -> m a
return Username
v
        OpResponse
_             -> MemcacheError -> IO Username
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO Username) -> MemcacheError -> IO Username
forall a b. (a -> b) -> a -> b
$ Response -> String -> MemcacheError
wrongOp Response
r String
"SASL_LIST"
    case Response -> Status
resStatus Response
r of
        Status
NoError -> Username -> IO Username
forall (m :: * -> *) a. Monad m => a -> m a
return Username
v
        Status
rs      -> MemcacheError -> IO Username
forall e a. Exception e => e -> IO a
throwIO (MemcacheError -> IO Username) -> MemcacheError -> IO Username
forall a b. (a -> b) -> a -> b
$ Status -> MemcacheError
OpError Status
rs