diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/blog-example/Example/Blog.hs b/blog-example/Example/Blog.hs new file mode 100644 --- /dev/null +++ b/blog-example/Example/Blog.hs @@ -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| +

You've posted a thought! +

the title was #{newThoughtTitle f} +

the contents were #{newThoughtContents f} + + Look at your thought + |] + FormMissing -> + defaultLayout + [whamlet| +

Hello world! +

+ ^{form} + + Submit thought + |] + FormFailure errs -> invalidArgs errs + +postNewThoughtR :: Handler Html +postNewThoughtR = getNewThoughtR + +getThoughtR :: ThoughtId -> Handler Html +getThoughtR thoughtId = do + thought <- runDB $ get404 thoughtId + defaultLayout + [whamlet| +

#{thoughtTitle thought} +

+ #{thoughtContents thought} + |] + +main :: IO () +main = runStderrLoggingT $ + withSqlitePool "example.sqlite3" 1 $ \pool -> do + runSqlPool (runMigration migrateThoughts) pool + liftIO $ Yesod.warp 3000 $ App {appConnectionPool = pool} diff --git a/blog-example/Example/BlogSpec.hs b/blog-example/Example/BlogSpec.hs new file mode 100644 --- /dev/null +++ b/blog-example/Example/BlogSpec.hs @@ -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 diff --git a/blog-example/Spec.hs b/blog-example/Spec.hs new file mode 100644 --- /dev/null +++ b/blog-example/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/src/Test/Syd/Yesod.hs b/src/Test/Syd/Yesod.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Yesod.hs @@ -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 diff --git a/src/Test/Syd/Yesod/Client.hs b/src/Test/Syd/Yesod/Client.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Yesod/Client.hs @@ -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 diff --git a/src/Test/Syd/Yesod/Def.hs b/src/Test/Syd/Yesod/Def.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Yesod/Def.hs @@ -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 diff --git a/src/Test/Syd/Yesod/Request.hs b/src/Test/Syd/Yesod/Request.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Yesod/Request.hs @@ -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) diff --git a/sydtest-yesod.cabal b/sydtest-yesod.cabal new file mode 100644 --- /dev/null +++ b/sydtest-yesod.cabal @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Test/Syd/Yesod/App.hs b/test/Test/Syd/Yesod/App.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Yesod/App.hs @@ -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| + + ^{widget} +