HttpAuth.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
-- | Implements HTTP Basic Authentication.
--
-- This module may add digest authentication in the future.
module Network.Wai.Middleware.HttpAuth
    ( -- * Middleware
      basicAuth
    , basicAuth'
    , CheckCreds
    , AuthSettings
    , authRealm
    , authOnNoAuth
    , authIsProtected
      -- * Helping functions
    , extractBasicAuth
    , extractBearerAuth
    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.ByteString.Base64 (decodeLenient)
import Data.String (IsString (..))
import Data.Word8 (isSpace, toLower, _colon)
import Network.HTTP.Types (hAuthorization, hContentType, status401)
import Network.Wai (Application, Middleware, Request (requestHeaders), responseLBS)


-- | Check if a given username and password is valid.
type CheckCreds = ByteString
               -> ByteString
               -> IO Bool

-- | Perform basic authentication.
--
-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"
--
-- @since 1.3.4
basicAuth :: CheckCreds
          -> AuthSettings
          -> Middleware
basicAuth checkCreds = basicAuth' (\_ -> checkCreds)

-- | Like 'basicAuth', but also passes a request to the authentication function.
--
-- @since 3.0.19
basicAuth' :: (Request -> CheckCreds)
           -> AuthSettings
           -> Middleware
basicAuth' checkCreds AuthSettings {..} app req sendResponse = do
    isProtected <- authIsProtected req
    allowed <- if isProtected then check else return True
    if allowed
        then app req sendResponse
        else authOnNoAuth authRealm req sendResponse
  where
    check =
        case lookup hAuthorization (requestHeaders req)
             >>= extractBasicAuth of
            Nothing -> return False
            Just (username, password) -> checkCreds req username password

-- | Basic authentication settings. This value is an instance of
-- @IsString@, so the recommended approach to create a value is to
-- provide a string literal (which will be the realm) and then
-- overriding individual fields.
--
-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings
--
-- @since 1.3.4
data AuthSettings = AuthSettings
    { authRealm :: !ByteString
    -- ^
    --
    -- @since 1.3.4
    , authOnNoAuth :: !(ByteString -> Application)
    -- ^ Takes the realm and returns an appropriate 401 response when
    -- authentication is not provided.
    --
    -- @since 1.3.4
    , authIsProtected :: !(Request -> IO Bool)
    -- ^ Determine if access to the requested resource is restricted.
    --
    -- Default: always returns @True@.
    --
    -- @since 1.3.4
    }

instance IsString AuthSettings where
    fromString s = AuthSettings
        { authRealm = fromString s
        , authOnNoAuth = \realm _req f -> f $ responseLBS
            status401
            [ (hContentType, "text/plain")
            , ("WWW-Authenticate", S.concat
                [ "Basic realm=\""
                , realm
                , "\""
                ])
            ]
            "Basic authentication is required"
        , authIsProtected = const $ return True
        }

-- | Extract basic authentication data from usually __Authorization__
-- header value. Returns username and password
--
-- @since 3.0.5
extractBasicAuth :: ByteString -> Maybe (ByteString, ByteString)
extractBasicAuth bs =
    let (x, y) = S.break isSpace bs
    in if S.map toLower x == "basic"
       then extract $ S.dropWhile isSpace y
       else Nothing
  where
    extract encoded =
        let raw = decodeLenient encoded
            (username, password') = S.break (== _colon) raw
        in ((username,) . snd) <$> S.uncons password'

-- | Extract bearer authentication data from __Authorization__ header
-- value. Returns bearer token
--
-- @since 3.0.5
extractBearerAuth :: ByteString -> Maybe ByteString
extractBearerAuth bs =
    let (x, y) = S.break isSpace bs
    in if S.map toLower x == "bearer"
        then Just $ S.dropWhile isSpace y
        else Nothing