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 realm testAuth next = do
req <- request
let authStr = fromMaybe "" $ lookup hAuthorization (requestHeaders req)
when (S8.take 5 authStr /= "Basic") requireAuth
case fmap (S8.split ':') $ decode $ S8.drop 6 authStr of
Right (user:pwd:[]) -> do
mfin <- testAuth req user pwd
maybe requireAuth (\finReq -> localRequest (const finReq) next) mfin
_ -> requireAuth
where requireAuth = respond $ requireBasicAuth realm
authRewriteReq :: AuthRouter r a
-> (S8.ByteString -> S8.ByteString -> Controller r Bool)
-> Controller r a
-> Controller r a
authRewriteReq authRouter testAuth rt =
authRouter (\req user pwd -> do
success <- testAuth user pwd
if success then
return $ Just $ transReq req user
else return Nothing) rt
where transReq req user = req
{ requestHeaders = ("X-User", user):(requestHeaders req)}
basicAuth :: String
-> S8.ByteString
-> S8.ByteString
-> Controller r a -> Controller r a
basicAuth realm user pwd = authRewriteReq (basicAuthRoute realm)
(\u p -> return $ u == user && p == pwd)