{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- Because of webdriver using dangerous constructors
{-# OPTIONS_GHC -fno-warn-incomplete-record-updates #-}
-- For the undefined trick
{-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-}

-- | This is a helper module for 'Test.Syd.Webdriver' to let you use Yesod
-- routes to define webdriver tests.
module Test.Syd.Webdriver.Yesod
  ( -- * Defining webdriver tests with yesod
    webdriverYesodSpec,

    -- * Implementing webdriver tests with yesod
    openRoute,
    openRouteWithParams,
    getCurrentRoute,
    currentRouteShouldBe,

    -- ** Finding elements by I18N Messages
    getLinkTextI,
    findElemByLinkTextI,
    findElemByPartialLinkTextI,
    findElemByButtonTextI,
  )
where

import Control.Arrow
import Control.Monad.Reader
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as LB
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP
import Network.URI
import Test.Syd
import Test.Syd.Wai
import Test.Syd.Webdriver
import Test.Syd.Yesod
import Test.WebDriver as WD hiding (setWindowSize)
import qualified Yesod

-- | Run webdriver tests given a 'SetupFunc' for your app.
webdriverYesodSpec ::
  Yesod.YesodDispatch app =>
  (HTTP.Manager -> SetupFunc app) ->
  WebdriverSpec app ->
  Spec
webdriverYesodSpec :: forall app.
YesodDispatch app =>
(Manager -> SetupFunc app) -> WebdriverSpec app -> Spec
webdriverYesodSpec Manager -> SetupFunc app
appSetupFunc = forall app.
(Manager -> SetupFunc (URI, app)) -> WebdriverSpec app -> Spec
webdriverSpec forall a b. (a -> b) -> a -> b
$ \Manager
man -> do
  app
site <- Manager -> SetupFunc app
appSetupFunc Manager
man
  YesodClient {app
URI
Manager
yesodClientSite :: forall site. YesodClient site -> site
yesodClientManager :: forall site. YesodClient site -> Manager
yesodClientSiteURI :: forall site. YesodClient site -> URI
yesodClientSiteURI :: URI
yesodClientManager :: Manager
yesodClientSite :: app
..} <- forall site.
YesodDispatch site =>
Manager -> site -> SetupFunc (YesodClient site)
yesodClientSetupFunc Manager
man app
site
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI
yesodClientSiteURI, app
yesodClientSite)

-- | Open a given yesod 'Route'
openRoute ::
  Yesod.RenderRoute app =>
  Route app ->
  WebdriverTestM app ()
openRoute :: forall app. RenderRoute app => Route app -> WebdriverTestM app ()
openRoute Route app
route = forall app.
RenderRoute app =>
Route app -> [(Text, Text)] -> WebdriverTestM app ()
openRouteWithParams Route app
route []

-- | Open a given yesod 'Route' with parameters
openRouteWithParams ::
  Yesod.RenderRoute app =>
  Route app ->
  [(Text, Text)] ->
  WebdriverTestM app ()
openRouteWithParams :: forall app.
RenderRoute app =>
Route app -> [(Text, Text)] -> WebdriverTestM app ()
openRouteWithParams Route app
route [(Text, Text)]
extraParams = do
  let ([Text]
pathPieces, [(Text, Text)]
queryParams) = forall a. RenderRoute a => Route a -> ([Text], [(Text, Text)])
Yesod.renderRoute Route app
route
  let q :: Query
q = QueryText -> Query
queryTextToQuery forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. a -> Maybe a
Just) ([(Text, Text)]
queryParams forall a. Semigroup a => a -> a -> a
<> [(Text, Text)]
extraParams)
  let pathBSBuilder :: Builder
pathBSBuilder = [Text] -> Query -> Builder
encodePath [Text]
pathPieces Query
q
  let pathBS :: ByteString
pathBS = ByteString -> ByteString
LB.toStrict (Builder -> ByteString
BB.toLazyByteString Builder
pathBSBuilder)
  case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
pathBS of
    Left UnicodeException
err ->
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines
            [ [String] -> String
unwords
                [ String
"Failed to decode path from bytestring:",
                  forall a. Show a => a -> String
show ByteString
pathBS
                ],
              forall a. Show a => a -> String
show UnicodeException
err
            ]
    Right Text
t -> forall app. String -> WebdriverTestM app ()
openPath forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t

-- | Get the current 'Route'
getCurrentRoute ::
  Yesod.ParseRoute app =>
  WebdriverTestM app (Route app)
getCurrentRoute :: forall app. ParseRoute app => WebdriverTestM app (Route app)
getCurrentRoute = do
  String
