diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-test +## 1.6.7 + +Add `addBasicAuthHeader` function [#1632](https://github.com/yesodweb/yesod/pull/1632) + ## 1.6.6.2 addPostParam will now URL-encode keys and values to prevent corruption diff --git a/Yesod/Test.hs b/Yesod/Test.hs --- a/Yesod/Test.hs +++ b/Yesod/Test.hs @@ -66,6 +66,7 @@ , getLocation , request , addRequestHeader + , addBasicAuthHeader , setMethod , addPostParam , addGetParam @@ -156,6 +157,7 @@ #endif import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Network.Wai import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) import Control.Monad.Trans.Reader (ReaderT (..)) @@ -189,6 +191,7 @@ import GHC.Exts (Constraint) type HasCallStack = (() :: Constraint) #endif +import Data.ByteArray.Encoding (convertToBase, Base(..)) {-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-} {-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-} @@ -1143,6 +1146,21 @@ addRequestHeader header = modifySIO $ \rbd -> rbd { rbdHeaders = header : rbdHeaders rbd } + +-- | Adds a header for to the request +-- +-- ==== __Examples__ +-- +-- > request $ do +-- > addBasicAuthHeader "Aladdin" "OpenSesame" +-- +-- @since 1.6.7 +addBasicAuthHeader :: CI ByteString -- ^ Username + -> CI ByteString -- ^ Password + -> RequestBuilder site () +addBasicAuthHeader username password = + let credentials = convertToBase Base64 $ CI.original $ username <> ":" <> password + in addRequestHeader ("Authorization", "Basic " <> credentials) -- | The general interface for performing requests. 'request' takes a 'RequestBuilder', -- constructs a request, and executes it. diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -38,7 +38,7 @@ import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD -import Network.HTTP.Types.Status (status301, status303, status422, unsupportedMediaType415) +import Network.HTTP.Types.Status (status301, status303, status403, status422, unsupportedMediaType415) import UnliftIO.Exception (tryAny, SomeException, try) import qualified Web.Cookie as Cookie import Data.Maybe (isNothing) @@ -206,7 +206,38 @@ bad <- tryAny (clickOn "a#nonexistentlink") assertEq "bad link" (isLeft bad) True + ydescribe "custom error message" $ do + yit "returns the message pass to areqMsg" $ do + get ("/form" :: Text) + statusIs 200 + request $ do + setMethod "POST" + setUrl ("/form" :: Text) + addToken + statusIs 200 + htmlAnyContain ".errors" "Missing Label" + yit "returns the message pass to mreqMsg" $ do + get ("/mform" :: Text) + statusIs 200 + + request $ do + setMethod "POST" + setUrl ("/mform" :: Text) + addToken + statusIs 200 + htmlAnyContain ".errors" "Missing MLabel" + yit "returns the message pass to wreqMsg" $ do + get ("/wform" :: Text) + statusIs 200 + + request $ do + setMethod "POST" + setUrl ("/wform" :: Text) + addToken + statusIs 200 + htmlAnyContain ".errors" "Missing WLabel" + ydescribe "utf8 paths" $ do yit "from path" $ do get ("/dynamic1/שלום" :: Text) @@ -413,6 +444,21 @@ loc <- getLocation liftIO $ assertBool "expected a Left when not a redirect" $ isLeft loc + describe "Basic Authentication" $ yesodSpec app $ do + yit "rejects no header" $ do + get ("checkBasicAuth" :: Text) + statusIs 403 + yit "rejects incorrect header" $ do + request $ do + setUrl ("checkBasicAuth" :: Text) + addBasicAuthHeader "Aladdin" "foo" + statusIs 403 + yit "accepts correct header" $ do + request $ do + setUrl ("checkBasicAuth" :: Text) + addBasicAuthHeader "Aladdin" "OpenSesame" + statusIs 200 + instance RenderMessage LiteApp FormMessage where renderMessage _ _ = defaultFormMessage @@ -439,14 +485,26 @@ ((mfoo, widget), _) <- runFormPost $ renderDivs $ (,) - Control.Applicative.<$> areq textField "Some Label" Nothing + Control.Applicative.<$> areqMsg textField "Some Label" ("Missing Label" :: SomeMessage LiteApp) Nothing <*> areq fileField "Some File" Nothing case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget + onStatic "mform" $ dispatchTo $ do + ((mfoo, widget), _) <- runFormPost $ renderDivs $ formToAForm $ do + (field1F, field1V) <- mreqMsg textField "Some MLabel" ("Missing MLabel" :: SomeMessage LiteApp) Nothing + (field2F, field2V) <- mreq fileField "Some MFile" Nothing + + return + ( (,) Control.Applicative.<$> field1F <*> field2F + , [field1V, field2V] + ) + case mfoo of + FormSuccess (foo, _) -> return $ toHtml foo + _ -> defaultLayout widget onStatic "wform" $ dispatchTo $ do ((mfoo, widget), _) <- runFormPost $ renderDivs $ wFormToAForm $ do - field1F <- wreq textField "Some WLabel" Nothing + field1F <- wreqMsg textField "Some WLabel" ("Missing WLabel" :: SomeMessage LiteApp) Nothing field2F <- wreq fileField "Some WFile" Nothing return $ (,) Control.Applicative.<$> field1F <*> field2F @@ -487,6 +545,14 @@ if actual == expected then return () else sendResponseStatus unsupportedMediaType415 () + onStatic "checkBasicAuth" $ dispatchTo $ do + headers <- requestHeaders <$> waiRequest + let authHeader = lookup "Authorization" headers + + -- Copied from the Wikipedia Aladdin:OpenSesame example + if authHeader == Just "Basic QWxhZGRpbjpPcGVuU2VzYW1l" + then return () + else sendResponseStatus status403 () cookieApp :: LiteApp cookieApp = liteApp $ do diff --git a/yesod-test.cabal b/yesod-test.cabal --- a/yesod-test.cabal +++ b/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.6.6.2 +version: 1.6.7 license: MIT license-file: LICENSE author: Nubis @@ -28,6 +28,7 @@ , html-conduit >= 0.1 , http-types >= 0.7 , network >= 2.2 + , memory , pretty-show >= 1.6 , semigroups , text