yesod-test 1.6.6.2 → 1.6.7
raw patch · 4 files changed
+93/−4 lines, 4 filesdep +memory
Dependencies added: memory
Files
- ChangeLog.md +4/−0
- Yesod/Test.hs +18/−0
- test/main.hs +69/−3
- yesod-test.cabal +2/−1
ChangeLog.md view
@@ -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
Yesod/Test.hs view
@@ -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 <https://en.wikipedia.org/wiki/Basic_access_authentication HTTP Basic Authentication> 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.
test/main.hs view
@@ -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
yesod-test.cabal view
@@ -1,5 +1,5 @@ name: yesod-test-version: 1.6.6.2+version: 1.6.7 license: MIT license-file: LICENSE author: Nubis <nubis@woobiz.com.ar>@@ -28,6 +28,7 @@ , html-conduit >= 0.1 , http-types >= 0.7 , network >= 2.2+ , memory , pretty-show >= 1.6 , semigroups , text