hspec-yesod 0.2.1.1 → 0.3.0.0

raw patch · 12 files changed

+379/−109 lines, 12 filesdep ~yesod-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: yesod-core

API changes (from Hackage documentation)

Files

• ChangeLog.md +30/−0
• hspec-yesod.cabal +11/−2
• src/Test/Hspec/Yesod.hs +153/−98
• src/Test/Hspec/Yesod/Internal.hs +9/−1
• test/NestedRouteDispatchSpec.hs +39/−0
• test/NestedRouteDispatchSpec/Foo/Handler.hs +24/−0
• test/NestedRouteDispatchSpec/Foo/HandlerSpec.hs +19/−0
• test/NestedRouteDispatchSpec/Foo/Route.hs +11/−0
• test/NestedRouteDispatchSpec/Resources.hs +28/−0
• test/NestedRouteDispatchSpec/YesodData.hs +16/−0
• test/NestedRouteDispatchSpec/YesodDispatch.hs +26/−0
• test/main.hs +13/−8

@@ -1,5 +1,35 @@ # ChangeLog for hspec-yesod +## 0.3.0.0++- [#7](https://github.com/parsonsmatt/hspec-yesod/pull/7)+    - Require `yesod-core >= 1.7.0.0`.+    - You can now test a subset of routes without depending on the full+      `YesodDispatch`, which can dramatically cut test compile times. `setUrl`+      and the new `setUrlNested` accept route fragments via `RequestBuilderFor`,+      which carries the route-fragment type.+    - **Breaking:** `RequestBuilderData` gained a `url` type parameter+      (`RequestBuilderData url site`); `getLatestRequest`/`requireLatestRequest`+      return `RequestBuilderData () site`.+    - **Breaking:** `get`, `post`, `postBody`, `performMethod`, and `request`+      now require `UrlToDispatch url site` (from `yesod-core`) instead of+      `RedirectUrl site url`.+    - **Breaking:** a request must now set a URL explicitly; previously an unset+      URL defaulted to `/`, now `request` fails with an error.+    - **Breaking:** removed `TestApp`, `mkTestApp`, and the+      `yedCreateApplication` field of `YesodExampleData`.+    - Added `getRunnerEnv`, which builds a `YesodRunnerEnv` for the current+      `yedSite` via `mkYesodRunnerEnv`. It is built fresh per request so it+      always reflects per-request foundation changes.+    - The `YesodDispatch site` constraint is no longer required by `yesodSpec`,+      `yesodSpecWithSiteGenerator`, `yesodSpecWithSiteGeneratorAndArgument`, or+      `siteToYesodExampleData`.+    - WAI middlewares are now applied in the request builder.+    - Add a `CallStack` to `requireLatestRequest`.+    - Assertion failures now use `withFrozenCallStack`, and the debug formatters+      decode request bytes leniently, so a failure message can no longer be+      masked by a `UnicodeException`.+ ## 0.2.1.1  - [#8](https://github.com/parsonsmatt/hspec-yesod/pull/8)

@@ -1,5 +1,5 @@ name:               hspec-yesod-version:            0.2.1.1+version:            0.3.0.0 license:            MIT license-file:       LICENSE author:             Nubis <nubis@woobiz.com.ar>, Matt Parsons <parsonsmatt@gmail.com>@@ -41,7 +41,7 @@                    , wai-extra                    , xml-conduit               >= 1.0                    , xml-types                 >= 0.3-                   , yesod-core                >= 1.6.17+                   , yesod-core                >= 1.7.0.0                    , yesod-test                       exposed-modules: Test.Hspec.Yesod, Test.Hspec.Yesod.Internal@@ -52,6 +52,15 @@     default-language: Haskell2010     type: exitcode-stdio-1.0     main-is: main.hs+    other-modules:+       NestedRouteDispatchSpec+       NestedRouteDispatchSpec.Resources+       NestedRouteDispatchSpec.Foo.Route+       NestedRouteDispatchSpec.Foo.Handler+       NestedRouteDispatchSpec.Foo.HandlerSpec+       NestedRouteDispatchSpec.YesodData+       NestedRouteDispatchSpec.YesodDispatch+     hs-source-dirs: test     build-depends:          base                           , yesod-test