currentUrl <- forall (wd :: * -> *). (HasCallStack, WebDriver wd) => wd String
getCurrentURL
  case String -> Maybe URI
parseURI String
currentUrl of
    Maybe URI
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"Should have been able to parse the current url into an URI: " forall a. Semigroup a => a -> a -> a
<> String
currentUrl
    Just URI {String
Maybe URIAuth
uriScheme :: URI -> String
uriAuthority :: URI -> Maybe URIAuth
uriPath :: URI -> String
uriQuery :: URI -> String
uriFragment :: URI -> String
uriFragment :: String
uriQuery :: String
uriPath :: String
uriAuthority :: Maybe URIAuth
uriScheme :: String
..} -> do
      let ([Text]
textPieces, Query
query_) = ByteString -> ([Text], Query)
HTTP.decodePath forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
uriPath, String
uriQuery]
          queryPieces :: [(Text, Text)]
queryPieces = forall a b. (a -> b) -> [a] -> [b]
map forall {b} {a}. IsString b => (a, Maybe b) -> (a, b)
unJust forall a b. (a -> b) -> a -> b
$ Query -> QueryText
HTTP.queryToQueryText Query
query_
      case forall a.
ParseRoute a =>
([Text], [(Text, Text)]) -> Maybe (Route a)
Yesod.parseRoute ([Text]
textPieces, [(Text, Text)]
queryPieces) of
        Maybe (Route app)
Nothing ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$
              [String] -> String
unlines
                [ String
"Should have been able to parse an App route from " forall a. Semigroup a => a -> a -> a
<> String
currentUrl,
                  forall a. Show a => a -> String
ppShow ([Text]
textPieces, [(Text, Text)]
queryPieces)
                ]
        Just Route app
route -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Route app
route
  where
    unJust :: (a, Maybe b) -> (a, b)
unJust (a
a, Just b
b) = (a
a, b
b)
    unJust (a
a, Maybe b
Nothing) = (a
a, b
"")

-- | Get the current 'Route' and check that it equals the given route
currentRouteShouldBe ::
  (Show (Route app), Yesod.ParseRoute app) =>
  Route app ->
  WebdriverTestM app ()
currentRouteShouldBe :: forall app.
(Show (Route app), ParseRoute app) =>
Route app -> WebdriverTestM app ()
currentRouteShouldBe Route app
expected = do
  Route app
actual <- forall app. ParseRoute app => WebdriverTestM app (Route app)
getCurrentRoute
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Route app
actual forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Route app
expected

-- | Get the link text for a given I18N message.
--
-- This will only work if the language hasn't been set.
getLinkTextI :: Yesod.RenderMessage app message => message -> WebdriverTestM app Text
getLinkTextI :: forall app message.
RenderMessage app message =>
message -> WebdriverTestM app Text
getLinkTextI message
message = do
  app
y <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall app. WebdriverTestEnv app -> app
webdriverTestEnvApp
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
Yesod.renderMessage app
y [] message
message

-- | Find an 'Element', 'ByLinkText' the text obtained by 'getLinkTextI'
findElemByLinkTextI :: Yesod.RenderMessage app message => message -> WebdriverTestM app Element
findElemByLinkTextI :: forall app message.
RenderMessage app message =>
message -> WebdriverTestM app Element
findElemByLinkTextI message
message = forall app message.
RenderMessage app message =>
message -> WebdriverTestM app Text
getLinkTextI message
message forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
Selector -> wd Element
findElem forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Selector
ByLinkText

-- | Find an 'Element', 'ByPartialLinkText' the text obtained by 'getLinkTextI'
findElemByPartialLinkTextI :: Yesod.RenderMessage app message => message -> WebdriverTestM app Element
findElemByPartialLinkTextI :: forall app message.
RenderMessage app message =>
message -> WebdriverTestM app Element
findElemByPartialLinkTextI message
message = forall app message.
RenderMessage app message =>
message -> WebdriverTestM app Text
getLinkTextI message
message forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
Selector -> wd Element
findElem forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Selector
ByPartialLinkText

-- | Find an 'Element', 'ByLinkText' the text obtained by 'getLinkTextI'
findElemByButtonTextI :: Yesod.RenderMessage app message => message -> WebdriverTestM app Element
findElemByButtonTextI :: forall app message.
RenderMessage app message =>
message -> WebdriverTestM app Element
findElemByButtonTextI message
message = do
  Text
t <- forall app message.
RenderMessage app message =>
message -> WebdriverTestM app Text
getLinkTextI message
message
  forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
Selector -> wd Element
findElem forall a b. (a -> b) -> a -> b
$ Text -> Selector
ByXPath forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Text
"//button[normalize-space()=\"", Text
t, Text
"\"]"]