@@ -0,0 +1,98 @@
1+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
2+-- | Implements HTTP Basic Authentication.
4+-- This module may add digest authentication in the future.
5+module Network.Wai.Middleware.HttpAuth
15+import Network.HTTP.Types (status401)
16+import Data.ByteString (ByteString)
17+import qualified Data.ByteString as S
18+import Data.String (IsString (..))
19+import Control.Monad.Trans.Resource (ResourceT)
20+import Data.Word8 (isSpace, _colon, toLower)
21+import Data.ByteString.Base64 (decodeLenient)
23+-- | Check if a given username and password is valid.
24+type CheckCreds = ByteString
28+-- | Perform basic authentication.
30+-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"
33+basicAuth :: CheckCreds
36+basicAuth checkCreds AuthSettings {..} app req = do
37+ isProtected <- authIsProtected req
38+ allowed <- if isProtected then check else return True
41+ else authOnNoAuth authRealm req
44+ case lookup "Authorization" $ requestHeaders req of
45+ Nothing -> return False
47+ let (x, y) = S.break isSpace bs
48+ in if S.map toLower x == "basic"
49+ then checkB64 $ S.dropWhile isSpace y
52+ case S.uncons password' of
53+ Just (_, password) -> checkCreds username password
54+ Nothing -> return False
56+ raw = decodeLenient encoded
57+ (username, password') = S.breakByte _colon raw
59+-- | Authentication settings. This value is an instance of @IsString@, so the
60+-- recommended approach to create a value is to provide a string literal (which
61+-- will be the realm) and then overriding individual fields.
63+-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings
66+data AuthSettings = AuthSettings
67+ { authRealm :: !ByteString
71+ , authOnNoAuth :: !(ByteString -> Application)
72+ -- ^ Takes the realm and returns an appropriate 401 response when
73+ -- authentication is not provided.
76+ , authIsProtected :: !(Request -> ResourceT IO Bool)
77+ -- ^ Determine if access to the requested resource is restricted.
79+ -- Default: always returns @True@.
84+instance IsString AuthSettings where
85+ fromString s = AuthSettings
86+ { authRealm = fromString s
87+ , authOnNoAuth = \realm _req -> return $ responseLBS
89+ [ ("Content-Type", "text/plain")
90+ , ("WWW-Authenticate", S.concat
96+ "Basic authentication is required"
97+ , authIsProtected = const $ return True