lio-simple 0.0.0.3 → 0.0.1.0

raw patch · 2 files changed

+55/−17 lines, 2 files

Files

• LIO/Web/Simple/Auth.hs +54/−16
• lio-simple.cabal +1/−1

@@ -1,9 +1,16 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE OverloadedStrings #-} --- | Provides HTTP Basic Authentication.-module LIO.Web.Simple.Auth ( basicAuth) where+-- | Provides generic and HTTP Basic authentication.+module LIO.Web.Simple.Auth ( basicAuth+                           , handleAuth+                           , requestLogin+                           -- * Helpers+                           , withUserOrLogin+                           , currentUser+                           ) where +import Data.Maybe import Control.Monad import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Base64@@ -13,24 +20,26 @@ import Web.Simple.Controller.Trans  --- | A 'Route' that uses HTTP basic authentication to authenticate a--- request for a realm with the given username ans password. The--- request is rewritten with an 'X-User' header containing the--- authenticated username before being passed to the next 'Route'.+-- | A middleware that uses HTTP basic authentication to authenticate+-- a request for a realm with the given username and password. The+-- request is rewritten with an @X-User@ request header containing the+-- authenticated username before being passed to the next+-- 'application'. Note that the HTTP basic authentication header is+-- only set if the executed app requests it, by setting the @X-Login@+-- response header (e.g., with 'requestLogin'). basicAuth :: Monad m           => String                          -- ^ Realm           -> (S8.ByteString -> S8.ByteString -> m Bool)           -> SimpleMiddleware m-basicAuth realm auth app req = -  case getBasicAuthLogin req of-    Nothing -> return authResp-    Just (usr, pwd) -> do-      success <- auth usr pwd-      let req' = req { requestHeaders = ("X-User", usr) : requestHeaders req }-      if success-        then app req'-        else return authResp-    where authResp = requireBasicAuth realm+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   -- | Helper method for implementing basic authentication. Given a@@ -44,3 +53,32 @@   case up of      Right (user:pwd:[]) -> return (user, pwd)      _ -> fail "Malformed basic auth header."++-- | Executes the app and if the app 'Response' has header+-- @X-Login@ and the user is not logged in, i.e., the @X-User@ request+-- header is not present, execute the login application.+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++-- | Request authentication middleware to authenticate user+requestLogin :: Response+requestLogin = responseLBS status400 [("X-Login", "True")] ""++-- | Execute action with the current user's name. Otherwise, request+-- that the user authenticate.+withUserOrLogin :: Monad m +                => (S8.ByteString -> ControllerT m r a)+                -> ControllerT m r a+withUserOrLogin act = currentUser >>= \muser ->+  maybe (respond requestLogin) act muser++-- | Get the current user.+currentUser :: Monad m => ControllerT m r (Maybe S8.ByteString)+currentUser = requestHeader "X-User"

@@ -1,5 +1,5 @@ name:                lio-simple-version:             0.0.0.3+version:             0.0.1.0 synopsis:            LIO support for the Simple web framework description: