{-# LANGUAGE OverloadedStrings #-}
module Web.Simple.Auth
( AuthRouter
, basicAuthRoute, basicAuth, authRewriteReq
) where
import Control.Monad
import Data.ByteString.Base64
import qualified Data.ByteString.Char8 as S8
import Data.Maybe
import Network.HTTP.Types
import Network.Wai
import Web.Simple.Responses
import Web.Simple.Controller
type AuthRouter r a = (Request -> S8.ByteString
-> S8.ByteString
-> Controller r (Maybe Request))
-> Controller r a
-> Controller r a
basicAuthRoute :: String -> AuthRouter r a
basicAuthRoute :: String -> AuthRouter r a
basicAuthRoute realm :: String
realm testAuth :: Request -> ByteString -> ByteString -> Controller r (Maybe Request)
testAuth next :: Controller r a
next = do
Request
req <- Controller r Request
forall s. Controller s Request
request
let authStr :: ByteString
authStr = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAuthorization (Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)
Bool -> ControllerT r IO () -> ControllerT r IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> ByteString -> ByteString
S8.take 5 ByteString
authStr ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= "Basic") ControllerT r IO ()
forall s a. Controller s a
requireAuth
case (ByteString -> [ByteString])
-> Either String ByteString -> Either String [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> ByteString -> [ByteString]
S8.split ':') (Either String ByteString -> Either String [ByteString])
-> Either String ByteString -> Either String [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S8.drop 6 ByteString
authStr of
Right (user :: ByteString
user:pwd :: ByteString
pwd:[]) -> do
Maybe Request
mfin <- Request -> ByteString -> ByteString -> Controller r (Maybe Request)
testAuth Request
req ByteString
user ByteString
pwd
Controller r a
-> (Request -> Controller r a) -> Maybe Request -> Controller r a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Controller r a
forall s a. Controller s a
requireAuth (\finReq :: Request
finReq -> (Request -> Request) -> Controller r a -> Controller r a
forall s a.
(Request -> Request) -> Controller s a -> Controller s a
localRequest (Request -> Request -> Request
forall a b. a -> b -> a
const Request
finReq) Controller r a
next) Maybe Request
mfin
_ -> Controller r a
forall s a. Controller s a
requireAuth
where requireAuth :: Controller s a
requireAuth = Response -> Controller s a
forall s a. Response -> Controller s a
respond (Response -> Controller s a) -> Response -> Controller s a
forall a b. (a -> b) -> a -> b
$ String -> Response
requireBasicAuth String
realm
authRewriteReq :: AuthRouter r a
-> (S8.ByteString -> S8.ByteString -> Controller r Bool)
-> Controller r a
-> Controller r a
authRewriteReq :: AuthRouter r a
-> (ByteString -> ByteString -> Controller r Bool)
-> Controller r a
-> Controller r a
authRewriteReq authRouter :: AuthRouter r a
authRouter testAuth :: ByteString -> ByteString -> Controller r Bool
testAuth rt :: Controller r a
rt =
AuthRouter r a
authRouter (\req :: Request
req user :: ByteString
user pwd :: ByteString
pwd -> do
Bool
success <- ByteString -> ByteString -> Controller r Bool
testAuth ByteString
user ByteString
pwd
if Bool
success then
Maybe Request -> ControllerT r IO (Maybe Request)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Request -> ControllerT r IO (Maybe Request))
-> Maybe Request -> ControllerT r IO (Maybe Request)
forall a b. (a -> b) -> a -> b
$ Request -> Maybe Request
forall a. a -> Maybe a
Just (Request -> Maybe Request) -> Request -> Maybe Request
forall a b. (a -> b) -> a -> b
$ Request -> ByteString -> Request
transReq Request
req ByteString
user
else Maybe Request -> ControllerT r IO (Maybe Request)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Request
forall a. Maybe a
Nothing) Controller r a
rt
where transReq :: Request -> ByteString -> Request
transReq req :: Request
req user :: ByteString
user = Request
req
{ requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = ("X-User", ByteString
user)(HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
:(Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)}
basicAuth :: String
-> S8.ByteString
-> S8.ByteString
-> Controller r a -> Controller r a
basicAuth :: String
-> ByteString -> ByteString -> Controller r a -> Controller r a
basicAuth realm :: String
realm user :: ByteString
user pwd :: ByteString
pwd = AuthRouter r a
-> (ByteString -> ByteString -> Controller r Bool)
-> Controller r a
-> Controller r a
forall r a.
AuthRouter r a
-> (ByteString -> ByteString -> Controller r Bool)
-> Controller r a
-> Controller r a
authRewriteReq (String -> AuthRouter r a
forall r a. String -> AuthRouter r a
basicAuthRoute String
realm)
(\u :: ByteString
u p :: ByteString
p -> Bool -> Controller r Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Controller r Bool) -> Bool -> Controller r Bool
forall a b. (a -> b) -> a -> b
$ ByteString
u ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
user Bool -> Bool -> Bool
&& ByteString
p ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
pwd)