diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,30 @@ +# Changelog + +## 0.2.0.0 + +### Breaking changes + +- Require GHC 8.10 / base 4.14 or newer. +- Decode credentials with strict RFC 4648 Base64 validation. Quoted tokens, + embedded whitespace, invalid characters, missing required padding, excess + padding, and trailing junk are rejected rather than silently repaired. +- Require ASCII spaces after the case-insensitive `Basic` scheme. Tabs and + nonbreaking spaces are no longer accepted as separators. + +Clients should use their HTTP library's Basic Auth option, or send an unquoted +Base64 token. Decoded usernames and passwords are still passed to the checker +unchanged; credentials are not trimmed. + +### Fixes and maintenance + +- Return `Nothing` for invalid UTF-8 usernames instead of throwing, even if the + credential checker accepts those bytes. Passwords remain opaque bytes. +- Use a `newtype` for `AuthSettings`; its realm field remains reserved. +- Replace placeholder tests with authentication, UTF-8, and request-cache tests. +- Replace Travis with cached, pedantic GitHub Actions builds for LTS 18.28, + LTS 22.38, and LTS 24.65. +- Simplify README/Haddock usage and Basic challenge examples, remove unused + dependencies, and show the callback type directly in the public signature. + +Route authorization and HTTP challenges remain application-managed. Successful +and failed authentication results remain cached only within each request. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,66 @@ +# Yesod HTTP Basic Authentication + +[![Hackage](https://img.shields.io/hackage/v/yesod-auth-basic.svg)](https://hackage.haskell.org/package/yesod-auth-basic) + +HTTP Basic Auth for Yesod applications. Use HTTPS. + +## Usage + +Import `Yesod.Auth.Http.Basic`, then add this override to your existing +`YesodAuth` instance, where `AuthId App = Text`: + +```haskell +maybeAuthId = defaultMaybeBasicAuthId checkCredentials defaultAuthSettings +``` + +Supply your application's credential checker. For example: + +```haskell +checkCredentials :: ByteString -> ByteString -> IO Bool +checkCredentials username password = + pure (username == "user" && password == "secret") -- Example only. +``` + +The checker receives decoded bytes unchanged. Usernames must be valid UTF-8 +because the authenticated ID is `Text`; password encoding is up to the checker. +Successful and failed results are cached **only within the current request**. + +## Protect routes and send a challenge + +The helper does not enforce access or send HTTP challenges. Configure these in +your application's `Yesod` instance (using your own route names): + +```haskell +instance Yesod App where + authRoute _ = Nothing -- Return 401 instead of redirecting to a login page. + + isAuthorized ProtectedR _ = do + user <- maybeAuthId + pure $ maybe AuthenticationRequired (const Authorized) user + isAuthorized _ _ = pure Authorized + + errorHandler NotAuthenticated = do + addHeader "WWW-Authenticate" "Basic realm=\"API\", charset=\"UTF-8\"" + defaultErrorHandler NotAuthenticated + errorHandler err = defaultErrorHandler err +``` + +Missing or invalid credentials on `ProtectedR` produce a 401 response. +`authRealm` is currently reserved; set the challenge's realm in your handler. + +## Requests + +Let your HTTP client construct the header: + +```sh +curl --user 'user:secret' https://example.com/protected +``` + +```text +Authorization: Basic +``` + +`Basic` is case-insensitive and followed by ASCII spaces. Use standard Base64 +with required padding, without quotes or embedded whitespace. Malformed headers +are rejected, not repaired. Decoded credentials are not trimmed; colons after +the first delimiter remain part of the password. diff --git a/Yesod/Auth/Http/Basic.hs b/Yesod/Auth/Http/Basic.hs --- a/Yesod/Auth/Http/Basic.hs +++ b/Yesod/Auth/Http/Basic.hs @@ -1,68 +1,53 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} --- | A Yesod middleware for --- <> --- --- --- Performs a single authentication lookup per request and uses the --- <> mechanisms to store valid auth --- credentials found in the Authorization header. --- +-- | HTTP Basic authentication for Yesod. Use HTTPS. -- --- The recommended way to use this module is to override the --- @maybeAuthId@ to @defaultMaybeBasicAuthId@ and supply a lookup --- function. +-- Import this module and set @maybeAuthId@ in your existing @YesodAuth@ +-- instance, where @AuthId App = Text@: -- -- @ --- 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") +-- maybeAuthId = defaultMaybeBasicAuthId checkCredentials defaultAuthSettings -- @ -- --- --- WWW-Authenticate challenges are currently not implemented. The --- current workaround is to override the error handler: +-- Supply an application-specific credential checker: -- -- @ --- 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 --- ... +-- checkCredentials :: ByteString -> ByteString -> IO Bool +-- checkCredentials username password = +-- pure (username == "user" && password == "secret") -- Example only. -- @ -- +-- The checker receives decoded bytes unchanged. Usernames must be UTF-8; +-- password encoding is up to the checker. Both successful and failed results +-- are cached for the current request, never across HTTP requests. -- --- 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. +-- Route authorization and HTTP challenges belong to your application: -- -- @ -- instance Yesod App where --- isAuthorized SecureR _ = --- maybeAuthId >>= return . maybe AuthenticationRequired (const Authorized) --- isAuthorized _ _ = Authorized +-- authRoute _ = Nothing -- Return 401 instead of redirecting to a login page. +-- +-- isAuthorized ProtectedR _ = do +-- user <- maybeAuthId +-- pure $ maybe AuthenticationRequired (const Authorized) user +-- isAuthorized _ _ = pure Authorized +-- +-- errorHandler NotAuthenticated = do +-- addHeader "WWW-Authenticate" "Basic realm=\"API\", charset=\"UTF-8\"" +-- defaultErrorHandler NotAuthenticated +-- errorHandler err = defaultErrorHandler err -- @ +-- +-- This produces a 401 response for missing or invalid credentials on +-- @ProtectedR@. See . module Yesod.Auth.Http.Basic ( - -- * Drop in replace for maybeAuthId. + -- * Authentication defaultMaybeBasicAuthId - -- * The AuthSettings currently do nothing - -- useful but are supplied to the defaultMaybeAUthId - -- anyways. + -- * Settings , AuthSettings , authRealm , defaultAuthSettings @@ -72,51 +57,55 @@ import qualified Data.Text.Encoding as T import Data.ByteString (ByteString) -import Data.ByteString.Base64 (decodeLenient) +import Data.ByteString.Base64 (decode) import Data.Text (Text) import Data.Typeable -import Data.Word8 (isSpace, toLower, _colon) +import Data.Word8 (toLower, _colon, _space) import Network.Wai import Prelude import Yesod hiding (Header) --- | Authentication Settings -data AuthSettings = AuthSettings { +-- | Reserved authentication settings. HTTP challenges are application-managed. +newtype AuthSettings = AuthSettings { authRealm :: Text + -- ^ Reserved realm value; does not generate a @WWW-Authenticate@ header. } deriving (Eq, Show) --- | Ready-to-go 'AuthSettings' which can be used +-- | Default reserved settings, with @authRealm = "Realm"@. defaultAuthSettings :: AuthSettings defaultAuthSettings = AuthSettings { authRealm = "Realm" } --- | Cachable basic authentication credentials +-- | A request-local authentication result, including failed authentication. newtype CachedBasicAuthId a = CachedBasicAuthId { unCached :: Maybe a } deriving Typeable --- | A function to verify user credentials +-- | Application-supplied checker for decoded username and password bytes. type CheckCreds = ByteString -> ByteString -> IO Bool --- | Retrieve the 'AuthId' using Authorization header. +-- | Look up HTTP Basic credentials and return the verified UTF-8 username. -- --- If valid credentials are found and authorized the auth id is --- cached. +-- Use as @maybeAuthId@ in a @YesodAuth@ instance with @AuthId@ equal to 'Text'. +-- Missing or malformed headers, invalid UTF-8 usernames, and rejected +-- credentials return 'Nothing'. The checker receives the decoded bytes +-- without trimming; passwords may contain colons. -- --- TODO use more general type than Text to represent the auth id +-- Both successful and failed results are cached within the current request. +-- This function does not enforce route access or generate a challenge. defaultMaybeBasicAuthId :: MonadHandler m - => CheckCreds + => (ByteString -> ByteString -> IO Bool) -> AuthSettings -> m (Maybe Text) defaultMaybeBasicAuthId auth cfg = cachedAuth $ waiRequest >>= maybeBasicAuthId auth cfg --- | Cached Authentication credentials +-- | Cache the authentication result for the current request. cachedAuth :: (MonadHandler m) => m (Maybe Text) @@ -124,36 +113,38 @@ cachedAuth = fmap unCached . cached . fmap CachedBasicAuthId --- | Use the HTTP Basic _Authorization_ header to retrieve the AuthId --- of request +-- | Decode and check HTTP Basic credentials for one request. -- --- This function uses yesod 'cachedAuth' to cache the result of the --- first succesful header lookup. +-- The scheme is case-insensitive and followed by one or more ASCII spaces. +-- Credentials must be strictly Base64-encoded (RFC 4648); malformed input is +-- rejected before invoking the credential checker, not silently repaired. -- --- Subsequent calls to 'maybeAuthId' do not require the 'CheckCreds' --- function to be run again. +-- Request-local caching is provided by 'defaultMaybeBasicAuthId'. maybeBasicAuthId :: (MonadHandler m) => CheckCreds -> AuthSettings -> Request -> m (Maybe Text) -maybeBasicAuthId checkCreds AuthSettings{..} req = +maybeBasicAuthId checkCreds _ req = case authorization of Just (strategy, userpass) | BS.map toLower strategy == "basic" -> - authorizeCredentials $ BS.dropWhile isSpace userpass + authorizeCredentials $ BS.dropWhile (== _space) userpass | otherwise -> return Nothing _ -> return Nothing where - authorization = BS.break isSpace + authorization = BS.break (== _space) <$> 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 + case decode encoded of + Left _ -> return Nothing + Right decoded -> + let (username, password') = BS.break (== _colon) decoded + in case BS.uncons password' of + Nothing -> return Nothing + Just (_,password) -> do + authorized <- liftIO $ checkCreds username password + return $ if authorized + then either (const Nothing) Just $ T.decodeUtf8' username + else Nothing diff --git a/test/YesodAuthHttpBasicSpec.hs b/test/YesodAuthHttpBasicSpec.hs --- a/test/YesodAuthHttpBasicSpec.hs +++ b/test/YesodAuthHttpBasicSpec.hs @@ -5,37 +5,126 @@ module YesodAuthHttpBasicSpec where -import Data.Monoid ((<>)) +import Control.Monad (forM_) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import Data.IORef +import qualified Data.Text.Encoding as T import Test.Hspec import Yesod hiding (get) +import Yesod.Auth.Http.Basic import Yesod.Test --- TODO create real tests - spec :: SpecWith () -spec = describe "Yesod HTTP Basic Authentication" $ - yesodSpec app $ - ydescribe "Yesod HTTP Basic Authentication" $ - ydescribe "tests1" $ do - yit "Has Basic Auth" $ do - -- addRequestHeader (hUserAgent, "Chrome/41.0.2228.0") - get $ LiteAppRoute [] - statusIs 200 - yit "Denies Failed Basic Auth" $ do - get $ LiteAppRoute [] - statusIs 200 - -- statusIs 403 +spec = describe "Yesod HTTP Basic Authentication" $ do + calls <- runIO $ newIORef 0 + yesodSpec (app calls) $ do + forM_ validHeaders $ \(label, header, username) -> + yit label $ do + liftIO $ writeIORef calls 0 + requestWith $ Just header + statusIs 200 + bodyEquals username + -- The handler asks twice, but the checker runs only once per request. + liftIO $ readIORef calls `shouldReturn` 1 + forM_ malformedHeaders $ \(label, header) -> + yit ("rejects " <> label <> " before checking credentials") $ do + liftIO $ writeIORef calls 0 + requestWith $ Just header + statusIs 401 + liftIO $ readIORef calls `shouldReturn` 0 + yit "rejects missing Authorization without checking credentials" $ do + liftIO $ writeIORef calls 0 + requestWith Nothing + statusIs 401 + liftIO $ readIORef calls `shouldReturn` 0 + + yit "caches a failed credential check within the request" $ do + liftIO $ writeIORef calls 0 + requestWith $ Just $ basic "user:wrong" + statusIs 401 + liftIO $ readIORef calls `shouldReturn` 1 + + yit "rejects an invalid UTF-8 username even when the checker accepts its bytes" $ do + liftIO $ writeIORef calls 0 + requestWith $ Just $ basic $ BS.singleton 255 <> ":secret" + statusIs 401 + liftIO $ readIORef calls `shouldReturn` 1 + + yit "does not reuse authentication between HTTP requests" $ do + liftIO $ writeIORef calls 0 + requestWith $ Just $ basic "user:secret" + statusIs 200 + requestWith $ Just $ basic "user:secret" + statusIs 200 + liftIO $ readIORef calls `shouldReturn` 2 + +validHeaders :: [(String, ByteString, String)] +validHeaders = + [ ("accepts standard Basic Auth", basic "user:secret", "user") + , ("accepts a case-insensitive scheme", "bAsIc " <> payload, "user") + , ("accepts multiple ASCII separator spaces", "Basic " <> payload, "user") + , ("preserves colons in the password and accepts Base64 needing no padding", basic "user:se:cret", "user") + , ("preserves whitespace inside decoded credentials", basic " user : secret ", " user ") + , ("allows the checker to accept an empty password", basic "user:", "user") + , ("accepts a UTF-8 username", basic (utf8Username <> ":secret"), "josé") + ] + +malformedHeaders :: [(String, ByteString)] +malformedHeaders = + [ ("double-quoted tokens", "Basic \"" <> payload <> "\"") + , ("single-quoted tokens", "Basic '" <> payload <> "'") + , ("punctuation inside Base64", "Basic " <> BS.take 4 payload <> "!" <> BS.drop 4 payload) + , ("whitespace inside Base64", "Basic " <> BS.take 4 payload <> " " <> BS.drop 4 payload) + , ("a tab separator", "Basic\t" <> payload) + , ("a tab after a separator space", "Basic \t" <> payload) + , ("a nonbreaking-space separator", "Basic\160" <> payload) + , ("missing required padding", "Basic " <> BS.takeWhile (/= 61) payload) + , ("excess padding", "Basic " <> payload <> "=") + , ("trailing junk after padding", "Basic " <> payload <> "ignored") + , ("a trailing quote after padding", "Basic " <> payload <> "\"") + , ("an impossible Base64 length", basic "user:se:cret" <> "A") + , ("credentials without a colon", basic "user") + , ("an unsupported scheme", "Bearer " <> payload) + , ("a missing separator", "Basic" <> payload) + , ("an empty payload", "Basic ") + ] + +payload :: ByteString +payload = Base64.encode "user:secret" + +basic :: ByteString -> ByteString +basic credentials = "Basic " <> Base64.encode credentials + +utf8Username :: ByteString +utf8Username = T.encodeUtf8 "josé" + +requestWith :: Maybe ByteString -> YesodExample LiteApp () +requestWith header = request $ do + setMethod "GET" + setUrl $ LiteAppRoute [] + forM_ header $ \value -> addRequestHeader ("Authorization", value) + + instance RenderMessage LiteApp FormMessage where renderMessage _ _ = defaultFormMessage -app :: LiteApp -app = liteApp $ +app :: IORef Int -> LiteApp +app calls = liteApp $ dispatchTo $ do - mfoo <- lookupGetParam "foo" - case mfoo of - Nothing -> return "Hello world!" - Just foo -> return $ "foo=" <> foo + first <- defaultMaybeBasicAuthId checkCreds defaultAuthSettings + second <- defaultMaybeBasicAuthId checkCreds defaultAuthSettings + case (first, second) of + (Just username, Just cachedUsername) | username == cachedUsername -> return username + _ -> notAuthenticated + where + checkCreds username password = do + modifyIORef calls (+ 1) + return $ (username, password) `elem` + [ ("user", "secret"), ("user", "se:cret"), (" user ", " secret "), ("user", "") + , (utf8Username, "secret"), (BS.singleton 255, "secret") ] diff --git a/yesod-auth-basic.cabal b/yesod-auth-basic.cabal --- a/yesod-auth-basic.cabal +++ b/yesod-auth-basic.cabal @@ -1,47 +1,41 @@ name: yesod-auth-basic -version: 0.1.0.3 +version: 0.2.0.0 license: BSD3 license-file: LICENSE +extra-doc-files: README.md, CHANGELOG.md author: Christopher Reichert maintainer: creichert07@gmail.com copyright: (c) 2015, Christopher Reichert category: Web build-type: Simple -cabal-version: >=1.10 -synopsis: Yesod Middleware for HTTP Basic Authentication +cabal-version: 2.0 +synopsis: HTTP Basic authentication for Yesod description: - An efficient Yesod middleware middleware for HTTP Basic - Authentication. + HTTP Basic authentication with an application-supplied credential checker + and request-local caching of successful and failed authentication results. . - Utilizes Yesod request-local caching mechanisms to store valid auth - credentials found in the Authorization header. + See the documentation for Yesod.Auth.Http.Basic for usage examples. + Route authorization and HTTP challenges are handled by the application. source-repository head type: git - location: git://github.com/creichert/yesod-auth-basic.git + location: https://github.com/creichert/yesod-auth-basic.git library exposed-modules: Yesod.Auth.Http.Basic ghc-options: -Wall default-language: Haskell2010 - build-depends: base == 4.* + build-depends: base >= 4.14 && < 5 , base64-bytestring , bytestring - , exceptions , text , yesod , wai , word8 - , monad-control - if impl(ghc < 7.6) - build-depends: - iproute < 1.4 - - test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs @@ -49,7 +43,10 @@ other-modules: YesodAuthHttpBasicSpec ghc-options: -Wall -threaded default-language: Haskell2010 - build-depends: base == 4.* + build-tool-depends: hspec-discover:hspec-discover + build-depends: base >= 4.14 && < 5 + , base64-bytestring + , bytestring , yesod , yesod-auth-basic , yesod-test