    {-# LANGUAGE FlexibleContexts #-}
    -- | Support for basic access authentication <http://en.wikipedia.org/wiki/Basic_access_authentication>
    module Happstack.Server.Auth where

    import Data.Foldable (foldl')
    import Data.Bits (xor, (.|.))
    import Data.Maybe (fromMaybe)
    import Control.Monad                             (MonadPlus(mzero, mplus))
    import Data.ByteString.Base64                    as Base64
    import qualified Data.ByteString                 as BS
    import qualified Data.ByteString.Char8           as B
    import qualified Data.Map                        as M
    import Happstack.Server.Monads                   (Happstack, escape, getHeaderM, setHeaderM)
    import Happstack.Server.Response                 (unauthorized, toResponse)

    -- | A simple HTTP basic authentication guard.
    --
    -- If authentication fails, this part will call 'mzero'.
    --
    -- example:
    --
    -- > main = simpleHTTP nullConf $
    -- >  msum [ basicAuth "127.0.0.1" (fromList [("happstack","rocks")]) $ ok "You are in the secret club"
    -- >       , ok "You are not in the secret club."
    -- >       ]
    --
    basicAuth :: (Happstack m) =>
       String -- ^ the realm name
       -> M.Map String String -- ^ the username password map
       -> m a -- ^ the part to guard
       -> m a
    basicAuth :: forall (m :: * -> *) a.
    Happstack m =>
    [Char] -> Map [Char] [Char] -> m a -> m a
    basicAuth [Char]
    realmName Map [Char] [Char]
    authMap = (ByteString -> ByteString -> Bool) -> [Char] -> m a -> m a
    forall (m :: * -> *) a.
    Happstack m =>
    (ByteString -> ByteString -> Bool) -> [Char] -> m a -> m a
    basicAuthBy (Map [Char] [Char] -> ByteString -> ByteString -> Bool
    validLoginPlaintext Map [Char] [Char]
    authMap) [Char]
    realmName

    -- | Generalized version of 'basicAuth'.
    --
    -- The function that checks the username password combination must be
    -- supplied as first argument.
    --
    -- example:
    --
    -- > main = simpleHTTP nullConf $
    -- >  msum [ basicAuth' (validLoginPlaintext (fromList [("happstack","rocks")])) "127.0.0.1" $ ok "You are in the secret club"
    -- >       , ok "You are not in the secret club."
    -- >       ]
    --
    basicAuthBy :: (Happstack m) =>
       (B.ByteString -> B.ByteString -> Bool) -- ^ function that returns true if the name password combination is valid
       -> String -- ^ the realm name
       -> m a -- ^ the part to guard
       -> m a
    basicAuthBy :: forall (m :: * -> *) a.
    Happstack m =>
    (ByteString -> ByteString -> Bool) -> [Char] -> m a -> m a
    basicAuthBy ByteString -> ByteString -> Bool
    validLogin [Char]
    realmName m a
    xs = m a
    forall {b}. m b
    basicAuthImpl m a -> m a -> m a
    forall a. m a -> m a -> m a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` m a
    xs
      where
        basicAuthImpl :: m b
    basicAuthImpl = do
            aHeader <- [Char] -> m (Maybe ByteString)
    forall (m :: * -> *).
    ServerMonad m =>
    [Char] -> m (Maybe ByteString)
    getHeaderM [Char]
    "authorization"
            case aHeader of
                Maybe ByteString
    Nothing -> m b
    forall (m :: * -> *) a. Happstack m => m a
    err
                Just ByteString
    x ->
                    do (name, password) <- ByteString -> m (ByteString, ByteString)
    forall {m :: * -> *}.
    Happstack m =>
    ByteString -> m (ByteString, ByteString)
    parseHeader ByteString
    x
                       if B.length password > 0
                          && B.head password == ':'
                          && validLogin name (B.tail password)
                         then mzero
                         else err
        parseHeader :: ByteString -> m (ByteString, ByteString)
    parseHeader ByteString
    h =
          case ByteString -> Either [Char] ByteString
    Base64.decode (ByteString -> Either [Char] ByteString)
    -> (ByteString -> ByteString)
    -> ByteString
    -> Either [Char] ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> ByteString -> ByteString
    B.drop Int
    6 (ByteString -> Either [Char] ByteString)
    -> ByteString -> Either [Char] ByteString
    forall a b. (a -> b) -> a -> b
    $ ByteString
    h of
            (Left [Char]
    _)   -> m (ByteString, ByteString)
    forall (m :: * -> *) a. Happstack m => m a
    err
            (Right ByteString
    bs) -> (ByteString, ByteString) -> m (ByteString, ByteString)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((Char -> Bool) -> ByteString -> (ByteString, ByteString)
    B.break (Char
    ':'Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==) ByteString
    bs)
        headerName :: [Char]
    headerName  = [Char]
    "WWW-Authenticate"
        headerValue :: [Char]
    headerValue = [Char]
    "Basic realm=\"" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    realmName [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "\""
        err :: (Happstack m) => m a
        err :: forall (m :: * -> *) a. Happstack m => m a
    err = m Response -> m a
    forall a (m :: * -> *) b.
    (WebMonad a m, FilterMonad a m) =>
    m a -> m b
    escape (m Response -> m a) -> m Response -> m a
    forall a b. (a -> b) -> a -> b
    $ do
                [Char] -> [Char] -> m ()
    forall (m :: * -> *).
    FilterMonad Response m =>
    [Char] -> [Char] -> m ()
    setHeaderM [Char]
    headerName [Char]
    headerValue
                Response -> m Response
    forall (m :: * -> *) a. FilterMonad Response m => a -> m a
    unauthorized (Response -> m Response) -> Response -> m Response
    forall a b. (a -> b) -> a -> b
    $ [Char] -> Response
    forall a. ToMessage a => a -> Response
    toResponse [Char]
    "Not authorized"

    -- | Function that looks up the plain text password for username in a
    -- Map and returns True if it matches with the given password.
    --
    -- Note: The implementation is hardened against timing attacks but not
    -- completely safe. Ideally you should build your own predicate, using
    -- a robust constant-time equality comparison from a cryptographic
    -- library like sodium.
    validLoginPlaintext ::
      M.Map String String -- ^ the username password map
      -> B.ByteString -- ^ the username
      -> B.ByteString -- ^ the password
      -> Bool
    validLoginPlaintext :: Map [Char] [Char] -> ByteString -> ByteString -> Bool
    validLoginPlaintext Map [Char] [Char]
    authMap ByteString
    name ByteString
    password = Bool -> Maybe Bool -> Bool
    forall a. a -> Maybe a -> a
    fromMaybe Bool
    False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ do
        r <- [Char] -> Map [Char] [Char] -> Maybe [Char]
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup (ByteString -> [Char]
    B.unpack ByteString
    name) Map [Char] [Char]
    authMap
        pure (constTimeEq (B.pack r) password)
      where
        -- (Mostly) constant time equality of bytestrings to prevent timing attacks by testing out passwords. This still
        -- allows to extract the length of the configured password via timing attacks. This implementation is still brittle
        -- in the sense that it relies on GHC not unrolling or vectorizing the loop.
        {-# NOINLINE constTimeEq #-}
        constTimeEq :: BS.ByteString -> BS.ByteString -> Bool
        constTimeEq :: ByteString -> ByteString -> Bool
    constTimeEq ByteString
    x ByteString
    y
          | ByteString -> Int
    BS.length ByteString
    x Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ByteString -> Int
    BS.length ByteString
    y
          = Bool
    False

          | Bool
    otherwise
          = (Word8 -> Word8 -> Word8) -> Word8 -> [Word8] -> Word8
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' Word8 -> Word8 -> Word8
    forall a. Bits a => a -> a -> a
    (.|.) Word8
    0 ((Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> [Word8]
    forall a. (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a]
    BS.zipWith Word8 -> Word8 -> Word8
    forall a. Bits a => a -> a -> a
    xor ByteString
    x ByteString
    y) Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    0