diff --git a/wai-extra/Network/Wai/Middleware/HttpAuth.hs b/wai-extra/Network/Wai/Middleware/HttpAuth.hs new file mode 100644 index 00000000..bb7284e0 --- /dev/null +++ b/wai-extra/Network/Wai/Middleware/HttpAuth.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +-- | Implements HTTP Basic Authentication. +-- +-- This module may add digest authentication in the future. +module Network.Wai.Middleware.HttpAuth + ( basicAuth + , CheckCreds + , AuthSettings + , authRealm + , authOnNoAuth + , authIsProtected + ) where + +import Network.Wai +import Network.HTTP.Types (status401) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.String (IsString (..)) +import Control.Monad.Trans.Resource (ResourceT) +import Data.Word8 (isSpace, _colon, toLower) +import Data.ByteString.Base64 (decodeLenient) + +-- | Check if a given username and password is valid. +type CheckCreds = ByteString + -> ByteString + -> ResourceT 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 AuthSettings {..} app req = do + isProtected <- authIsProtected req + allowed <- if isProtected then check else return True + if allowed + then app req + else authOnNoAuth authRealm req + where + check = + case lookup "Authorization" $ requestHeaders req of + Nothing -> return False + Just bs -> + let (x, y) = S.break isSpace bs + in if S.map toLower x == "basic" + then checkB64 $ S.dropWhile isSpace y + else return False + checkB64 encoded = + case S.uncons password' of + Just (_, password) -> checkCreds username password + Nothing -> return False + where + raw = decodeLenient encoded + (username, password') = S.breakByte _colon raw + +-- | 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 -> ResourceT 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 -> return $ responseLBS + status401 + [ ("Content-Type", "text/plain") + , ("WWW-Authenticate", S.concat + [ "Basic realm=\"" + , realm + , "\"" + ]) + ] + "Basic authentication is required" + , authIsProtected = const $ return True + } diff --git a/wai-extra/wai-extra.cabal b/wai-extra/wai-extra.cabal index 6666f8e9..d48ee8db 100644 --- a/wai-extra/wai-extra.cabal +++ b/wai-extra/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 1.3.3.2 +Version: 1.3.4 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: MIT @@ -44,6 +44,8 @@ Library , void >= 0.5 , stringsearch >= 0.3 && < 0.4 , containers + , base64-bytestring + , word8 Exposed-modules: Network.Wai.Handler.CGI Network.Wai.Middleware.AcceptOverride @@ -56,6 +58,7 @@ Library Network.Wai.Middleware.MethodOverridePost Network.Wai.Middleware.Rewrite Network.Wai.Middleware.Vhost + Network.Wai.Middleware.HttpAuth Network.Wai.Parse ghc-options: -Wall