diff --git a/src/Test/Syd/Yesod.hs b/src/Test/Syd/Yesod.hs --- a/src/Test/Syd/Yesod.hs +++ b/src/Test/Syd/Yesod.hs @@ -9,6 +9,8 @@ -- For a fully-worked example, see sydtest-yesod/blog-example. module Test.Syd.Yesod ( -- * Functions to run a test suite + + -- ** Tests against a local instance of a site yesodSpec, yesodSpecWithSiteGenerator, yesodSpecWithSiteGeneratorAndArgument, @@ -20,6 +22,13 @@ -- *** Setup functions yesodClientSetupFunc, + -- ** Tests against a remote instance of a site + yesodE2ESpec, + yesodE2ESpec', + E2E (..), + localToE2ESpec, + localToE2EClient, + -- ** Core YesodSpec, YesodClient (..), @@ -77,6 +86,7 @@ module Test.Syd.Yesod.Client, module Test.Syd.Yesod.Def, module Test.Syd.Yesod.Request, + module Test.Syd.Yesod.E2E, -- * Reexports module HTTP, @@ -87,4 +97,5 @@ import Network.HTTP.Types as HTTP import Test.Syd.Yesod.Client import Test.Syd.Yesod.Def +import Test.Syd.Yesod.E2E import Test.Syd.Yesod.Request diff --git a/src/Test/Syd/Yesod/Client.hs b/src/Test/Syd/Yesod/Client.hs --- a/src/Test/Syd/Yesod/Client.hs +++ b/src/Test/Syd/Yesod/Client.hs @@ -24,6 +24,7 @@ import Network.HTTP.Client as HTTP import Network.HTTP.Types as HTTP import Network.Socket (PortNumber) +import Network.URI import Test.Syd import Test.Syd.Wai.Client (lastRequestResponseContext) import Yesod.Core as Yesod @@ -34,8 +35,8 @@ yesodClientSite :: !site, -- | The 'HTTP.Manager' to make the requests yesodClientManager :: !HTTP.Manager, - -- | The port that the site is running on, using @warp@ - yesodClientSitePort :: !PortNumber + -- | The base 'URI' that the site is running on + yesodClientSiteURI :: !URI } deriving (Generic) @@ -103,7 +104,7 @@ getLast = State.gets yesodClientStateLast -- | Get the 'Location' header of most recently received response. -getLocation :: ParseRoute site => YesodClientM site (Either Text (Route site)) +getLocation :: ParseRoute site => YesodClientM localSite (Either Text (Route site)) getLocation = do mr <- getResponse case mr of diff --git a/src/Test/Syd/Yesod/Def.hs b/src/Test/Syd/Yesod/Def.hs --- a/src/Test/Syd/Yesod/Def.hs +++ b/src/Test/Syd/Yesod/Def.hs @@ -23,6 +23,7 @@ import GHC.Stack (HasCallStack) import Network.HTTP.Client as HTTP +import Network.URI import Test.Syd import Test.Syd.Wai import Test.Syd.Yesod.Client @@ -167,14 +168,29 @@ YesodClient { yesodClientManager = man, yesodClientSite = site, - yesodClientSitePort = p + yesodClientSiteURI = + nullURI + { uriScheme = "http:", + uriAuthority = + Just $ + URIAuth + { uriUserInfo = "", + uriRegName = "localhost", + uriPort = ':' : show 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'. +-- | Define a test in the @YesodClientM site@ monad instead of 'IO'. +-- +-- The @YesodClientM site ()@ type is a member of 'IsTest', so 'yit' is defined as 'it'. +-- This function is only here for backward compatibility. +-- +-- > yit = it yit :: forall site. HasCallStack => @@ -183,7 +199,7 @@ YesodSpec site yit = it --- | For compatibility with `yesod-test` +-- | For compatibility with @yesod-test@ -- -- > ydescribe = describe ydescribe :: String -> YesodSpec site -> YesodSpec site diff --git a/src/Test/Syd/Yesod/E2E.hs b/src/Test/Syd/Yesod/E2E.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Yesod/E2E.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Syd.Yesod.E2E where + +import Control.Arrow (second) +import qualified Data.Binary.Builder as BB +import qualified Data.ByteString.Lazy as LB +import Data.Function +import qualified Data.Text.Encoding as TE +import GHC.Generics (Generic) +import Network.HTTP.Client as HTTP +import Network.HTTP.Client.TLS +import Network.HTTP.Types as HTTP +import Network.URI +import Test.Syd +import Test.Syd.Yesod.Client +import Test.Syd.Yesod.Def +import Yesod.Core + +-- | Run an end-to-end yesod test suite against a remote server at the given 'URI'. +-- +-- If you would like to write tests that can be run against both a local and a remote instance of your site, you can use the following type: +-- +-- > mySpec :: (Yesod site, RedirectUrl site (Route App)) => YesodSpec site +-- > mySpec = do +-- > it "responds 200 OK to GET HomeR" $ do +-- > get HomeR +-- > statusIs 200 +yesodE2ESpec :: URI -> YesodSpec (E2E site) -> Spec +yesodE2ESpec uri = beforeAll newTlsManager . yesodE2ESpec' uri + +-- | Like 'yesodE2ESpec', but doesn't set up the 'HTTP.Manager' for you. +-- +-- If you are running the end-to-end test against a server that uses +-- @https://@, make sure to use a TLS-enabled 'HTTP.Manager'. +-- +-- You can do this using @beforeAll newTlsManager@. +yesodE2ESpec' :: URI -> YesodSpec (E2E site) -> TestDef '[HTTP.Manager] () +yesodE2ESpec' uri = + beforeWith' + ( \man () -> do + pure + YesodClient + { yesodClientManager = man, + yesodClientSite = E2E, + yesodClientSiteURI = uri + } + ) + +-- | Turn a local 'YesodClient site' into a remote 'YesodClient (E2E site)'. +localToE2EClient :: YesodClient site -> YesodClient (E2E site) +localToE2EClient yc = yc {yesodClientSite = E2E} + +-- | See 'localToE2EClient' +-- +-- Turn an end-to-end yesod test suite into a local yesod test suite by +-- treating a local instance as remote. +localToE2ESpec :: YesodSpec (E2E site) -> YesodSpec site +localToE2ESpec = beforeWith (\yc -> pure $ localToE2EClient yc) + +-- | A dummy type that is an instance of 'Yesod', with as a phantom type, the app that it represents. +-- +-- That is to say, @E2E site@ is an instance of 'Yesod' that pretends to be a +-- @site@. You can treat it as a @site@ in end-to-end tests, except that you +-- cannot use the @site@ value because there is none in there. +data E2E site = E2E + deriving (Show, Eq, Generic) + +instance Yesod site => Yesod (E2E site) + +instance (Eq (Route site), RenderRoute site) => RenderRoute (E2E site) where + data Route (E2E site) = E2ERoute {unE2ERoute :: Route site} + deriving (Generic) + renderRoute (E2ERoute route) = renderRoute route + +instance Show (Route site) => Show (Route (E2E site)) where + show = show . unE2ERoute + +instance Eq (Route site) => Eq (Route (E2E site)) where + (==) = (==) `on` unE2ERoute + +instance RenderRoute site => RedirectUrl (E2E site) (Route site) where + toTextUrl route = do + let (urlPieces, queryParams) = renderRoute (E2ERoute route) + q = queryTextToQuery $ map (second Just) queryParams + pathBS = encodePath urlPieces q + pure $ TE.decodeUtf8 (LB.toStrict (BB.toLazyByteString pathBS)) -- Not safe, but it will fail during testing (if at all) so should be ok. + +instance ParseRoute site => ParseRoute (E2E site) where + parseRoute = fmap E2ERoute . parseRoute diff --git a/src/Test/Syd/Yesod/Request.hs b/src/Test/Syd/Yesod/Request.hs --- a/src/Test/Syd/Yesod/Request.hs +++ b/src/Test/Syd/Yesod/Request.hs @@ -30,7 +30,7 @@ import Data.Time import GHC.Stack import Network.HTTP.Client as HTTP -import Network.HTTP.Client.Internal (httpRaw) +import Network.HTTP.Client.Internal (httpRaw, toHttpException) import Network.HTTP.Client.MultipartFormData import Network.HTTP.Types as HTTP import Test.Syd @@ -84,7 +84,7 @@ -- > get HomeR -- > statusIs 301 -- > locationShouldBe OverviewR -locationShouldBe :: (ParseRoute site, Show (Route site)) => Route site -> YesodClientM site () +locationShouldBe :: (ParseRoute site, Show (Route site)) => Route site -> YesodClientM localSite () locationShouldBe expected = withLastRequestContext $ do errOrLoc <- getLocation @@ -167,14 +167,21 @@ -- | 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 + baseURI <- asks yesodClientSiteURI 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 + -- We try without the base URI first, just in case: + -- + -- There is an absolute URI in a redirect that we're following + -- OR + -- you want to contact any URI other than the server under test + req <- case parseRequest requestStr of Just req -> pure req + Nothing -> + case parseRequest $ show baseURI <> 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) @@ -205,12 +212,12 @@ Just "application/x-www-form-urlencoded" ) BinaryPostData sb -> pure (RequestBodyBS sb, Nothing) + cj <- State.gets yesodClientStateCookies now <- liftIO getCurrentTime let (req', cj') = insertCookiesIntoRequest ( req - { port = fromIntegral p, -- Safe because it is PortNumber -> Int - method = requestBuilderDataMethod, + { method = requestBuilderDataMethod, requestHeaders = concat [ requestBuilderDataHeaders, @@ -353,21 +360,29 @@ -- | 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. +-- You could make a request to https://example.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' - } - ) + errOrResp <- + liftIO $ + (Right <$> (httpRaw req man >>= traverse (fmap LB.fromChunks . brConsume))) + `catches` [ Handler $ \e -> pure $ Left $ toHttpException req e, + Handler $ \e -> pure $ Left (e :: HttpException) + ] + case errOrResp of + Left err -> liftIO $ expectationFailure $ "HTTPException: " <> displayException err + Right resp -> do + 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) @@ -397,6 +412,13 @@ -- -- (We consider a request a redirect if the status is -- 301, 302, 303, 307 or 308, and the Location header is set.) +-- +-- > it "redirects home" $ do +-- > get RedirectHomeR +-- > statusIs 303 +-- > locationShouldBe HomeR +-- > _ <- followRedirect +-- > statusIs 200 followRedirect :: Yesod site => -- | 'Left' with an error message if not a redirect, 'Right' with the redirected URL if it was diff --git a/sydtest-yesod.cabal b/sydtest-yesod.cabal --- a/sydtest-yesod.cabal +++ b/sydtest-yesod.cabal @@ -5,14 +5,14 @@ -- see: https://github.com/sol/hpack name: sydtest-yesod -version: 0.2.0.1 +version: 0.3.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 +copyright: Copyright (c) 2020-2021 Tom Sydney Kerckhove license: OtherLicense license-file: LICENSE.md build-type: Simple @@ -26,6 +26,7 @@ Test.Syd.Yesod Test.Syd.Yesod.Client Test.Syd.Yesod.Def + Test.Syd.Yesod.E2E Test.Syd.Yesod.Request other-modules: Paths_sydtest_yesod @@ -33,6 +34,7 @@ src build-depends: base >=4.7 && <5 + , binary , blaze-builder , bytestring , case-insensitive @@ -40,9 +42,11 @@ , cookie , exceptions , http-client + , http-client-tls , http-types , mtl , network + , network-uri , pretty-show , sydtest >=0.3.0.0 , sydtest-wai @@ -106,5 +110,6 @@ , sydtest-yesod , text , yesod + , yesod-core , yesod-form default-language: Haskell2010 diff --git a/test/Test/Syd/YesodSpec.hs b/test/Test/Syd/YesodSpec.hs --- a/test/Test/Syd/YesodSpec.hs +++ b/test/Test/Syd/YesodSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Test.Syd.YesodSpec (spec) where @@ -6,9 +7,15 @@ import Test.Syd import Test.Syd.Yesod import Test.Syd.Yesod.App +import Yesod.Core spec :: Spec spec = yesodSpec App $ do + describe "Local" blogSpec + describe "E2E" $ localToE2ESpec blogSpec + +blogSpec :: (Yesod site, RedirectUrl site (Route App)) => YesodSpec site +blogSpec = do it "responds 200 OK to GET HomeR" $ do get HomeR statusIs 200