{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | A Yesod middleware for -- <<http://tools.ietf.org/html/rfc1945#section-11.1 HTTP Basic -- Authentication>> -- -- -- Performs a single authentication lookup per request and uses the -- <<https://github.com/yesodweb/yesod/blob/master/yesod-core/Yesod/Core/TypeCache.hs#L21 -- Yesod request-local caching>> mechanisms to store valid auth -- credentials found in the Authorization header. -- -- -- The recommended way to use this module is to override the -- @maybeAuthId@ to @defaultMaybeBasicAuthId@ and supply a lookup -- function. -- -- @ -- instance YesodAuth App where -- type AuthId App = Text -- getAuthId = return . Just . credsIdent -- maybeAuthId = defaultMaybeBasicAuthId checkCreds defaultAuthSettings -- where -- checkCreds = \k s -> return $ (k == "user") -- && (s == "secret") -- @ -- -- -- WWW-Authenticate challenges are currently not implemented. The -- current workaround is to override the error handler: -- -- @ -- instance Yesod App where -- errorHandler NotAuthenticated = selectRep $ -- provideRep $ do -- addHeader "WWW-Authenticate" $ T.concat -- [ "RedirectJSON realm=\"Realm\", param=\"myurl.com\"" ] -- -- send error response here -- ... -- errorHandler e = defaultErrorHandler e -- ... -- @ -- -- -- Proper response status on failed authentication is not implemented. -- The current workaround is to override the 'Yesod' typeclass -- @isAuthorized@ function to handle required auth routes. e.g. -- -- @ -- instance Yesod App where -- isAuthorized SecureR _ = -- maybeAuthId >>= return . maybe AuthenticationRequired (const Authorized) -- isAuthorized _ _ = Authorized -- @ module Yesod.Auth.Http.Basic ( -- * Drop in replace for maybeAuthId. defaultMaybeBasicAuthId -- * The AuthSettings currently do nothing -- useful but are supplied to the defaultMaybeAUthId -- anyways. , AuthSettings , authRealm , defaultAuthSettings ) where import qualified Data.ByteString as BS import qualified Data.Text.Encoding as T import Data.ByteString (ByteString) import Data.ByteString.Base64 (decodeLenient) import Data.Text (Text) import Data.Typeable import Data.Word8 (isSpace, toLower, _colon) import Network.Wai import Prelude import Yesod hiding (Header) -- | Authentication Settings data AuthSettings = AuthSettings { authRealm :: Text } deriving (Eq, Show) -- | Ready-to-go 'AuthSettings' which can be used defaultAuthSettings :: AuthSettings defaultAuthSettings = AuthSettings { authRealm = "Realm" } -- | Cachable basic authentication credentials newtype CachedBasicAuthId a = CachedBasicAuthId { unCached :: Maybe a } deriving Typeable -- | A function to verify user credentials type CheckCreds = ByteString -> ByteString -> IO Bool -- | Retrieve the 'AuthId' using Authorization header. -- -- If valid credentials are found and authorized the auth id is -- cached. -- -- TODO use more general type than Text to represent the auth id defaultMaybeBasicAuthId :: MonadHandler m => CheckCreds -> AuthSettings -> m (Maybe Text) defaultMaybeBasicAuthId auth cfg = cachedAuth $ waiRequest >>= maybeBasicAuthId auth cfg -- | Cached Authentication credentials cachedAuth :: (MonadHandler m) => m (Maybe Text) -> m (Maybe Text) cachedAuth = fmap unCached . cached . fmap CachedBasicAuthId -- | Use the HTTP Basic _Authorization_ header to retrieve the AuthId -- of request -- -- This function uses yesod 'cachedAuth' to cache the result of the -- first succesful header lookup. -- -- Subsequent calls to 'maybeAuthId' do not require the 'CheckCreds' -- function to be run again. maybeBasicAuthId :: (MonadHandler m) => CheckCreds -> AuthSettings -> Request -> m (Maybe Text) maybeBasicAuthId checkCreds AuthSettings{..} req = case authorization of Just (strategy, userpass) | BS.map toLower strategy == "basic" -> authorizeCredentials $ BS.dropWhile isSpace userpass | otherwise -> return Nothing _ -> return Nothing where authorization = BS.break isSpace <$> lookup "Authorization" (requestHeaders req) authorizeCredentials encoded = let (username, password') = BS.break (== _colon) $ decodeLenient encoded in case BS.uncons password' of Nothing -> return Nothing Just (_,password) -> do authorized <- liftIO $ checkCreds username password return $ if authorized then Just $ T.decodeUtf8 username else Nothing