@@ -1,23 +1,30 @@
1−{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
1+{-# LANGUAGE RecordWildCards, OverloadedStrings, TupleSections #-}
22-- | Implements HTTP Basic Authentication.
33--
44-- This module may add digest authentication in the future.
55module Network.Wai.Middleware.HttpAuth
6− ( basicAuth
6+ ( -- * Middleware
7+ basicAuth
78 , CheckCreds
89 , AuthSettings
910 , authRealm
1011 , authOnNoAuth
1112 , authIsProtected
13+ -- * Helping functions
14+ , extractBasicAuth
15+ , extractBearerAuth
1216 ) where
1317
14−import Network.Wai
15−import Network.HTTP.Types (status401)
18+import Control.Applicative
1619import Data.ByteString (ByteString)
17−import qualified Data.ByteString as S
20+import Data.ByteString.Base64 (decodeLenient)
1821import Data.String (IsString (..))
1922import Data.Word8 (isSpace, _colon, toLower)
20−import Data.ByteString.Base64 (decodeLenient)
23+import Network.HTTP.Types (status401)
24+import Network.Wai
25+
26+import qualified Data.ByteString as S
27+
2128
2229-- | Check if a given username and password is valid.
2330type CheckCreds = ByteString
@@ -40,24 +47,16 @@ basicAuth checkCreds AuthSettings {..} app req sendResponse = do
4047 else authOnNoAuth authRealm req sendResponse
4148 where
4249 check =
43− case lookup "Authorization" $ requestHeaders req of
50+ case (lookup "Authorization" $ requestHeaders req)
51+ >>= extractBasicAuth of
4452 Nothing -> return False
45− Just bs ->
46− let (x, y) = S.break isSpace bs
47− in if S.map toLower x == "basic"
48− then checkB64 $ S.dropWhile isSpace y
49− else return False
50− checkB64 encoded =
51− case S.uncons password' of
52− Just (_, password) -> checkCreds username password
53− Nothing -> return False
54− where
55− raw = decodeLenient encoded
56− (username, password') = S.breakByte _colon raw
53+ Just (username, password) -> checkCreds username password
54+
5755
58−-- | Authentication settings. This value is an instance of @IsString@, so the
59−-- recommended approach to create a value is to provide a string literal (which
60−-- will be the realm) and then overriding individual fields.
56+-- | Basic authentication settings. This value is an instance of
57+-- @IsString@, so the recommended approach to create a value is to
58+-- provide a string literal (which will be the realm) and then
59+-- overriding individual fields.
6160--
6261-- > "My Realm" { authIsProtected = someFunc } :: AuthSettings
6362--
@@ -95,3 +94,26 @@ instance IsString AuthSettings where
9594 "Basic authentication is required"
9695 , authIsProtected = const $ return True
9796 }
97+
98+-- | Extract basic authentication data from usually __Authorization__
99+-- header value. Returns username and password
100+extractBasicAuth :: ByteString -> Maybe (ByteString, ByteString)
101+extractBasicAuth bs =
102+ let (x, y) = S.break isSpace bs
103+ in if S.map toLower x == "basic"
104+ then extract $ S.dropWhile isSpace y
105+ else Nothing
106+ where
107+ extract encoded =
108+ let raw = decodeLenient encoded
109+ (username, password') = S.breakByte _colon raw
110+ in ((username,) . snd) <$> S.uncons password'
111+
112+-- | Extract bearer authentication data from __Authorization__ header
113+-- value. Returns bearer token
114+extractBearerAuth :: ByteString -> Maybe ByteString
115+extractBearerAuth bs =
116+ let (x, y) = S.break isSpace bs
117+ in if S.map toLower x == "bearer"
118+ then Just $ S.dropWhile isSpace y
119+ else Nothing