Add HttpAuth module

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
+        }

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