module LIO.Web.Simple.Auth ( basicAuth
, handleAuth
, requestLogin
, withUserOrLogin
, currentUser
) where
import Data.Maybe
import Control.Monad
import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Base64
import Network.HTTP.Types
import Network.Wai
import Web.Simple.Responses
import Web.Simple.Controller.Trans
basicAuth :: Monad m
=> String
-> (S8.ByteString -> S8.ByteString -> m Bool)
-> SimpleMiddleware m
basicAuth realm auth app0 req0 = handleAuth authApp (mkApp app0) req0
where authApp = const . return $ requireBasicAuth realm
mkApp app req = case getBasicAuthLogin req of
Nothing -> app req
Just (usr, pwd) -> do
success <- auth usr pwd
let req' = req { requestHeaders = ("X-User", usr) :
requestHeaders req }
if success then app req' else app req
getBasicAuthLogin :: Request -> Maybe (S8.ByteString, S8.ByteString)
getBasicAuthLogin req = do
authStr <- lookup hAuthorization $ requestHeaders req
unless ("Basic" `S8.isPrefixOf` authStr) $ fail "Not basic auth."
let up = fmap (S8.split ':') $ decode $ S8.drop 6 authStr
case up of
Right (user:pwd:[]) -> return (user, pwd)
_ -> fail "Malformed basic auth header."
handleAuth :: Monad m => SimpleApplication m -> SimpleMiddleware m
handleAuth loginApp app req = do
resp <- app req
if hasLogin resp && notLoggedIn
then loginApp req
else return resp
where hasLogin r = "X-Login" `isIn` responseHeaders r
notLoggedIn = not $ "X-User" `isIn` requestHeaders req
isIn n xs = isJust $ lookup n xs
requestLogin :: Response
requestLogin = responseLBS status400 [("X-Login", "True")] ""
withUserOrLogin :: Monad m
=> (S8.ByteString -> ControllerT r m a)
-> ControllerT r m a
withUserOrLogin act = currentUser >>= \muser ->
maybe (respond requestLogin) act muser
currentUser :: Monad m => ControllerT r m (Maybe S8.ByteString)
currentUser = requestHeader "X-User"