@@ -0,0 +1,98 @@
1+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
2+-- | Implements HTTP Basic Authentication.
3+--
4+-- This module may add digest authentication in the future.
5+module Network.Wai.Middleware.HttpAuth
6+ ( basicAuth
7+ , CheckCreds
8+ , AuthSettings
9+ , authRealm
10+ , authOnNoAuth
11+ , authIsProtected
12+ ) where
13+
14+import Network.Wai
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)
22+
23+-- | Check if a given username and password is valid.
24+type CheckCreds = ByteString
25+ -> ByteString
26+ -> ResourceT IO Bool
27+
28+-- | Perform basic authentication.
29+--
30+-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"
31+--
32+-- Since 1.3.4
33+basicAuth :: CheckCreds
34+ -> AuthSettings
35+ -> Middleware
36+basicAuth checkCreds AuthSettings {..} app req = do
37+ isProtected <- authIsProtected req
38+ allowed <- if isProtected then check else return True
39+ if allowed
40+ then app req
41+ else authOnNoAuth authRealm req
42+ where
43+ check =
44+ case lookup "Authorization" $ requestHeaders req of
45+ Nothing -> return False
46+ Just bs ->
47+ let (x, y) = S.break isSpace bs
48+ in if S.map toLower x == "basic"
49+ then checkB64 $ S.dropWhile isSpace y
50+ else return False
51+ checkB64 encoded =
52+ case S.uncons password' of
53+ Just (_, password) -> checkCreds username password
54+ Nothing -> return False
55+ where
56+ raw = decodeLenient encoded
57+ (username, password') = S.breakByte _colon raw
58+
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.
62+--
63+-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings
64+--
65+-- Since 1.3.4
66+data AuthSettings = AuthSettings
67+ { authRealm :: !ByteString
68+ -- ^
69+ --
70+ -- Since 1.3.4
71+ , authOnNoAuth :: !(ByteString -> Application)
72+ -- ^ Takes the realm and returns an appropriate 401 response when
73+ -- authentication is not provided.
74+ --
75+ -- Since 1.3.4
76+ , authIsProtected :: !(Request -> ResourceT IO Bool)
77+ -- ^ Determine if access to the requested resource is restricted.
78+ --
79+ -- Default: always returns @True@.
80+ --
81+ -- Since 1.3.4
82+ }
83+
84+instance IsString AuthSettings where
85+ fromString s = AuthSettings
86+ { authRealm = fromString s
87+ , authOnNoAuth = \realm _req -> return $ responseLBS
88+ status401
89+ [ ("Content-Type", "text/plain")
90+ , ("WWW-Authenticate", S.concat
91+ [ "Basic realm=\""
92+ , realm
93+ , "\""
94+ ])
95+ ]
96+ "Basic authentication is required"
97+ , authIsProtected = const $ return True
98+ }