    {-# LANGUAGE OverloadedStrings #-}

    -- | Provides HTTP Basic Authentication.
    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

    -- | An 'AuthRouter' authenticates a 'Request' and, if successful, forwards the
    -- 'Request' to the 'Routeable'.
    type AuthRouter r a = (Request -> S8.ByteString
                                   -> S8.ByteString
                                   -> Controller r (Maybe Request))
                      -> Controller r a
                      -> Controller r a

    -- | An 'AuthRouter' that uses HTTP basic authentication to authenticate a request
    -- in a particular realm.
    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

    -- | Wraps an 'AuthRouter' to take a simpler authentication function (that just
    -- just takes a username and password, and returns 'True' or 'False'). It also
    -- adds an \"X-User\" header to the 'Request' with the authenticated user\'s
    -- name (the first argument to the authentication function).
    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)}

    -- | 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'.
    basicAuth :: String
              -- ^ Realm
              -> S8.ByteString
              -- ^ Username
              -> S8.ByteString
              -- ^ Password
              -> 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)