sydtest-yesod (empty) → 0.0.0.0
raw patch · 12 files changed
+1352/−0 lines, 12 filesdep +QuickCheckdep +basedep +blaze-builder
Dependencies added: QuickCheck, base, blaze-builder, bytestring, case-insensitive, conduit, containers, cookie, exceptions, http-client, http-types, monad-logger, mtl, persistent, persistent-sqlite, persistent-template, pretty-show, resourcet, sydtest, sydtest-persistent-sqlite, sydtest-wai, sydtest-yesod, text, time, wai, xml-conduit, yesod, yesod-core, yesod-form, yesod-test
Files
- LICENSE.md +5/−0
- blog-example/Example/Blog.hs +124/−0
- blog-example/Example/BlogSpec.hs +109/−0
- blog-example/Spec.hs +1/−0
- src/Test/Syd/Yesod.hs +84/−0
- src/Test/Syd/Yesod/Client.hs +125/−0
- src/Test/Syd/Yesod/Def.hs +182/−0
- src/Test/Syd/Yesod/Request.hs +416/−0
- sydtest-yesod.cabal +109/−0
- test/Spec.hs +1/−0
- test/Test/Syd/Yesod/App.hs +113/−0
- test/Test/Syd/YesodSpec.hs +83/−0
+ LICENSE.md view
@@ -0,0 +1,5 @@+# Sydtest License++Copyright (c) 2020-2021 Tom Sydney Kerckhove++See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text.
+ blog-example/Example/Blog.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- This is an example of a yesod application that uses a database.+-- It is supposed to represent a blog with blog posts.+-- However, we call the blog posts thought so that it's not too confusing with 'POST' also being the HTTP method.+module Example.Blog where++import Control.Monad.Logger+import Data.Text (Text)+import Database.Persist.Sql+import Database.Persist.Sqlite+import Database.Persist.TH+import Yesod++share+ [mkPersist sqlSettings, mkMigrate "migrateThoughts"]+ [persistLowerCase|+Thought+ title Text+ contents Text+ deriving Show Eq+|]++data App = App+ { appConnectionPool :: ConnectionPool+ }++mkYesod+ "App"+ [parseRoutes|+ / HomeR GET+ /new-thought NewThoughtR GET POST+ /thought/#ThoughtId ThoughtR GET+|]++type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)++instance Yesod App++instance YesodPersist App where+ type YesodPersistBackend App = SqlBackend+ runDB func = do+ pool <- getsYesod appConnectionPool+ runSqlPool func pool++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++getHomeR :: Handler Html+getHomeR = defaultLayout "Welcome!, feel free to post some thoughts at /new-thought."++data NewThought = NewThought+ { newThoughtTitle :: Text,+ newThoughtContents :: Text+ }++newThoughtForm :: Form NewThought+newThoughtForm =+ renderDivs $+ NewThought+ <$> areq textField ("Title" {fsName = Just "title"}) Nothing+ <*> (unTextarea <$> areq textareaField ("Contents" {fsName = Just "contents"}) Nothing)++getNewThoughtR :: Handler Html+getNewThoughtR = do+ ((res, form), enctype) <- runFormPost newThoughtForm+ case res of+ FormSuccess f -> do+ thoughtId <-+ runDB $+ insert $+ Thought+ { thoughtTitle = newThoughtTitle f,+ thoughtContents = newThoughtContents f+ }+ defaultLayout+ [whamlet|+ <p>You've posted a thought!+ <p>the title was #{newThoughtTitle f}+ <p>the contents were #{newThoughtContents f}+ <a href=@{ThoughtR thoughtId}>+ Look at your thought+ |]+ FormMissing ->+ defaultLayout+ [whamlet|+ <p>Hello world!+ <form enctype="#{enctype}" method="post">+ ^{form}+ <input type="submit">+ Submit thought+ |]+ FormFailure errs -> invalidArgs errs++postNewThoughtR :: Handler Html+postNewThoughtR = getNewThoughtR++getThoughtR :: ThoughtId -> Handler Html+getThoughtR thoughtId = do+ thought <- runDB $ get404 thoughtId+ defaultLayout+ [whamlet|+ <h1> #{thoughtTitle thought}+ <p>+ #{thoughtContents thought}+ |]++main :: IO ()+main = runStderrLoggingT $+ withSqlitePool "example.sqlite3" 1 $ \pool -> do+ runSqlPool (runMigration migrateThoughts) pool+ liftIO $ Yesod.warp 3000 $ App {appConnectionPool = pool}
+ blog-example/Example/BlogSpec.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}++module Example.BlogSpec (spec) where++import Control.Monad.Reader+import qualified Data.Text as T+import Database.Persist (selectList)+import Database.Persist.Sql (Entity (..), SqlPersistT)+import Example.Blog+import Network.HTTP.Client as HTTP+import Test.QuickCheck+import Test.Syd+import Test.Syd.Persistent.Sqlite+import Test.Syd.Yesod++-- | A 'SetupFunc' to provide the App and clean up around it.+--+-- The 'HTTP.Manager' here is the one that is used for doing the test requests.+-- It is setup only once and it is shared accross tests for performance reasons.+-- If you also need an 'HTTP.Manager' in your 'App', then you can use it in your 'SetupFunc' here+-- but in this case we don't need it.+appSetupFunc :: HTTP.Manager -> SetupFunc () App+appSetupFunc _ = do+ pool <- connectionPoolSetupFunc migrateThoughts+ pure $ App {appConnectionPool = pool}++testDB :: SqlPersistT IO a -> YesodClientM App a+testDB func = do+ pool <- asks $ appConnectionPool . yesodClientSite+ liftIO $ runSqlPool func pool++spec :: Spec+spec = yesodSpecWithSiteSetupFunc appSetupFunc $ do+ -- A simple read-only test: We can request the home page succesfully.+ yit "can GET the home page" $ do+ get HomeR+ statusIs 200++ -- A simple test that shows a post request, and shows that empty forms will not be accepted.+ yit "cannot post if the form data is missing" $ do+ get NewThoughtR+ statusIs 200+ request $ do+ setMethod "POST"+ setUrl NewThoughtR+ addToken -- For the CSRF protection+ statusIs 400++ -- A simple form POST request test.+ -- Each part of the form needs to be added using 'addPostParam'+ -- Don't forget the 'addToken' piece to make sure you don't run into CSRF errors.+ yit "can post this example blogpost" $ do+ get NewThoughtR+ statusIs 200+ request $ do+ setMethod "POST"+ setUrl NewThoughtR+ addToken+ addPostParam "title" "example title"+ addPostParam "contents" "example contents"+ statusIs 200++ -- A property test that does the same as the simple POST request test above,+ -- Note that ut for _any_ title and contents instead of specific above.+ -- Note that we need to use nonempty title and contents so they don't look missing to the server.+ it "can post any blogpost" $ \yc ->+ forAll (arbitrary `suchThat` (not . null)) $ \title ->+ forAll (arbitrary `suchThat` (not . null)) $ \contents ->+ runYesodClientM yc $ do+ get NewThoughtR+ statusIs 200+ request $ do+ setMethod "POST"+ setUrl NewThoughtR+ addToken+ addPostParam "title" (T.pack title)+ addPostParam "contents" (T.pack contents)+ statusIs 200++ -- A proprety test that does the above, but also goes and finds the thought that was posted,+ -- both on the page and in the database.+ -- We generate alphanumeric titles and contents just so that we don't have to depend on `genvalidity` here and figure out encodings correctly.+ it "can post any blogpost and then look it up" $ \yc ->+ forAll (listOf (choose ('a', 'z')) `suchThat` (not . null)) $ \title ->+ forAll (listOf (choose ('a', 'z')) `suchThat` (not . null)) $ \contents ->+ runYesodClientM yc $ do+ let titleText = T.pack title+ let contentsText = T.pack contents+ get NewThoughtR+ statusIs 200+ request $ do+ setMethod "POST"+ setUrl NewThoughtR+ addToken+ addPostParam "title" titleText+ addPostParam "contents" contentsText+ statusIs 200+ thoughts <- testDB $ selectList [] []+ Entity thoughtId thought <- case thoughts of+ [] -> liftIO $ expectationFailure "Expected to find at least one thought, found none."+ [e] -> pure e+ _ -> liftIO $ expectationFailure "Found more than one thought."+ liftIO $ do+ thoughtTitle thought `shouldBe` titleText+ thoughtContents thought `shouldBe` contentsText+ get $ ThoughtR thoughtId+ bodyContains $ T.unpack titleText+ bodyContains $ T.unpack contentsText+ statusIs 200
+ blog-example/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
+ src/Test/Syd/Yesod.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++-- | Testing a yesod site.+--+-- For a fully-worked example, see sydtest-yesod/blog-example.+module Test.Syd.Yesod+ ( -- * Functions to run a test suite+ yesodSpec,+ yesodSpecWithSiteGenerator,+ yesodSpecWithSiteGeneratorAndArgument,+ yesodSpecWithSiteSupplier,+ yesodSpecWithSiteSupplierWith,+ yesodSpecWithSiteSetupFunc,+ yesodSpecWithSiteSetupFunc',++ -- *** Setup functions+ yesodClientSetupFunc,++ -- ** Core+ YesodSpec,+ YesodClient (..),+ YesodClientM (..),+ runYesodClientM,+ YesodExample,++ -- * Helper functions to define tests+ yit,+ ydescribe,++ -- * Making requests+ get,+ post,+ followRedirect,++ -- ** Using the request builder+ request,+ setUrl,+ setMethod,+ addRequestHeader,+ addGetParam,+ addPostParam,+ addFile,+ addFileWith,+ setRequestBody,++ -- ** Helpers+ performMethod,+ performRequest,++ -- *** Types+ RequestBuilder (..),+ runRequestBuilder,++ -- *** Token+ addToken,+ addToken_,+ addTokenFromCookie,+ addTokenFromCookieNamedToHeaderNamed,++ -- *** Queries+ getRequest,+ getResponse,+ getLocation,+ getLast,++ -- * Declaring assertions+ statusIs,+ locationShouldBe,+ bodyContains,++ -- ** Reexports+ module HTTP,+ )+where++import Network.HTTP.Client as HTTP+import Network.HTTP.Types as HTTP+import Test.Syd.Yesod.Client+import Test.Syd.Yesod.Def+import Test.Syd.Yesod.Request
+ src/Test/Syd/Yesod/Client.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-unused-imports #-}++module Test.Syd.Yesod.Client where++import Control.Monad.Catch+import Control.Monad.Fail+import Control.Monad.Reader+import Control.Monad.State+import qualified Control.Monad.State as State+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB+import Data.Text (Text)+import qualified Data.Text as T+import Network.HTTP.Client as HTTP+import Network.HTTP.Types as HTTP+import Test.Syd+import Yesod.Core as Yesod++-- | A client environment to call a Yesod app.+data YesodClient site = YesodClient+ { -- | The site itself+ yesodClientSite :: !site,+ -- | The 'HTTP.Manager' to make the requests+ yesodClientManager :: !HTTP.Manager,+ -- | The port that the site is running on, using @warp@+ yesodClientSitePort :: !Int+ }++-- | The state that is maintained throughout a 'YesodClientM'+data YesodClientState site = YesodClientState+ { -- | The last request and response pair+ yesodClientStateLast :: !(Maybe (Request, Response LB.ByteString)),+ -- | The cookies to pass along+ yesodClientStateCookies :: !CookieJar+ }++-- | The starting point of the 'YesodClientState site' of a 'YesodClientM site'+initYesodClientState :: YesodClientState site+initYesodClientState =+ YesodClientState+ { yesodClientStateLast = Nothing,+ yesodClientStateCookies = createCookieJar []+ }++-- | A monad to call a Yesod app.+--+-- This has access to a 'YesodClient site'.+newtype YesodClientM site a = YesodClientM+ { unYesodClientM :: StateT (YesodClientState site) (ReaderT (YesodClient site) IO) a+ }+ deriving+ ( Functor,+ Applicative,+ Monad,+ MonadIO,+ MonadReader (YesodClient site),+ MonadState (YesodClientState site),+ MonadFail,+ MonadThrow+ )++-- | For backward compatibility+type YesodExample site a = YesodClientM site a++-- | Run a YesodClientM site using a YesodClient site+runYesodClientM :: YesodClient site -> YesodClientM site a -> IO a+runYesodClientM cenv (YesodClientM func) = runReaderT (evalStateT func initYesodClientState) cenv++-- | Get the most recently sent request.+getRequest :: YesodClientM site (Maybe Request)+getRequest = State.gets (fmap fst . yesodClientStateLast)++-- | Get the most recently received response.+getResponse :: YesodClientM site (Maybe (Response LB.ByteString))+getResponse = State.gets (fmap snd . yesodClientStateLast)++-- | Get the most recently sent request and the response to it.+getLast :: YesodClientM site (Maybe (Request, Response LB.ByteString))+getLast = State.gets yesodClientStateLast++-- | Get the 'Location' header of most recently received response.+getLocation :: ParseRoute site => YesodClientM site (Either Text (Route site))+getLocation = do+ mr <- getResponse+ case mr of+ Nothing -> return $ Left "getLocation called, but there was no previous response, so no Location header"+ Just r -> case lookup "Location" (responseHeaders r) of+ Nothing -> return $ Left "getLocation called, but the previous response has no Location header"+ Just h -> case parseRoute $ decodePath' h of+ Nothing -> return $ Left $ "getLocation called, but couldn’t parse it into a route: " <> T.pack (show h)+ Just l -> return $ Right l+ where+ decodePath' :: ByteString -> ([Text], [(Text, Text)])+ decodePath' b =+ let (ss, q) = decodePath $ extractPath b+ in (ss, map unJust $ queryToQueryText q)+ unJust (a, Just b) = (a, b)+ unJust (a, Nothing) = (a, mempty)++-- | Annotate the given test code with the last request and its response, if one has been made already.+withLastRequestContext :: YesodClientM site a -> YesodClientM site a+withLastRequestContext yfunc@(YesodClientM func) = do+ mLast <- getLast+ case mLast of+ Nothing -> yfunc+ Just (req, resp) ->+ YesodClientM $ do+ s <- get+ c <- ask+ let ctx =+ unlines+ [ "last request:",+ ppShow req,+ "full response:",+ ppShow resp+ ]+ (r, s') <- liftIO $ context ctx $ runReaderT (runStateT func s) c+ put s'+ pure r
+ src/Test/Syd/Yesod/Def.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++module Test.Syd.Yesod.Def+ ( yesodSpec,+ yesodSpecWithSiteGenerator,+ yesodSpecWithSiteGeneratorAndArgument,+ yesodSpecWithSiteSupplier,+ yesodSpecWithSiteSupplierWith,+ yesodSpecWithSiteSetupFunc,+ yesodSpecWithSiteSetupFunc',+ yesodClientSetupFunc,+ YesodSpec,+ yit,+ ydescribe,+ )+where++import GHC.Stack+import Network.HTTP.Client as HTTP+import Test.Syd+import Test.Syd.Wai+import Test.Syd.Yesod.Client+import Yesod.Core as Yesod++-- | Run a test suite using the given 'site'.+--+-- If your 'site' contains any resources that need to be set up, you probably want to be using one of the following functions instead.+--+-- Example usage with a minimal yesod 'App':+--+-- > {-# LANGUAGE MultiParamTypeClasses #-}+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE QuasiQuotes #-}+-- > {-# LANGUAGE TemplateHaskell #-}+-- > {-# LANGUAGE TypeFamilies #-}+-- >+-- > module Minimal where+-- >+-- > import Yesod+-- > import Test.Syd+-- >+-- > data App = App -- | Empty App type+-- >+-- > mkYesod "App" [parseRoutes|+-- > / HomeR GET+-- > |]+-- >+-- > instance Yesod App+-- >+-- > getHomeR :: Handler Html+-- > getHomeR = "Hello, world!"+-- >+-- > main :: IO ()+-- > main = Yesod.warp 3000 App+-- >+-- > testMain :: IO ()+-- > testMain = sydTest spec+-- >+-- > spec :: Spec+-- > spec = yesodSpec App $ do+-- > it "returns 200 on the homepage" $ do+-- > get HomeR+-- > statusIs 200+--+-- This function exists for backward compatibility with yesod-test.+yesodSpec :: YesodDispatch site => site -> YesodSpec site -> Spec+yesodSpec site = yesodSpecWithSiteGenerator $ pure site++-- | Run a test suite using the given 'site' generator.+--+-- If your 'site' contains any resources that you will want to have set up beforhand, you will probably want to use 'yesodSpecWithSiteGeneratorAndArgument' or 'yesodSpecWithSiteSupplierWith' instead.+--+--+-- Example usage with a yesod 'App' that contains a secret key that is generated at startup but not used during tests:+--+-- > data Key = Key -- The implementation of the actual key is omitted here for brevity.+-- > genKey :: IO Key+-- > genKey = pure Key+-- >+-- > data App = App { appSecretKey :: Key }+-- >+-- > genApp :: IO App+-- > genApp = App <$> genKey+-- >+-- > main :: IO ()+-- > main = sydTest spec+-- >+-- > spec :: Spec+-- > spec = yesodSpecWithSiteGenerator genApp $ do+-- > it "returns 200 on the homepage" $ do+-- > get HomeR+-- > statusIs 200+--+-- This function exists for backward compatibility with yesod-test.+yesodSpecWithSiteGenerator :: YesodDispatch site => IO site -> YesodSpec site -> Spec+yesodSpecWithSiteGenerator siteGen = yesodSpecWithSiteGeneratorAndArgument $ \() -> siteGen++-- | Run a test suite using the given 'site' generator which uses an inner resource.+--+-- If your 'site' contains any resources that you need to set up using a 'withX' function, you will want to use `yesodSpecWithSiteSupplier` instead.+--+-- This function exists for backward compatibility with yesod-test.+yesodSpecWithSiteGeneratorAndArgument :: YesodDispatch site => (a -> IO site) -> YesodSpec site -> SpecWith a+yesodSpecWithSiteGeneratorAndArgument func = yesodSpecWithSiteSupplierWith $ \f a -> func a >>= f++-- | Using a function that supplies a 'site', run a test suite.+--+-- Example usage with a yesod 'App' that contains an sqlite database connection. See 'sydtest-persistent-sqlite'.+--+-- > import Test.Syd.Persistent.Sqlite+-- >+-- > data App = App { appConnectionPool :: ConnectionPool }+-- >+-- > main :: IO ()+-- > main = sydTest spec+-- >+-- > appSupplier :: (App -> IO r) -> IO r+-- > appSupplier func =+-- > withConnectionPool myMigration $ \pool ->+-- > func $ App { appConnectionPool = pool}+-- >+-- > spec :: Spec+-- > spec = yesodSpecWithSiteSupplier appSupplier $ do+-- > it "returns 200 on the homepage" $ do+-- > get HomeR+-- > statusIs 200+yesodSpecWithSiteSupplier :: YesodDispatch site => (forall r. (site -> IO r) -> IO r) -> YesodSpec site -> Spec+yesodSpecWithSiteSupplier func = yesodSpecWithSiteSupplierWith (\f () -> func f)++-- | Using a function that supplies a 'site', based on an inner resource, run a test suite.+yesodSpecWithSiteSupplierWith :: YesodDispatch site => (forall r. (site -> IO r) -> (a -> IO r)) -> YesodSpec site -> SpecWith a+yesodSpecWithSiteSupplierWith func = yesodSpecWithSiteSetupFunc $ \_ -> SetupFunc func++-- | Using a function that supplies a 'site', using a 'SetupFunc'+yesodSpecWithSiteSetupFunc :: YesodDispatch site => (HTTP.Manager -> SetupFunc a site) -> TestDef (HTTP.Manager ': l) (YesodClient site) -> TestDef l a+yesodSpecWithSiteSetupFunc setupFunc = managerSpec . yesodSpecWithSiteSetupFunc' setupFunc++-- | Using a function that supplies a 'site', using a 'SetupFunc' but without setting up the 'HTTP.Manager' beforehand.+--+-- This function assumed that you've already set up the 'HTTP.Manager' beforehand using something like 'managerSpec'.+yesodSpecWithSiteSetupFunc' :: YesodDispatch site => (HTTP.Manager -> SetupFunc a site) -> TestDef (HTTP.Manager ': l) (YesodClient site) -> TestDef (HTTP.Manager ': l) a+yesodSpecWithSiteSetupFunc' setupFunc = setupAroundWith' (\man -> setupFunc man `connectSetupFunc` yesodClientSetupFunc man)++yesodClientSetupFunc :: YesodDispatch site => HTTP.Manager -> SetupFunc site (YesodClient site)+yesodClientSetupFunc man = wrapSetupFunc $ \site -> do+ application <- liftIO $ Yesod.toWaiAppPlain site+ p <- unwrapSetupFunc applicationSetupFunc application+ let client =+ YesodClient+ { yesodClientManager = man,+ yesodClientSite = site,+ yesodClientSitePort = p+ }+ pure client++-- | For backward compatibility with yesod-test+type YesodSpec site = TestDef '[HTTP.Manager] (YesodClient site)++-- | Define a test in the 'YesodClientM site' monad instead of 'IO'.+yit ::+ forall site e.+ ( HasCallStack,+ IsTest (YesodClient site -> IO e),+ Arg1 (YesodClient site -> IO e) ~ (),+ Arg2 (YesodClient site -> IO e) ~ YesodClient site+ ) =>+ String ->+ YesodClientM site e ->+ YesodSpec site+yit s f = it s ((\cenv -> runYesodClientM cenv f) :: YesodClient site -> IO e)++-- | For backward compatibility+--+-- > ydescribe = describe+ydescribe :: String -> YesodSpec site -> YesodSpec site+ydescribe = describe
+ src/Test/Syd/Yesod/Request.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-unused-imports #-}++module Test.Syd.Yesod.Request where++import Control.Applicative+import Control.Monad.Catch+import Control.Monad.Fail+import Control.Monad.Reader+import Control.Monad.State (MonadState, StateT (..), execStateT)+import qualified Control.Monad.State as State+import Data.ByteString (ByteString)+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.CaseInsensitive (CI)+import Data.Functor.Identity+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Time+import GHC.Stack+import Network.HTTP.Client as HTTP+import Network.HTTP.Client.Internal (httpRaw)+import Network.HTTP.Client.MultipartFormData+import Network.HTTP.Types as HTTP+import Test.Syd+import Test.Syd.Yesod.Client+import qualified Text.XML.Cursor as C+import Web.Cookie as Cookie+import Yesod.Core as Yesod+import Yesod.Core.Unsafe+import qualified Yesod.Test as YesodTest+import Yesod.Test.TransversingCSS as CSS++-- | Make a @GET@ request for the given route+--+-- > yit "returns 200 on the home route" $ do+-- > get HomeR+-- > statusIs 200+get :: (Yesod site, RedirectUrl site url) => url -> YesodClientM site ()+get = performMethod methodGet++-- | Make a @POST@ request for the given route+--+-- > yit "returns 200 on the start processing route" $ do+-- > post StartProcessingR+-- > statusIs 200+post :: (Yesod site, RedirectUrl site url) => url -> YesodClientM site ()+post = performMethod methodPost++-- | Perform a request using an arbitrary method for the given route.+performMethod :: (Yesod site, RedirectUrl site url) => Method -> url -> YesodClientM site ()+performMethod method route = request $ do+ setUrl route+ setMethod method++-- | Assert the status of the most recently received response.+--+-- > yit "returns 200 on the home route" $ do+-- > get HomeR+-- > statusIs 200+statusIs :: HasCallStack => Int -> YesodClientM site ()+statusIs i = do+ mLast <- getLast+ case mLast of+ Nothing -> liftIO $ expectationFailure "statusIs: No request made yet."+ Just (_, resp) ->+ let c = statusCode (responseStatus resp)+ in withLastRequestContext $ liftIO $ c `shouldBe` i++-- | Assert the redirect location of the most recently received response.+--+-- > yit "redirects to the overview on the home route" $ do+-- > get HomeR+-- > statusIs 301+-- > locationShouldBe OverviewR+locationShouldBe :: (ParseRoute site, Show (Route site)) => Route site -> YesodClientM site ()+locationShouldBe expected =+ withLastRequestContext $ do+ errOrLoc <- getLocation+ liftIO $ case errOrLoc of+ Left err -> expectationFailure (T.unpack err)+ Right actual -> expected `shouldBe` actual++-- | Assert the last response has the given text.+--+-- The check is performed using the response body in full text form without any html parsing.+bodyContains :: HasCallStack => String -> YesodExample site ()+bodyContains text = do+ mResp <- getLast+ case mResp of+ Nothing -> liftIO $ expectationFailure "bodyContains: No request made yet."+ Just (_, resp) ->+ withLastRequestContext $+ liftIO $+ shouldSatisfyNamed (responseBody resp) (unwords ["bodyContains", show text]) (\body -> TE.encodeUtf8 (T.pack text) `SB.isInfixOf` LB.toStrict body)++-- | A request builder monad that allows you to monadically build a request using `runRequestBuilder`.+--+-- This request builder has access to the entire `YesodClientM` underneath.+-- This includes the `Site` under test, as well as cookies etc.+--+-- See 'YesodClientM' for more details.+newtype RequestBuilder site a = RequestBuilder+ { unRequestBuilder ::+ StateT+ (RequestBuilderData site)+ (YesodClientM site)+ a+ }+ deriving+ ( Functor,+ Applicative,+ Monad,+ MonadIO,+ MonadReader (YesodClient site),+ MonadState (RequestBuilderData site),+ MonadFail,+ MonadThrow+ )++-- | Run a 'YesodClientM' function as part of a 'RequestBuilder'.+liftClient :: YesodClientM site a -> RequestBuilder site a+liftClient = RequestBuilder . lift++data RequestBuilderData site = RequestBuilderData+ { requestBuilderDataMethod :: !Method,+ requestBuilderDataUrl :: !Text,+ requestBuilderDataHeaders :: !HTTP.RequestHeaders,+ requestBuilderDataGetParams :: !HTTP.Query,+ requestBuilderDataPostData :: !PostData+ }++data PostData+ = MultipleItemsPostData [RequestPart]+ | BinaryPostData ByteString++data RequestPart+ = ReqKvPart Text Text+ | ReqFilePart Text FilePath ByteString (Maybe Text)++initialRequestBuilderData :: RequestBuilderData site+initialRequestBuilderData =+ RequestBuilderData+ { requestBuilderDataMethod = "GET",+ requestBuilderDataUrl = "",+ requestBuilderDataHeaders = [],+ requestBuilderDataGetParams = [],+ requestBuilderDataPostData = MultipleItemsPostData []+ }++isFile :: RequestPart -> Bool+isFile = \case+ ReqKvPart {} -> False+ ReqFilePart {} -> True++-- | Run a 'RequestBuilder' to make the 'Request' that it defines.+runRequestBuilder :: RequestBuilder site a -> YesodClientM site Request+runRequestBuilder (RequestBuilder func) = do+ p <- asks yesodClientSitePort+ cj <- State.gets yesodClientStateCookies+ RequestBuilderData {..} <- execStateT func initialRequestBuilderData+ let requestStr = T.unpack requestBuilderDataUrl++ req <- case parseRequest requestStr <|> parseRequest ("http://localhost" <> requestStr) of+ Nothing -> liftIO $ expectationFailure $ "Failed to parse url: " <> requestStr+ Just req -> pure req+ boundary <- liftIO webkitBoundary+ (body, contentTypeHeader) <- liftIO $ case requestBuilderDataPostData of+ MultipleItemsPostData [] -> pure (RequestBodyBS SB.empty, Nothing)+ MultipleItemsPostData dat ->+ if any isFile dat+ then do+ ps <-+ renderParts+ boundary+ ( flip map dat $ \case+ ReqKvPart k v -> partBS k (TE.encodeUtf8 v)+ ReqFilePart k path contents mime ->+ (partFileRequestBody k path (RequestBodyBS contents))+ { partContentType = TE.encodeUtf8 <$> mime+ }+ )+ pure+ ( ps,+ Just $ "multipart/form-data; boundary=" <> boundary+ )+ else+ pure+ ( RequestBodyBS $+ renderSimpleQuery False $+ flip mapMaybe dat $ \case+ ReqKvPart k v -> Just (TE.encodeUtf8 k, TE.encodeUtf8 v)+ ReqFilePart {} -> Nothing,+ Just "application/x-www-form-urlencoded"+ )+ BinaryPostData sb -> pure (RequestBodyBS sb, Nothing)+ now <- liftIO getCurrentTime+ let (req', cj') =+ insertCookiesIntoRequest+ ( req+ { port = p,+ method = requestBuilderDataMethod,+ requestHeaders =+ concat+ [ requestBuilderDataHeaders,+ [("Content-Type", cth) | cth <- maybeToList contentTypeHeader]+ ],+ requestBody = body,+ queryString = HTTP.renderQuery False requestBuilderDataGetParams+ }+ )+ cj+ now+ State.modify' (\s -> s {yesodClientStateCookies = cj'})+ pure req'++-- | Perform the request that is built by the given 'RequestBuilder'.+--+-- > yit "returns 200 on this post request" $ do+-- > request $ do+-- > setUrl StartProcessingR+-- > setMethod "POST"+-- > addPostParam "key" "value"+-- > statusIs 200+request :: RequestBuilder site a -> YesodClientM site ()+request rb = do+ req <- runRequestBuilder rb+ performRequest req++-- | Set the url of the 'RequestBuilder' to the given route.+setUrl :: (Yesod site, RedirectUrl site url) => url -> RequestBuilder site ()+setUrl route = do+ site <- asks yesodClientSite+ Right url <-+ Yesod.Core.Unsafe.runFakeHandler+ M.empty+ (const $ error "Test.Syd.Yesod: No logger available")+ site+ (toTextUrl route)+ State.modify'+ ( \oldReq ->+ oldReq+ { requestBuilderDataUrl = url+ }+ )++-- | Set the method of the 'RequestBuilder'.+setMethod :: Method -> RequestBuilder site ()+setMethod m = State.modify' (\r -> r {requestBuilderDataMethod = m})++-- | Add the given request header to the 'RequestBuilder'.+addRequestHeader :: HTTP.Header -> RequestBuilder site ()+addRequestHeader h = State.modify' (\r -> r {requestBuilderDataHeaders = h : requestBuilderDataHeaders r})++-- | Add the given GET parameter to the 'RequestBuilder'.+addGetParam :: Text -> Text -> RequestBuilder site ()+addGetParam k v = State.modify' (\r -> r {requestBuilderDataGetParams = (TE.encodeUtf8 k, Just $ TE.encodeUtf8 v) : requestBuilderDataGetParams r})++-- | Add the given POST parameter to the 'RequestBuilder'.+addPostParam :: Text -> Text -> RequestBuilder site ()+addPostParam name value =+ State.modify' $ \r -> r {requestBuilderDataPostData = addPostData (requestBuilderDataPostData r)}+ where+ addPostData (BinaryPostData _) = error "Trying to add post param to binary content."+ addPostData (MultipleItemsPostData posts) =+ MultipleItemsPostData $ ReqKvPart name value : posts++addFile ::+ -- | The parameter name for the file.+ Text ->+ -- | The path to the file.+ FilePath ->+ -- | The MIME type of the file, e.g. "image/png".+ Text ->+ RequestBuilder site ()+addFile name path mimetype = do+ contents <- liftIO $ SB.readFile path+ addFileWith name path contents (Just mimetype)++addFileWith ::+ -- | The parameter name for the file.+ Text ->+ -- | The path to the file.+ FilePath ->+ -- | The contents of the file.+ ByteString ->+ -- | The MIME type of the file, e.g. "image/png".+ Maybe Text ->+ RequestBuilder site ()+addFileWith name path contents mMimetype =+ State.modify' $ \r -> r {requestBuilderDataPostData = addPostData (requestBuilderDataPostData r)}+ where+ addPostData (BinaryPostData _) = error "Trying to add file after setting binary content."+ addPostData (MultipleItemsPostData posts) =+ MultipleItemsPostData $ ReqFilePart name path contents mMimetype : posts++-- | Set the request body of the 'RequestBuilder'.+--+-- Note that this invalidates any of the other post parameters that may have been set.+setRequestBody :: ByteString -> RequestBuilder site ()+setRequestBody body = State.modify' $ \r -> r {requestBuilderDataPostData = BinaryPostData body}++-- | Look up the CSRF token from the given form data and add it to the request header+addToken_ :: HasCallStack => Text -> RequestBuilder site ()+addToken_ scope = do+ matches <- liftClient $ htmlQuery $ scope <> " input[name=_token][type=hidden][value]"+ case matches of+ [] -> liftIO $ expectationFailure "No CSRF token found in the current page"+ [element] -> addPostParam "_token" $ head $ C.attribute "value" $ YesodTest.parseHTML element+ _ -> liftIO $ expectationFailure "More than one CSRF token found in the page"++-- | Look up the CSRF token from the only form data and add it to the request header+addToken :: HasCallStack => RequestBuilder site ()+addToken = addToken_ ""++-- | Look up the CSRF token from the cookie with name 'defaultCsrfCookieName' and add it to the request header with name 'defaultCsrfHeaderName'.+addTokenFromCookie :: HasCallStack => RequestBuilder site ()+addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName++-- | Looks up the CSRF token stored in the cookie with the given name and adds it to the given request header.+addTokenFromCookieNamedToHeaderNamed ::+ HasCallStack =>+ -- | The name of the cookie+ ByteString ->+ -- | The name of the header+ CI ByteString ->+ RequestBuilder site ()+addTokenFromCookieNamedToHeaderNamed cookieName headerName = do+ cookies <- getRequestCookies+ case M.lookup cookieName cookies of+ Just csrfCookie -> addRequestHeader (headerName, setCookieValue csrfCookie)+ Nothing ->+ liftIO $+ expectationFailure $+ concat+ [ "addTokenFromCookieNamedToHeaderNamed failed to lookup CSRF cookie with name: ",+ show cookieName,+ ". Cookies were: ",+ show cookies+ ]++-- | Perform the given request as-is.+--+-- Note that this function does not check whether you are making a request to the site under test.+-- You could make a request to https://google.com if you wanted.+performRequest :: Request -> YesodClientM site ()+performRequest req = do+ man <- asks yesodClientManager+ resp <- liftIO $ httpRaw req man >>= traverse (fmap LB.fromChunks . brConsume)+ cj <- State.gets yesodClientStateCookies+ now <- liftIO getCurrentTime+ let (cj', _) = updateCookieJar resp req now cj+ State.modify'+ ( \s ->+ s+ { yesodClientStateLast = Just (req, resp),+ yesodClientStateCookies = cj'+ }+ )++-- | For backward compatibiilty, you can use the 'MonadState' constraint to get access to the 'CookieJar' directly.+getRequestCookies :: RequestBuilder site (Map ByteString SetCookie)+getRequestCookies = do+ cj <- liftClient $ State.gets yesodClientStateCookies+ pure $+ M.fromList $+ flip map (destroyCookieJar cj) $ \Cookie {..} ->+ ( cookie_name,+ defaultSetCookie+ { setCookieName = cookie_name,+ setCookieValue = cookie_value+ }+ )++-- | Query the last response using CSS selectors, returns a list of matched fragments+htmlQuery :: HasCallStack => CSS.Query -> YesodExample site [CSS.HtmlLBS]+htmlQuery query = do+ mResp <- getResponse+ case mResp of+ Nothing -> liftIO $ expectationFailure "No request made yet."+ Just resp -> case CSS.findBySelector (responseBody resp) query of+ Left err -> liftIO $ expectationFailure $ show query <> " did not parse: " <> show err+ Right matches -> pure $ map (LB.fromStrict . TE.encodeUtf8 . T.pack) matches++-- | Follow a redirect, if the last response was a redirect.+--+-- (We consider a request a redirect if the status is+-- 301, 302, 303, 307 or 308, and the Location header is set.)+followRedirect ::+ Yesod site =>+ -- | 'Left' with an error message if not a redirect, 'Right' with the redirected URL if it was+ YesodExample site (Either Text Text)+followRedirect = do+ mr <- getResponse+ case mr of+ Nothing -> return $ Left "followRedirect called, but there was no previous response, so no redirect to follow"+ Just r -> do+ if HTTP.statusCode (responseStatus r) `notElem` [301, 302, 303, 307, 308]+ then return $ Left "followRedirect called, but previous request was not a redirect"+ else do+ case lookup "Location" (responseHeaders r) of+ Nothing -> return $ Left "followRedirect called, but no location header set"+ Just h ->+ let url = TE.decodeUtf8 h+ in get url >> return (Right url)
+ sydtest-yesod.cabal view
@@ -0,0 +1,109 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: sydtest-yesod+version: 0.0.0.0+synopsis: A yesod companion library for sydtest+category: Testing+homepage: https://github.com/NorfairKing/sydtest#readme+bug-reports: https://github.com/NorfairKing/sydtest/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: Copyright (c) 2020 Tom Sydney Kerckhove+license: OtherLicense+license-file: LICENSE.md+build-type: Simple++source-repository head+ type: git+ location: https://github.com/NorfairKing/sydtest++library+ exposed-modules:+ Test.Syd.Yesod+ Test.Syd.Yesod.Client+ Test.Syd.Yesod.Def+ Test.Syd.Yesod.Request+ other-modules:+ Paths_sydtest_yesod+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , blaze-builder+ , bytestring+ , case-insensitive+ , containers+ , cookie+ , exceptions+ , http-client+ , http-types+ , mtl+ , pretty-show+ , sydtest+ , sydtest-wai+ , text+ , time+ , wai+ , xml-conduit+ , yesod-core+ , yesod-test+ default-language: Haskell2010++test-suite sydtest-yesod-blog-example-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Example.Blog+ Example.BlogSpec+ Paths_sydtest_yesod+ hs-source-dirs:+ blog-example+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-tool-depends:+ sydtest-discover:sydtest-discover+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , http-client+ , monad-logger+ , mtl+ , persistent+ , persistent-sqlite+ , persistent-template+ , sydtest+ , sydtest-persistent-sqlite+ , sydtest-yesod+ , text+ , yesod+ , yesod-form+ default-language: Haskell2010++test-suite sydtest-yesod-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Test.Syd.Yesod.App+ Test.Syd.YesodSpec+ Paths_sydtest_yesod+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-tool-depends:+ sydtest-discover:sydtest-discover+ build-depends:+ base >=4.7 && <5+ , bytestring+ , conduit+ , cookie+ , http-types+ , resourcet+ , sydtest+ , sydtest-yesod+ , text+ , yesod+ , yesod-form+ default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
+ test/Test/Syd/Yesod/App.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Test.Syd.Yesod.App where++import Conduit+import Control.Monad+import qualified Data.ByteString as SB+import Web.Cookie+import Yesod++data App = App++mkYesod+ "App"+ [parseRoutes|++ / HomeR GET POST++ /expects-header ExpectsHeaderR GET+ /expects-get-param ExpectsGetParamR GET+ /expects-post-param ExpectsPostParamR POST+ /expects-post-body ExpectsPostBodyR POST+ /expects-post-file ExpectsPostFileR POST++ /redirect RedirectHomeR GET++ /set-cookie SetCookieR GET+ /expects-cookie ExpectsCookieR GET++ /form FormR GET POST+|]++instance Yesod App++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++getHomeR :: Handler Html+getHomeR = pure "Hello, world! (GET)"++postHomeR :: Handler Html+postHomeR = pure "Hello, world! (POST)"++getExpectsHeaderR :: Handler ()+getExpectsHeaderR = do+ mh <- lookupHeader "TEST_HEADER"+ case mh of+ Nothing -> notFound+ Just _ -> pure ()++getExpectsGetParamR :: Handler ()+getExpectsGetParamR = do+ mh <- lookupGetParam "TEST_PARAM"+ case mh of+ Nothing -> notFound+ Just _ -> pure ()++postExpectsPostParamR :: Handler ()+postExpectsPostParamR = do+ mh <- lookupPostParam "TEST_PARAM"+ case mh of+ Nothing -> notFound+ Just _ -> pure ()++postExpectsPostBodyR :: Handler ()+postExpectsPostBodyR = do+ body <- SB.concat <$> runConduit (rawRequestBody .| sinkList)+ case body of+ "test" -> pure ()+ _ -> notFound++postExpectsPostFileR :: Handler ()+postExpectsPostFileR = do+ mh <- lookupFile "TEST_PARAM"+ case mh of+ Nothing -> notFound+ Just fi -> do+ unless (fileName fi == "filename") $ invalidArgs ["incorrect filename"]+ unless (fileContentType fi == "text/plain") $ invalidArgs ["incorrect content type"]+ contents <- runResourceT $ fileSourceByteString fi+ unless (contents == "test") $ invalidArgs ["incorrect body"]++getRedirectHomeR :: Handler ()+getRedirectHomeR = redirect HomeR++getSetCookieR :: Handler ()+getSetCookieR = setCookie (defaultSetCookie {setCookieName = "TEST_COOKIE"})++getExpectsCookieR :: Handler ()+getExpectsCookieR = do+ mc <- lookupCookie "TEST_COOKIE"+ case mc of+ Nothing -> notFound+ Just _ -> pure ()++getFormR :: Handler Html+getFormR = do+ (widget, enctype) <- generateFormPost $ renderDivs $ areq textField "testKey" Nothing+ defaultLayout+ [whamlet|+ <form method=post action=@{FormR} enctype=#{enctype}>+ ^{widget}+ <button>Submit+ |]++postFormR :: Handler ()+postFormR = do+ tv <- runInputPost $ ireq textField "testKey"+ unless (tv == "testVal") $ invalidArgs ["incorrect value"]
+ test/Test/Syd/YesodSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Syd.YesodSpec (spec) where++import Data.Text (Text)+import Test.Syd+import Test.Syd.Yesod+import Test.Syd.Yesod.App++spec :: Spec+spec = yesodSpec App $ do+ yit "responds 200 OK to GET HomeR" $ do+ get HomeR+ statusIs 200+ yit "responds 200 OK to GET HomeR using the request builder" $ do+ request $ do+ setUrl HomeR+ setMethod "GET"+ statusIs 200+ yit "responds 200 OK to GET /" $ do+ get ("/" :: Text)+ statusIs 200+ yit "responds 200 OK to POST HomeR" $ do+ post HomeR+ statusIs 200+ yit "responds 200 OK to POST HomeR using the request builder" $ do+ request $ do+ setUrl HomeR+ setMethod "POST"+ statusIs 200+ yit "responds 200 OK to POST /" $ do+ post ("/" :: Text)+ statusIs 200+ yit "is able to add a header" $ do+ request $ do+ setUrl ExpectsHeaderR+ addRequestHeader ("TEST_HEADER", "test")+ statusIs 200+ yit "is able to add a get param" $ do+ request $ do+ setUrl ExpectsGetParamR+ addGetParam "TEST_PARAM" "test"+ statusIs 200+ yit "is able to add a post param" $ do+ request $ do+ setUrl ExpectsPostParamR+ setMethod "POST"+ addPostParam "TEST_PARAM" "test"+ statusIs 200+ yit "is able to add a raw post body" $ do+ request $ do+ setUrl ExpectsPostBodyR+ setMethod "POST"+ setRequestBody "test"+ statusIs 200+ yit "is able to add a post file" $ do+ request $ do+ setUrl ExpectsPostFileR+ setMethod "POST"+ addFileWith "TEST_PARAM" "filename" "test" (Just "text/plain")+ statusIs 200+ yit "can check for redirects" $ do+ get RedirectHomeR+ locationShouldBe HomeR+ errOrDestination <- followRedirect+ liftIO $ case errOrDestination of+ Left err -> expectationFailure (show err)+ Right _ -> pure ()+ statusIs 200+ yit "retains cookies" $ do+ get SetCookieR+ statusIs 200+ get ExpectsCookieR+ statusIs 200+ yit "can do forms" $ do+ get FormR+ statusIs 200+ request $ do+ setUrl FormR+ setMethod "POST"+ addToken+ addPostParam "testKey" "testVal"+ statusIs 200