@@ -123,9 +123,7 @@     , yesodSpecWithSiteGeneratorAndArgument     , YesodExample     , YesodExampleData(..)-    , TestApp (..)     , YSpec-    , mkTestApp     , ydescribe     , yit @@ -172,8 +170,10 @@     , addFile     , setRequestBody     , RequestBuilder+    , RequestBuilderFor     , SIO     , setUrl+    , setUrlNested     , clickOn      -- *** Adding fields by label@@ -222,6 +222,7 @@      -- * Grab information     , getTestYesod+    , getRunnerEnv     , getLatestRequest     , requireLatestRequest     , formatRequestBuilderDataForDebugging@@ -248,6 +249,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TErr+import GHC.Stack (withFrozenCallStack) import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Test.HUnit as HUnit import qualified Network.HTTP.Types as H@@ -262,6 +264,7 @@ import System.IO import Yesod.Core.Unsafe (runFakeHandler) import Yesod.Core+import Yesod.Core.Types (YesodRunnerEnv) import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With) import Text.XML.Cursor hiding (element)@@ -290,11 +293,10 @@ -- -- Since 1.2.4 data YesodExampleData site = YesodExampleData-    { yedCreateApplication :: !(site -> Middleware -> IO Application)-    , yedMiddleware :: !Middleware+    { yedMiddleware :: !Middleware     , yedSite :: !site     , yedCookies :: !Cookies-    , yedRequest :: !(Maybe (RequestBuilderData site))+    , yedRequest :: !(Maybe (RequestBuilderData () site))     , yedResponse :: !(Maybe SResponse)     , yedTestCleanup :: !(IO ())     }@@ -325,19 +327,35 @@ getTestYesod :: YesodExample site site getTestYesod = fmap yedSite MS.get +-- | Build a 'YesodRunnerEnv' for the current test's 'yedSite' via+-- 'mkYesodRunnerEnv'.+--+-- The environment is built fresh on each call so that it always reflects the+-- current site, including any per-request foundation changes that downstream+-- harnesses make by updating 'yedSite' directly. 'mkYesodRunnerEnv' spawns a+-- few @auto-update@ worker threads (for the logger date, session date, and+-- max-expires caches); when an environment is no longer referenced those+-- workers block and the RTS reaps them (@BlockedIndefinitelyOnMVar@). Their+-- lifecycle is a @yesod-core@ concern, not something this library tries to+-- pool around.+getRunnerEnv :: Yesod site => YesodExample site (YesodRunnerEnv site)+getRunnerEnv = do+    currentSite <- MS.gets yedSite+    liftIO $ mkYesodRunnerEnv currentSite+ -- | Get the most recently provided request value, if available. -- -- This is intended to allow assertions to add context on the request in their error messages. -- Currently the contents of RequestBuilderData are only accessible via Test.Hspec.Yesod.Internal and formatRequestBuilderDataForDebugging. -- -- @since 0.2.0-getLatestRequest :: YesodExample site (Maybe (RequestBuilderData site))+getLatestRequest :: YesodExample site (Maybe (RequestBuilderData () site)) getLatestRequest = fmap yedRequest MS.get  -- | Like 'getLatestRequest', but throws an error if no request has been made. -- -- @since 0.2.0-requireLatestRequest :: YesodExample site (RequestBuilderData site)+requireLatestRequest :: HasCallStack => YesodExample site (RequestBuilderData () site) requireLatestRequest = do   mRequest <- getLatestRequest   case mRequest of@@ -353,22 +371,30 @@ -- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments -- to send with your requests. Some of the functions that run on it use the current -- response to analyze the forms that the server is expecting to receive.-type RequestBuilder site = YT.SIO.SIO (RequestBuilderData site)+--+-- This type requires 'YesodDispatch' which may take a long time to+-- compile by depending on all the modules in your web application. To+-- reduce dependency load, see 'RequestBuilderFor'.+type RequestBuilder site = RequestBuilderFor (Route site) site +-- | A 'RequestBuilderFor' is a more general form of a 'RequestBuilder'+-- that allows you to target nested route fragments.+--+-- @since 0.3.0.0+type RequestBuilderFor url site = YT.SIO.SIO (RequestBuilderData url site)+ -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool' ydescribe :: String -> YesodSpec site -> YesodSpec site ydescribe = describe -yesodSpec :: YesodDispatch site-          => site+yesodSpec :: site           -> YesodSpec site           -> Spec yesodSpec site =     before $ do         pure YesodExampleData-            { yedCreateApplication = \finalSite middleware -> middleware <$> toWaiAppPlain finalSite-            , yedMiddleware = id+            { yedMiddleware = id             , yedSite = site             , yedCookies = M.empty             , yedRequest = Nothing@@ -379,8 +405,7 @@ -- | Same as yesodSpec, but instead of taking already built site it -- takes an action which produces site for each test. yesodSpecWithSiteGenerator-    :: YesodDispatch site-    => IO site+    :: IO site     -> YesodSpec site     -> Spec yesodSpecWithSiteGenerator getSiteAction =@@ -391,16 +416,14 @@ -- -- @since 1.6.4 yesodSpecWithSiteGeneratorAndArgument-    :: YesodDispatch site-    => (a -> IO site)+    :: (a -> IO site)     -> YesodSpec site     -> SpecWith a yesodSpecWithSiteGeneratorAndArgument getSiteAction =     beforeWith $ \a -> do         site <- getSiteAction a         pure YesodExampleData-            { yedCreateApplication = \finalSite middleware -> middleware <$> toWaiAppPlain finalSite-            , yedMiddleware = id+            { yedMiddleware = id             , yedSite = site             , yedCookies = M.empty             , yedRequest = Nothing@@ -656,7 +679,7 @@ statusIs number = do   latestRequest <- requireLatestRequest   withResponse $ \resp@(SResponse status _ _) -> do-    +     liftIO $ flip HUnit.assertBool (H.statusCode status == number) $ unlines       [ "Expected status: " <> show number       , "But status was: " <> (show $ H.statusCode status)@@ -677,7 +700,7 @@     in previewFinal  -getRequestBodyPreview :: RequestBuilderData site -> T.Text+getRequestBodyPreview :: RequestBuilderData url site -> T.Text getRequestBodyPreview RequestBuilderData{..} =     let mRequestContentType = lookup hContentType rbdHeaders         isRequestUTF8ContentType = maybe False YT.Internal.contentTypeHeaderIsUtf8 mRequestContentType@@ -692,7 +715,7 @@         getRequestTextPreview :: BSL8.ByteString -> T.Text         getRequestTextPreview body =           let characterLimit = 1024-              textBody = TL.toStrict $ decodeUtf8 body+              textBody = TL.toStrict $ decodeUtf8With TErr.lenientDecode body           in if T.length textBody < characterLimit                 then textBody                 else T.take characterLimit textBody <> "... (use `rbdPostData` from `yedRequest` to see complete request body)"@@ -942,7 +965,7 @@ -- > {-# LANGUAGE OverloadedStrings #-} -- > post $ do -- >   addPostParam "key" "value"-addPostParam :: T.Text -> T.Text -> RequestBuilder site ()+addPostParam :: T.Text -> T.Text -> RequestBuilderFor url site () addPostParam name value =   YT.SIO.modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }   where addPostData (BinaryPostData _) = error "Trying to add post param to binary content."@@ -956,7 +979,7 @@ -- > {-# LANGUAGE OverloadedStrings #-} -- > request $ do -- >   addGetParam "key" "value" -- Adds ?key=value to the URL-addGetParam :: T.Text -> T.Text -> RequestBuilder site ()+addGetParam :: T.Text -> T.Text -> RequestBuilderFor url site () addGetParam name value = YT.SIO.modifySIO $ \rbd -> rbd     { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)               : rbdGets rbd@@ -973,7 +996,7 @@ addFile :: T.Text -- ^ The parameter name for the file.         -> FilePath -- ^ The path to the file.         -> T.Text -- ^ The MIME type of the file, e.g. "image/png".-        -> RequestBuilder site ()+        -> RequestBuilderFor url site () addFile name path mimetype = do   contents <- liftIO $ BSL8.readFile path   YT.SIO.modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }@@ -983,7 +1006,7 @@  -- | -- This looks up the name of a field based on the contents of the label pointing to it.-genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text+genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilderFor url site T.Text genericNameFromLabel match label = do   mres <- fmap rbdResponse YT.SIO.getSIO   res <-@@ -1025,7 +1048,7 @@ byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)                  -> T.Text                     -- ^ The text contained in the @\<label>@.                  -> T.Text                     -- ^ The value to set the parameter to.-                 -> RequestBuilder site ()+                 -> RequestBuilderFor url site () byLabelWithMatch match label value = do   name <- genericNameFromLabel match label   addPostParam name value@@ -1059,7 +1082,7 @@ -- @since 1.5.9 byLabelExact :: T.Text -- ^ The text in the @\<label>@.              -> T.Text -- ^ The value to set the parameter to.-             -> RequestBuilder site ()+             -> RequestBuilderFor url site () byLabelExact = byLabelWithMatch (==)  -- |@@ -1070,7 +1093,7 @@ -- @since 1.6.2 byLabelContain :: T.Text -- ^ The text in the @\<label>@.                -> T.Text -- ^ The value to set the parameter to.-               -> RequestBuilder site ()+               -> RequestBuilderFor url site () byLabelContain = byLabelWithMatch T.isInfixOf  -- |@@ -1081,7 +1104,7 @@ -- @since 1.6.2 byLabelPrefix :: T.Text -- ^ The text in the @\<label>@.               -> T.Text -- ^ The value to set the parameter to.-              -> RequestBuilder site ()+              -> RequestBuilderFor url site () byLabelPrefix = byLabelWithMatch T.isPrefixOf  -- |@@ -1092,14 +1115,14 @@ -- @since 1.6.2 byLabelSuffix :: T.Text -- ^ The text in the @\<label>@.               -> T.Text -- ^ The value to set the parameter to.-              -> RequestBuilder site ()+              -> RequestBuilderFor url site () byLabelSuffix = byLabelWithMatch T.isSuffixOf  fileByLabelWithMatch  :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)                       -> T.Text                     -- ^ The text contained in the @\<label>@.                       -> FilePath                   -- ^ The path to the file.                       -> T.Text                     -- ^ The MIME type of the file, e.g. "image/png".-                      -> RequestBuilder site ()+                      -> RequestBuilderFor url site () fileByLabelWithMatch match label path mime = do   name <- genericNameFromLabel match label   addFile name path mime@@ -1131,7 +1154,7 @@ fileByLabelExact :: T.Text -- ^ The text contained in the @\<label>@.                  -> FilePath -- ^ The path to the file.                  -> T.Text -- ^ The MIME type of the file, e.g. "image/png".-                 -> RequestBuilder site ()+                 -> RequestBuilderFor url site () fileByLabelExact = fileByLabelWithMatch (==)  -- |@@ -1143,7 +1166,7 @@ fileByLabelContain :: T.Text -- ^ The text contained in the @\<label>@.                    -> FilePath -- ^ The path to the file.                    -> T.Text -- ^ The MIME type of the file, e.g. "image/png".-                   -> RequestBuilder site ()+                   -> RequestBuilderFor url site () fileByLabelContain = fileByLabelWithMatch T.isInfixOf  -- |@@ -1155,7 +1178,7 @@ fileByLabelPrefix :: T.Text -- ^ The text contained in the @\<label>@.                   -> FilePath -- ^ The path to the file.                   -> T.Text -- ^ The MIME type of the file, e.g. "image/png".-                  -> RequestBuilder site ()+                  -> RequestBuilderFor url site () fileByLabelPrefix = fileByLabelWithMatch T.isPrefixOf  -- |@@ -1167,7 +1190,7 @@ fileByLabelSuffix :: T.Text -- ^ The text contained in the @\<label>@.                   -> FilePath -- ^ The path to the file.                   -> T.Text -- ^ The MIME type of the file, e.g. "image/png".-                  -> RequestBuilder site ()+                  -> RequestBuilderFor url site () fileByLabelSuffix = fileByLabelWithMatch T.isSuffixOf  -- | Lookups the hidden input named "_token" and adds its value to the params.@@ -1177,12 +1200,15 @@ -- -- > request $ do -- >   addToken_ "#formID"-addToken_ :: HasCallStack => Query -> RequestBuilder site ()+addToken_ :: HasCallStack => Query -> RequestBuilderFor url site () addToken_ scope = do   matches <- htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $ scope <> " input[name=_token][type=hidden][value]"   case matches of     [] -> failure $ "No CSRF token found in the current page"-    element:[] -> addPostParam "_token" $ head $ attribute "value" $ parseHTML element+    element:[] ->+      case attribute "value" $ parseHTML element of+        value:_ -> addPostParam "_token" value+        [] -> failure "Found a CSRF token element, but it had no value attribute"     _ -> failure $ "More than one CSRF token found in the page"  -- | For responses that display a single form, just lookup the only CSRF token available.@@ -1191,7 +1217,7 @@ -- -- > request $ do -- >   addToken-addToken :: HasCallStack => RequestBuilder site ()+addToken :: HasCallStack => RequestBuilderFor url site () addToken = addToken_ ""  -- | Calls 'addTokenFromCookieNamedToHeaderNamed' with the 'defaultCsrfCookieName' and 'defaultCsrfHeaderName'.@@ -1204,7 +1230,7 @@ -- >   addTokenFromCookie -- -- Since 1.4.3.2-addTokenFromCookie :: HasCallStack => RequestBuilder site ()+addTokenFromCookie :: HasCallStack => RequestBuilderFor url site () addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName  -- | Looks up the CSRF token stored in the cookie with the given name and adds it to the request headers. An error is thrown if the cookie can't be found.@@ -1223,7 +1249,7 @@ addTokenFromCookieNamedToHeaderNamed :: HasCallStack                                      => ByteString -- ^ The name of the cookie                                      -> CI ByteString -- ^ The name of the header-                                     -> RequestBuilder site ()+                                     -> RequestBuilderFor url site () addTokenFromCookieNamedToHeaderNamed cookieName headerName = do   cookies <- getRequestCookies   case M.lookup cookieName cookies of@@ -1244,7 +1270,7 @@ -- >   liftIO $ putStrLn $ "Cookies are: " ++ show cookies -- -- Since 1.4.3.2-getRequestCookies :: HasCallStack => RequestBuilder site Cookies+getRequestCookies :: HasCallStack => RequestBuilderFor url site Cookies getRequestCookies = do   requestBuilderData <- YT.SIO.getSIO   headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of@@ -1259,7 +1285,7 @@ -- ==== __Examples__ -- -- > post HomeR-post :: (Yesod site, RedirectUrl site url)+post :: (Yesod site, UrlToDispatch url site)      => url      -> YesodExample site () post = performMethod "POST"@@ -1272,7 +1298,7 @@ -- -- > import Data.Aeson -- > postBody HomeR (encode $ object ["age" .= (1 :: Integer)])-postBody :: (Yesod site, RedirectUrl site url)+postBody :: (Yesod site, UrlToDispatch url site)          => url          -> BSL8.ByteString          -> YesodExample site ()@@ -1288,7 +1314,7 @@ -- > get HomeR -- -- > get ("http://google.com" :: Text)-get :: (Yesod site, RedirectUrl site url)+get :: (Yesod site, UrlToDispatch url site)     => url     -> YesodExample site () get = performMethod "GET"@@ -1301,7 +1327,7 @@ -- -- > performMethod "DELETE" HomeR performMethod-    :: (Yesod site, RedirectUrl site url)+    :: (Yesod site, UrlToDispatch url site)     => ByteString     -> url     -> YesodExample site ()@@ -1318,7 +1344,7 @@ -- > get HomeR -- > followRedirect followRedirect-    :: (Yesod site)+    :: (UrlToDispatch T.Text site, YesodDispatch site)     => YesodExample site (Either T.Text T.Text) -- ^ 'Left' with an error message if not a redirect, 'Right' with the redirected URL if it was followRedirect = do   mr <- getResponse@@ -1366,7 +1392,7 @@ -- > import Network.HTTP.Types.Method -- > request $ do -- >   setMethod methodPut-setMethod :: H.Method -> RequestBuilder site ()+setMethod :: H.Method -> RequestBuilderFor url site () setMethod m = YT.SIO.modifySIO $ \rbd -> rbd { rbdMethod = m }  -- | Sets the URL used by the request.@@ -1380,7 +1406,7 @@ -- >   setUrl ("http://google.com/" :: Text) setUrl :: (Yesod site, RedirectUrl site url)        => url-       -> RequestBuilder site ()+       -> RequestBuilderFor url site () setUrl url' = do     site <- fmap rbdSite YT.SIO.getSIO     eurl <- Yesod.Core.Unsafe.runFakeHandler@@ -1388,7 +1414,7 @@         (const $ error "Test.Hspec.Yesod: No logger available")         site         (toTextUrl url')-    url <- either (error . show) return eurl+    url <- either (\err -> failure $ "setUrl: failed to render the URL: " <> T.pack (show err)) return eurl     let (urlPath, urlQuery) = T.break (== '?') url     YT.SIO.modifySIO $ \rbd -> rbd         { rbdPath =@@ -1397,9 +1423,20 @@                 ("https:":_:rest) -> rest                 x -> x         , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery)+        , rbdUrl = Just url'         } +-- | Set the URL of the request, specialized to a nested route fragment.+--+-- @since 0.3.0.0+setUrlNested+    :: (RedirectUrl site (WithParentArgs url), Yesod site)+    => ParentArgs url+    -> url+    -> RequestBuilderFor (WithParentArgs url) site ()+setUrlNested parentArgs url = setUrl (WithParentArgs parentArgs url) + -- | Click on a link defined by a CSS query -- -- ==== __ Examples__@@ -1408,7 +1445,7 @@ -- > clickOn "a#idofthelink" -- -- @since 1.5.7-clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()+clickOn :: (HasCallStack, UrlToDispatch T.Text site, YesodDispatch site) => Query -> YesodExample site () clickOn query = do   withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->     case YT.CSS.findAttributeBySelector (simpleBody res) query "href" of@@ -1428,7 +1465,7 @@ -- > import Data.Aeson -- > request $ do -- >   setRequestBody $ encode $ object ["age" .= (1 :: Integer)]-setRequestBody :: BSL8.ByteString -> RequestBuilder site ()+setRequestBody :: BSL8.ByteString -> RequestBuilderFor url site () setRequestBody body = YT.SIO.modifySIO $ \rbd -> rbd { rbdPostData = BinaryPostData body }  -- | Adds the given header to the request; see "Network.HTTP.Types.Header" for creating 'Header's.@@ -1438,7 +1475,7 @@ -- > import Network.HTTP.Types.Header -- > request $ do -- >   addRequestHeader (hUserAgent, "Chrome/41.0.2228.0")-addRequestHeader :: H.Header -> RequestBuilder site ()+addRequestHeader :: H.Header -> RequestBuilderFor url site () addRequestHeader header = YT.SIO.modifySIO $ \rbd -> rbd     { rbdHeaders = header : rbdHeaders rbd     }@@ -1453,28 +1490,22 @@ -- @since 1.6.7 addBasicAuthHeader :: CI ByteString -- ^ Username                    -> CI ByteString -- ^ Password-                   -> RequestBuilder site ()+                   -> RequestBuilderFor url site () addBasicAuthHeader username password =   let credentials = convertToBase Base64 $ CI.original $ username <> ":" <> password   in addRequestHeader ("Authorization", "Basic " <> credentials) -yesodExampleDataToApplication :: YesodExampleData site -> IO Application-yesodExampleDataToApplication YesodExampleData {..} =-    yedCreateApplication yedSite yedMiddleware--mkApplication :: YesodExample site Application-mkApplication = do-    liftIO . yesodExampleDataToApplication =<< MS.get- -- | Provides a helpful summary of the request, meant to be used in assertion functions -- -- Currently formats as METHOD PATH?QUERY, e.g. GET /foo/bar?q=true -- The exact format is subject to change. -- -- @since 0.2.0-formatRequestBuilderDataForDebugging :: RequestBuilderData site -> T.Text+formatRequestBuilderDataForDebugging :: RequestBuilderData url site -> T.Text formatRequestBuilderDataForDebugging RequestBuilderData{..} =-    (TE.decodeUtf8 rbdMethod) <> " " <> getEncodedPath rbdPath <> (TE.decodeUtf8 $ H.renderQuery True rbdGets)+    lenient rbdMethod <> " " <> getEncodedPath rbdPath <> lenient (H.renderQuery True rbdGets)+  where+    lenient = TE.decodeUtf8With TErr.lenientDecode  getEncodedPath :: [T.Text] -> T.Text getEncodedPath pathSegments =@@ -1496,13 +1527,14 @@ -- >   setMethod "PUT" -- >   setUrl NameR request-    :: RequestBuilder site ()+    :: (UrlToDispatch url site, Yesod site, HasCallStack)+    => RequestBuilderFor url site ()     -> YesodExample site () request reqBuilder = do-    app <- mkApplication     site <- MS.gets yedSite     mRes <- MS.gets yedResponse     oldCookies <- MS.gets yedCookies+    middleware <- MS.gets yedMiddleware      rbd@RequestBuilderData {..} <- liftIO $ execSIO reqBuilder RequestBuilderData       { rbdPostData = MultipleItemsPostData []@@ -1512,29 +1544,33 @@       , rbdPath = []       , rbdGets = []       , rbdHeaders = []+      , rbdUrl = Nothing       }+     let path = getEncodedPath rbdPath +    yre <- getRunnerEnv+    appNoMiddleware <- mkApplicationFor yre rbd+    let app = middleware appNoMiddleware+     -- expire cookies and filter them for the current path. TODO: support max age     currentUtc <- liftIO getCurrentTime     let cookies = M.filter (checkCookieTime currentUtc) oldCookies         cookiesForPath = M.filter (checkCookiePath path) cookies -    let req = case rbdPostData of-          MultipleItemsPostData x ->-            if DL.any isFile x-            then (multipart x)-            else singlepart-          BinaryPostData _ -> singlepart-          where singlepart = makeSinglepart cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets-                multipart x = makeMultipart cookiesForPath x rbdMethod rbdHeaders path rbdGets-    -- let maker = case rbdPostData of-    --       MultipleItemsPostData x ->-    --         if DL.any isFile x-    --         then makeMultipart-    --         else makeSinglepart-    --       BinaryPostData _ -> makeSinglepart-    -- let req = maker cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets+    let req =+            case rbdPostData of+                MultipleItemsPostData x ->+                    if DL.any isFile x+                    then (multipart x)+                    else singlepart+                BinaryPostData _ -> singlepart+          where+            singlepart =+                makeSinglepart cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets+            multipart x =+                makeMultipart cookiesForPath x rbdMethod rbdHeaders path rbdGets+     response <- liftIO $ runSession (srequest req         { simpleRequest = (simpleRequest req)             { httpVersion = H.http11@@ -1542,7 +1578,11 @@         }) app     let newCookies = parseSetCookies $ simpleHeaders response         cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies-    modify $ \e -> e { yedCookies = cookies', yedRequest = Just rbd, yedResponse = Just response }+    modify $ \e -> e+        { yedCookies = cookies'+        , yedRequest = Just $ voidRequestBuilderUrl rbd+        , yedResponse = Just response+        }   where     isFile (ReqFilePart _ _ _ _) = True     isFile _ = False@@ -1633,37 +1673,52 @@       , queryString = urlQuery       } +-- | Build a WAI 'Application' for the route stored in the request builder,+-- dispatching against the given (cached) 'YesodRunnerEnv'.+--+-- The @url@ type determines the dispatch target: a full 'Route' dispatches+-- against the whole site, while a nested route fragment dispatches against+-- just that fragment (see 'setUrlNested'). A request with no URL set is an+-- error.+mkApplicationFor+    :: (MonadIO m, UrlToDispatch url site, HasCallStack)+    => YesodRunnerEnv site+    -> RequestBuilderData url site+    -> m Application+mkApplicationFor yre rbd =+    case rbdUrl rbd of+        Nothing -> liftIO $ do+            let msg = mconcat+                    [ "The test tried to make a request, but no URL was specified.\n"+                    , "Previously, the library would assume an empty URL to be the default / route.\n"+                    , "Now, you must explicitly set a route in a request."+                    ] +            failure msg+        Just url ->+            pure $ urlToDispatch url yre++ parseSetCookies :: [H.Header] -> [Cookie.SetCookie] parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ headers --- Yes, just a shortcut+-- Yes, just a shortcut. 'withFrozenCallStack' so the assertion is blamed on+-- the caller of 'failure' rather than on this line. failure :: (HasCallStack, MonadIO a) => T.Text -> a b-failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""--data TestApp site = TestApp-    { testAppSite :: site-    , testAppMiddleware :: Middleware-    }--mkTestApp :: site -> TestApp site-mkTestApp site = TestApp-    { testAppSite = site-    , testAppMiddleware = id-    }+failure reason = withFrozenCallStack $ do+    _ <- liftIO $ HUnit.assertFailure $ T.unpack reason+    error "Test.Hspec.Yesod.failure: assertFailure returned instead of throwing"  type YSpec site = SpecWith (YesodExampleData site)  -- | This creates a minimal 'YesodExampleData' for a given @site@. No -- middlewares are applied. siteToYesodExampleData-    :: (YesodDispatch site)-    => site+    :: site     -> YesodExampleData site siteToYesodExampleData site =     YesodExampleData-        { yedCreateApplication = \site' middleware -> middleware <$> toWaiAppPlain site'-        , yedMiddleware = id+        { yedMiddleware = id         , yedSite = site         , yedCookies = M.empty         , yedRequest = Nothing

@@ -5,6 +5,7 @@     ( RequestBuilderData(..)     , RBDPostData(..)     , RequestPart(..)+    , voidRequestBuilderUrl     ) where  import qualified Data.Text as T@@ -12,15 +13,22 @@ import qualified Network.HTTP.Types as H import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) -data RequestBuilderData site = RequestBuilderData+data RequestBuilderData url site = RequestBuilderData     { rbdPostData :: RBDPostData     , rbdResponse :: (Maybe SResponse)     , rbdMethod :: H.Method     , rbdSite :: site+    , rbdUrl :: Maybe url     , rbdPath :: [T.Text]     , rbdGets :: H.Query     , rbdHeaders :: H.RequestHeaders     }++voidRequestBuilderUrl :: RequestBuilderData url site -> RequestBuilderData () site+voidRequestBuilderUrl rbd =+    rbd+        { rbdUrl = () <$ rbdUrl rbd+        }  data RBDPostData = MultipleItemsPostData [RequestPart]                  | BinaryPostData BSL8.ByteString

@@ -0,0 +1,39 @@+-- | This module hierarchy has the example on how to split routes up.+--+-- First, "NestedRouteDispatchSpec.Resources" defines the @resources@ value+-- with 'parseRoutesNoCheck'. This gives us the @['ResourceTree' 'String']@+-- that we need in order to generate the rest of the route information. The+-- 'App' datatype is also defined there, along with the 'RouteOpts' that+-- we'll use for the rest of the code generation.+--+-- Second, "NestedRouteDispatchSpec.Foo.Route" imports the @resources@+-- above and calls @'mkYesodDataOpts' (mkRouteOpts (Just "FooR")) "App"+-- resources@. This generates the code for the nested route fragment+-- @FooR@.+--+-- Third, "NestedRouteDispatchSpec.Foo.Handler" imports the @resources@ and+-- the @FooR@ route datatype, and creates the 'YesodDispatchNested'+-- instance. The handlers for the datatype are defined here as well.+--+-- A developer could combine the prior two modules: defining both the route+-- datatype and the handlers for that datatype in the same location. This+-- would eliminate the need to have an orphan instance in the @Handler@+-- module. However, this would require you to know about the implementation+-- of the handlers in order to reference the route fragments, which is not+-- ideal from a module graph compilation perspective.+--+-- Fourth, in "NestedRouteDispatchSpec.YesodData", we define the+-- 'mkYesodDataOpts' for the entire 'App'. Then we can provide the+-- @instance Yesod App@, which is required for running tests. This also+-- gives us instances of 'ToParentRoute' since this is where the full+-- @'Route' App@ is fully defined. This module needs to import the 'FooR'+-- type, otherwise it will be regenerated and you'll get weird errors.+--+-- Finally, we have "NestedRouteDispatchSpec.Foo.HandlerSpec". This module+-- writes a test against the 'FooIndexR' route. This module depends on the+-- @instance Yesod App@ and the specific handlers, but it does not depend+-- on any other handlers in order for the test to work.+--+-- With this feature set, we can now write tests that only depend on the+-- handlers we actually need to call!+module NestedRouteDispatchSpec where

@@ -0,0 +1,24 @@+{-# language TemplateHaskell #-}+{-# language OverloadedStrings #-}+{-# language ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module NestedRouteDispatchSpec.Foo.Handler where++import NestedRouteDispatchSpec.Foo.Route+import NestedRouteDispatchSpec.Resources+import qualified Data.Text as Text+import Data.Text (Text)+import Yesod.Core++mkYesodDispatchOpts (nestDefaultOptsFor "FooR") "App" resources++getFooIndexR :: Int -> HandlerFor App Text+getFooIndexR i = pure $ "getFooIndexR: " <> Text.pack (show i)++getFooEditR :: Int -> HandlerFor App Text+getFooEditR i = pure $ "getFooEditR: " <> Text.pack (show i)++getFooShowR :: Int -> Int -> HandlerFor App Text+getFooShowR i j = pure $ "getFooShowR: " <> Text.pack (show (i, j))

@@ -0,0 +1,19 @@+module NestedRouteDispatchSpec.Foo.HandlerSpec where++import NestedRouteDispatchSpec.Foo.Handler () -- need YesodDispatchNested FooR instance+import NestedRouteDispatchSpec.Resources (App(..))+import NestedRouteDispatchSpec.Foo.Route (FooR(..))+import NestedRouteDispatchSpec.YesodData () -- need Yesod App instance+import Yesod.Core (WithParentArgs(..))+import Test.Hspec.Yesod (request, bodyEquals, siteToYesodExampleData, setUrl, setUrlNested)+import Test.Hspec (Spec, before, it)++spec :: Spec+spec = do+    before (pure (siteToYesodExampleData App)) $ do+        it "lets me dispatch a nested route fragment via setUrl" $ do+            request $ setUrl (WithParentArgs 1 FooIndexR)+            bodyEquals "getFooIndexR: 1"+        it "lets me dispatch a nested route fragment via setUrlNested" $ do+            request $ setUrlNested 1 FooIndexR+            bodyEquals "getFooIndexR: 1"

@@ -0,0 +1,11 @@+{-# language TemplateHaskell #-}+{-# language ViewPatterns #-}+{-# language TypeFamilies #-}+{-# language OverloadedStrings #-}++module NestedRouteDispatchSpec.Foo.Route where++import NestedRouteDispatchSpec.Resources+import Yesod.Core++mkYesodDataOpts (nestDefaultOptsFor "FooR") "App" resources

@@ -0,0 +1,28 @@+{-# language QuasiQuotes #-}++module NestedRouteDispatchSpec.Resources where++import Yesod.Core+import Yesod.Routes.TH.Types++data App = App++resources :: [ResourceTree String]+resources = [parseRoutesNoCheck|++/   HomeR GET++/foo/#Int   FooR:+    /       FooIndexR   GET+    /edit   FooEditR    GET+    /#Int   FooShowR    GET++|]++nestDefaultOptsFor :: String -> RouteOpts+nestDefaultOptsFor target =+    setFocusOnNestedRoute target nestDefaultOpts++nestDefaultOpts :: RouteOpts+nestDefaultOpts =+    setNestedRouteFallthrough True defaultOpts

@@ -0,0 +1,16 @@+{-# language TemplateHaskell #-}+{-# language ViewPatterns #-}+{-# language TypeFamilies #-}+{-# language OverloadedStrings #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module NestedRouteDispatchSpec.YesodData where++import NestedRouteDispatchSpec.Foo.Route (FooR(..))+import NestedRouteDispatchSpec.Resources+import Yesod.Core++mkYesodDataOpts nestDefaultOpts "App" resources++instance Yesod App

@@ -0,0 +1,26 @@+{-# language TemplateHaskell #-}+{-# language OverloadedStrings #-}+{-# language ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module is not imported by any spec on purpose. It builds the full+-- @YesodDispatch App@ instance (via 'mkYesodDispatchOpts' with+-- 'nestDefaultOpts'), and is kept in the test suite's @other-modules@ purely+-- to verify that the full application dispatch still compiles alongside the+-- nested route-fragment dispatch. Handler specs depend only on the cheap+-- @YesodDispatchNested FooR@ fragment; the real application still wants this+-- full @YesodDispatch@.+module NestedRouteDispatchSpec.YesodDispatch where++import NestedRouteDispatchSpec.Foo.Handler () -- needed for the yesod dispatch instance in scope+import NestedRouteDispatchSpec.Foo.Route (FooR(..))+import NestedRouteDispatchSpec.Resources+import NestedRouteDispatchSpec.YesodData+import Yesod.Core+import Data.Text (Text)++mkYesodDispatchOpts nestDefaultOpts "App" resources++getHomeR :: HandlerFor App Text+getHomeR = pure "HomeR"

@@ -1,5 +1,5 @@ -- Ignore warnings about using deprecated byLabel/fileByLabel functions-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+{-# OPTIONS_GHC -Wno-deprecations #-}  {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -47,6 +47,8 @@ import qualified Data.Text as T import Yesod.Test.Internal (contentTypeHeaderIsUtf8) +import qualified NestedRouteDispatchSpec.Foo.HandlerSpec+ parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery @@ -67,6 +69,7 @@  main :: IO () main = hspec $ do+    describe "NestedRouteDispatchSpec.Foo.HandlerSpec" NestedRouteDispatchSpec.Foo.HandlerSpec.spec     describe "CSS selector parsing" $ do         it "elements" $ parseQuery_ "strong" @?= [[DeepChildren [ByTagName "strong"]]]         it "child elements" $ parseQuery_ "strong > i" @?= [[DeepChildren [ByTagName "strong"], DirectChildren [ByTagName "i"]]]@@ -456,9 +459,11 @@             statusIs 201              loc <- getLocation-            liftIO $ assertBool "expected location to be available" $ isRight loc-            let (Right (ResourceR t)) = loc-            liftIO $ assertBool "expected location header to contain post param" $ t == "bar"+            case loc of+                Right (ResourceR t) ->+                    liftIO $ assertBool "expected location header to contain post param" $ t == "bar"+                other ->+                    liftIO $ assertFailure $ "expected a Right ResourceR location, got: " <> show other          yit "returns a Left when no redirect was returned" $ do             get HomeR@@ -497,11 +502,11 @@         yit "checks for valid content-type" $ do             get ("get-json-wrong-content-type" :: Text)             statusIs 200-            (requireJSONResponse :: YesodExample site [Integer]) `liftedShouldThrow` (\(e :: SomeException) -> True)+            (requireJSONResponse :: YesodExample site [Integer]) `liftedShouldThrow` (\(_ :: SomeException) -> True)         yit "checks for valid JSON parse" $ do             get ("get-json-response" :: Text)             statusIs 200-            (requireJSONResponse :: YesodExample site [Text]) `liftedShouldThrow` (\(e :: SomeException) -> True)+            (requireJSONResponse :: YesodExample site [Text]) `liftedShouldThrow` (\(_ :: SomeException) -> True)  instance RenderMessage LiteApp FormMessage where     renderMessage _ _ = defaultFormMessage@@ -649,8 +654,8 @@  getIntegerR :: Handler Text getIntegerR = do-    app <- getYesod-    pure $ T.pack $ show (routedAppInteger app)+    app' <- getYesod+    pure $ T.pack $ show (routedAppInteger app')   -- infix Copied from HSpec's version