{-# 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,
  )
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 :: (Manager -> SetupFunc app) -> WebdriverSpec app -> Spec
webdriverYesodSpec Manager -> SetupFunc app
appSetupFunc = (Manager -> SetupFunc (URI, app)) -> WebdriverSpec app -> Spec
forall app.
(Manager -> SetupFunc (URI, app)) -> WebdriverSpec app -> Spec
webdriverSpec ((Manager -> SetupFunc (URI, app)) -> WebdriverSpec app -> Spec)
-> (Manager -> SetupFunc (URI, app)) -> WebdriverSpec app -> Spec
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
..} <- Manager -> app -> SetupFunc (YesodClient app)
forall site.
YesodDispatch site =>
Manager -> site -> SetupFunc (YesodClient site)
yesodClientSetupFunc Manager
man app
site
  (URI, app) -> SetupFunc (URI, app)
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 :: Route app -> WebdriverTestM app ()
openRoute Route app
route = Route app -> [(Text, Text)] -> WebdriverTestM app ()
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 :: Route app -> [(Text, Text)] -> WebdriverTestM app ()
openRouteWithParams Route app
route [(Text, Text)]
extraParams = do
  let ([Text]
pathPieces, [(Text, Text)]
queryParams) = Route app -> ([Text], [(Text, Text)])
forall a. RenderRoute a => Route a -> ([Text], [(Text, Text)])
Yesod.renderRoute Route app
route
  let q :: Query
q = QueryText -> Query
queryTextToQuery (QueryText -> Query) -> QueryText -> Query
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> (Text, Maybe Text)) -> [(Text, Text)] -> QueryText
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Maybe Text) -> (Text, Text) -> (Text, Maybe Text)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Text -> Maybe Text
forall a. a -> Maybe a
Just) ([(Text, Text)]
queryParams [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
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 ->
      IO () -> WebdriverTestM app ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WebdriverTestM app ()) -> IO () -> WebdriverTestM app ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall a. HasCallStack => String -> IO a
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines
            [ [String] -> String
unwords
                [ String
"Failed to decode path from bytestring:",
                  ByteString -> String
forall a. Show a => a -> String
show ByteString
pathBS
                ],
              UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err
            ]
    Right Text
t -> String -> WebdriverTestM app ()
forall app. String -> WebdriverTestM app ()
openPath (String -> WebdriverTestM app ())
-> String -> WebdriverTestM app ()
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 :: WebdriverTestM app (Route app)
getCurrentRoute = do
  String
currentUrl <- WebdriverTestM app String
forall (wd :: * -> *). (HasCallStack, WebDriver wd) => wd String
getCurrentURL
  case String -> Maybe URI
parseURI String
currentUrl of
    Maybe URI
Nothing -> IO (Route app) -> WebdriverTestM app (Route app)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Route app) -> WebdriverTestM app (Route app))
-> IO (Route app) -> WebdriverTestM app (Route app)
forall a b. (a -> b) -> a -> b
$ String -> IO (Route app)
forall a. HasCallStack => String -> IO a
expectationFailure (String -> IO (Route app)) -> String -> IO (Route app)
forall a b. (a -> b) -> a -> b
$ String
"Should have been able to parse the current url into an URI: " String -> String -> String
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 (ByteString -> ([Text], Query)) -> ByteString -> ([Text], Query)
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
uriPath, String
uriQuery]
          queryPieces :: [(Text, Text)]
queryPieces = ((Text, Maybe Text) -> (Text, Text)) -> QueryText -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Maybe Text) -> (Text, Text)
forall b a. IsString b => (a, Maybe b) -> (a, b)
unJust (QueryText -> [(Text, Text)]) -> QueryText -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Query -> QueryText
HTTP.queryToQueryText Query
query_
      case ([Text], [(Text, Text)]) -> Maybe (Route app)
forall a.
ParseRoute a =>
([Text], [(Text, Text)]) -> Maybe (Route a)
Yesod.parseRoute ([Text]
textPieces, [(Text, Text)]
queryPieces) of
        Maybe (Route app)
Nothing ->
          IO (Route app) -> WebdriverTestM app (Route app)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Route app) -> WebdriverTestM app (Route app))
-> IO (Route app) -> WebdriverTestM app (Route app)
forall a b. (a -> b) -> a -> b
$
            String -> IO (Route app)
forall a. HasCallStack => String -> IO a
expectationFailure (String -> IO (Route app)) -> String -> IO (Route app)
forall a b. (a -> b) -> a -> b
$
              [String] -> String
unlines
                [ String
"Should have been able to parse an App route from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
currentUrl,
                  ([Text], [(Text, Text)]) -> String
forall a. Show a => a -> String
ppShow ([Text]
textPieces, [(Text, Text)]
queryPieces)
                ]
        Just Route app
route -> Route app -> WebdriverTestM app (Route app)
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
"")