@@ -5,6 +5,7 @@
5module Network.Wai.Middleware.HttpAuth
5module Network.Wai.Middleware.HttpAuth
6 ( -- * Middleware
6 ( -- * Middleware
8 , CheckCreds
9 , CheckCreds
9 , AuthSettings
10 , AuthSettings
10 , authRealm
11 , authRealm
@@ -36,11 +37,19 @@ type CheckCreds = ByteString
37-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"
38-- > basicAuth (\u p -> return $ u == "michael" && p == "mypass") "My Realm"
39−-- Since 1.3.4
40+-- @since 1.3.4
40basicAuth :: CheckCreds
41basicAuth :: CheckCreds
41 -> AuthSettings
42 -> AuthSettings
42 -> Middleware
43 -> Middleware
44+basicAuth checkCreds = basicAuth' (\_ -> checkCreds)
46+-- | Like 'basicAuth', but also passes a request to the authentication function.
49+basicAuth' :: (Request -> CheckCreds)
43−basicAuth checkCreds AuthSettings {..} app req sendResponse = do
52+basicAuth' checkCreds AuthSettings {..} app req sendResponse = do
44 isProtected <- authIsProtected req
53 isProtected <- authIsProtected req
45 allowed <- if isProtected then check else return True
54 allowed <- if isProtected then check else return True
46 if allowed
55 if allowed
@@ -51,8 +60,7 @@ basicAuth checkCreds AuthSettings {..} app req sendResponse = do
51 case (lookup hAuthorization $ requestHeaders req)
60 case (lookup hAuthorization $ requestHeaders req)
52 >>= extractBasicAuth of
61 >>= extractBasicAuth of
53 Nothing -> return False
62 Nothing -> return False
54− Just (username, password) -> checkCreds username password
63+ Just (username, password) -> checkCreds req username password
57-- | Basic authentication settings. This value is an instance of
65-- | Basic authentication settings. This value is an instance of
58-- @IsString@, so the recommended approach to create a value is to
66-- @IsString@, so the recommended approach to create a value is to
@@ -61,23 +69,23 @@ basicAuth checkCreds AuthSettings {..} app req sendResponse = do
62-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings
70-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings
64−-- Since 1.3.4
72+-- @since 1.3.4
65data AuthSettings = AuthSettings
73data AuthSettings = AuthSettings
66 { authRealm :: !ByteString
74 { authRealm :: !ByteString
69− -- Since 1.3.4
77+ -- @since 1.3.4
70 , authOnNoAuth :: !(ByteString -> Application)
78 , authOnNoAuth :: !(ByteString -> Application)
71 -- ^ Takes the realm and returns an appropriate 401 response when
79 -- ^ Takes the realm and returns an appropriate 401 response when
72 -- authentication is not provided.
80 -- authentication is not provided.
74− -- Since 1.3.4
82+ -- @since 1.3.4
75 , authIsProtected :: !(Request -> IO Bool)
83 , authIsProtected :: !(Request -> IO Bool)
76 -- ^ Determine if access to the requested resource is restricted.
84 -- ^ Determine if access to the requested resource is restricted.
78 -- Default: always returns @True@.
86 -- Default: always returns @True@.
80− -- Since 1.3.4
88+ -- @since 1.3.4
83instance IsString AuthSettings where
91instance IsString AuthSettings where
@@ -99,7 +107,7 @@ instance IsString AuthSettings where
99-- | Extract basic authentication data from usually __Authorization__
107-- | Extract basic authentication data from usually __Authorization__
100-- header value. Returns username and password
108-- header value. Returns username and password
102−-- Since 3.0.5
110+-- @since 3.0.5
103extractBasicAuth :: ByteString -> Maybe (ByteString, ByteString)
111extractBasicAuth :: ByteString -> Maybe (ByteString, ByteString)
104extractBasicAuth bs =
112extractBasicAuth bs =
105 let (x, y) = S.break isSpace bs
113 let (x, y) = S.break isSpace bs
@@ -115,7 +123,7 @@ extractBasicAuth bs =
115-- | Extract bearer authentication data from __Authorization__ header
123-- | Extract bearer authentication data from __Authorization__ header
116-- value. Returns bearer token
124-- value. Returns bearer token
118−-- Since 3.0.5
126+-- @since 3.0.5
119extractBearerAuth :: ByteString -> Maybe ByteString
127extractBearerAuth :: ByteString -> Maybe ByteString
120extractBearerAuth bs =
128extractBearerAuth bs =
121 let (x, y) = S.break isSpace bs
129 let (x, y) = S.break isSpace bs