content: {-# LANGUAGE Trustworthy #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  -- | 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
  import Network.HTTP.Types
  import Network.Wai
  import Web.Simple.Responses
  import Web.Simple.Controller.Trans
  
  
  -- | 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 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
  -- 'Request' returns the (username, password) pair from the basic
  -- authentication header if present.
  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."
  
  -- | 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 r m a)
                  -> ControllerT r m a
  withUserOrLogin act = currentUser >>= \muser ->
    maybe (respond requestLogin) act muser
  
  -- | Get the current user.
  currentUser :: Monad m => ControllerT r m (Maybe S8.ByteString)
  currentUser = requestHeader "X-User"
  