diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index d8973f29..202c7666 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -52,6 +52,9 @@ module Yesod.Core.Handler , lookupCookie , lookupFile , lookupHeader + -- **** Lookup authentication data + , lookupBasicAuth + , lookupBearerAuth -- **** Multi-lookup , lookupGetParams , lookupPostParams @@ -166,6 +169,8 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Network.HTTP.Types as H import qualified Network.Wai as W +import Network.Wai.Middleware.HttpAuth + ( extractBasicAuth, extractBearerAuth ) import Control.Monad.Trans.Class (lift) import qualified Data.Text as T @@ -972,6 +977,26 @@ lookupHeaders key = do req <- waiRequest return $ lookup' key $ W.requestHeaders req +-- | Lookup basic authentication data from __Authorization__ header of +-- request. Returns user name and password +lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text)) +lookupBasicAuth = fmap (>>= getBA) + (lookupHeader "Authorization") + where + getBA bs = (\(x, y) -> ( decodeUtf8With lenientDecode x + , decodeUtf8With lenientDecode y)) + <$> extractBasicAuth bs + +-- | Lookup bearer authentication datafrom __Authorization__ header of +-- request. Returns bearer token value +lookupBearerAuth :: (MonadHandler m) => m (Maybe Text) +lookupBearerAuth = fmap (>>= getBR) + (lookupHeader "Authorization") + where + getBR bs = decodeUtf8With lenientDecode + <$> extractBearerAuth bs + + -- | Lookup for GET parameters. lookupGetParams :: MonadHandler m => Text -> m [Text] lookupGetParams pn = do