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) 2022 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/src/Test/Syd/Webdriver.hs b/src/Test/Syd/Webdriver.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Webdriver.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NumericUnderscores #-} +{-# 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 #-} + +module Test.Syd.Webdriver + ( -- * Defining webdriver tests + WebdriverSpec, + webdriverSpec, + WebdriverTestM (..), + runWebdriverTestM, + WebdriverTestEnv (..), + webdriverTestEnvSetupFunc, + + -- * Writing webdriver tests + openPath, + setWindowSize, + + -- * Running a selenium server + SeleniumServerHandle (..), + seleniumServerSetupFunc, + ) +where + +import Control.Monad.Base +import Control.Monad.Reader +import Control.Monad.Trans.Control +import Data.Aeson as JSON +import GHC.Stack +import Network.HTTP.Client as HTTP +import Network.Socket +import Network.Socket.Free +import Network.Socket.Wait as Port +import Network.URI +import Path +import Path.IO +import System.Exit +import System.Process.Typed +import Test.Syd +import Test.Syd.Path +import Test.Syd.Process.Typed +import Test.Syd.Wai +import Test.WebDriver as WD hiding (setWindowSize) +import Test.WebDriver.Class (WebDriver (..)) +import qualified Test.WebDriver.Commands.Internal as WD +import qualified Test.WebDriver.JSON as WD +import Test.WebDriver.Session (WDSessionState (..)) + +-- | Type synonym for webdriver tests +type WebdriverSpec app = TestDef '[SeleniumServerHandle, HTTP.Manager] (WebdriverTestEnv app) + +-- | A monad for webdriver tests. +-- This instantiates the 'WebDriver' class, as well as the 'IsTest' class. +newtype WebdriverTestM app a = WebdriverTestM + { unWebdriverTestM :: ReaderT (WebdriverTestEnv app) WD a + } + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadReader (WebdriverTestEnv app), + -- We don't want 'MonadBaseControl IO' or 'MonadBase IO', but we have to + -- because webdriver uses them. + MonadBaseControl IO, + MonadBase IO + ) + +data WebdriverTestEnv app = WebdriverTestEnv + { -- | The base url of the app we test, so that we can test external sites just like local ones. + webdriverTestEnvURI :: !URI, + -- | The webdriver configuration + webdriverTestEnvConfig :: !WDConfig, + -- | The app that we'll test. + -- + -- You can put any piece of data here. In the case of yesod tests, we'll put an @App@ here. + webdriverTestEnvApp :: !app + } + +instance WDSessionState (WebdriverTestM app) where + getSession = WebdriverTestM getSession + putSession = WebdriverTestM . putSession + +instance WebDriver (WebdriverTestM app) where + doCommand m p a = WebdriverTestM $ doCommand m p a + +instance IsTest (WebdriverTestM app ()) where + type Arg1 (WebdriverTestM app ()) = () + type Arg2 (WebdriverTestM app ()) = WebdriverTestEnv app + runTest wdTestFunc = runTest (\() wdte -> runWebdriverTestM wdte wdTestFunc) + +instance IsTest (WebdriverTestM app (GoldenTest a)) where + type Arg1 (WebdriverTestM app (GoldenTest a)) = () + type Arg2 (WebdriverTestM app (GoldenTest a)) = WebdriverTestEnv app + runTest wdTestFunc = runTest (\() wdte -> runWebdriverTestM wdte wdTestFunc) + +-- | Run a webdriver test. +runWebdriverTestM :: WebdriverTestEnv app -> WebdriverTestM app a -> IO a +runWebdriverTestM env (WebdriverTestM func) = WD.runSession (webdriverTestEnvConfig env) $ + WD.finallyClose $ do + setImplicitWait 10_000 + setScriptTimeout 10_000 + setPageLoadTimeout 10_000 + runReaderT func env + +-- | Open a page on the URI in the 'WebdriverTestEnv'. +openPath :: String -> WebdriverTestM app () +openPath p = do + uri <- asks webdriverTestEnvURI + let url = show uri <> p + openPage url + +-- We have to override this because it returns something. +-- So we remove the 'noReturn'. +setWindowSize :: + (HasCallStack, WebDriver wd) => + -- | (Width, Height) + (Word, Word) -> + wd () +setWindowSize (w, h) = + WD.ignoreReturn $ + WD.doWinCommand methodPost currentWindow "/size" $ + object ["width" .= w, "height" .= h] + +webdriverSpec :: + (HTTP.Manager -> SetupFunc (URI, app)) -> + WebdriverSpec app -> + Spec +webdriverSpec appSetupFunc = + managerSpec + . modifyMaxSuccess (`div` 50) + . setupAroundWith' (\man () -> appSetupFunc man) + . setupAroundAll seleniumServerSetupFunc + . webdriverTestEnvSpec + +webdriverTestEnvSpec :: + TestDef '[SeleniumServerHandle, HTTP.Manager] (WebdriverTestEnv app) -> + TestDef '[SeleniumServerHandle, HTTP.Manager] (URI, app) +webdriverTestEnvSpec = setupAroundWith' go2 . setupAroundWith' go1 + where + go1 :: + SeleniumServerHandle -> + (SeleniumServerHandle -> SetupFunc (WebdriverTestEnv app)) -> + SetupFunc (WebdriverTestEnv app) + go1 ssh func = func ssh + go2 :: + HTTP.Manager -> + (URI, app) -> + SetupFunc (SeleniumServerHandle -> SetupFunc (WebdriverTestEnv app)) + go2 man (uri, app) = pure $ \ssh -> webdriverTestEnvSetupFunc ssh man uri app + +-- | Set up a 'WebdriverTestEnv' for your app by readying a webdriver session +webdriverTestEnvSetupFunc :: + SeleniumServerHandle -> + HTTP.Manager -> + URI -> + app -> + SetupFunc (WebdriverTestEnv app) +webdriverTestEnvSetupFunc SeleniumServerHandle {..} manager uri app = do + chromeExecutable <- liftIO $ do + chromeFile <- parseRelFile "chromium" + mExecutable <- findExecutable chromeFile + case mExecutable of + Nothing -> die "No chromium found on PATH." + Just executable -> pure executable + + userDataDir <- tempDirSetupFunc "chromium-user-data" + + let browser = + chrome + { chromeOptions = + [ "--user-data-dir=" <> fromAbsDir userDataDir, + "--headless", + "--no-sandbox", -- Bypass OS security model to run on nix as well + "--disable-dev-shm-usage", -- Overcome limited resource problem + "--disable-gpu", + "--use-gl=angle", + "--use-angle=swiftshader", + "--window-size=1920,1080" + ], + chromeBinary = Just $ fromAbsFile chromeExecutable + } + let caps = + WD.defaultCaps + { browser = browser + } + let webdriverTestEnvConfig = + WD.defaultConfig + { wdPort = (fromIntegral :: PortNumber -> Int) seleniumServerHandlePort, + wdHTTPManager = Just manager, + wdCapabilities = caps + } + let webdriverTestEnvURI = uri + webdriverTestEnvApp = app + pure WebdriverTestEnv {..} + +data SeleniumServerHandle = SeleniumServerHandle + { seleniumServerHandlePort :: PortNumber + } + +-- | Run, and clean up, a selenium server +seleniumServerSetupFunc :: SetupFunc SeleniumServerHandle +seleniumServerSetupFunc = do + tempDir <- tempDirSetupFunc "selenium-server" + portInt <- liftIO getFreePort + let processConfig = + setStdout nullStream $ + setStderr nullStream $ + setWorkingDir (fromAbsDir tempDir) $ + proc + "selenium-server" + [ "-port", + show portInt + ] + _ <- typedProcessSetupFunc processConfig + liftIO $ Port.wait "127.0.0.1" portInt + let seleniumServerHandlePort = fromIntegral portInt + pure SeleniumServerHandle {..} diff --git a/sydtest-webdriver.cabal b/sydtest-webdriver.cabal new file mode 100644 --- /dev/null +++ b/sydtest-webdriver.cabal @@ -0,0 +1,64 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.6. +-- +-- see: https://github.com/sol/hpack + +name: sydtest-webdriver +version: 0.0.0.0 +synopsis: A webdriver companion library for sydtest +category: Testing +license: OtherLicense +license-file: LICENSE.md +build-type: Simple +extra-source-files: + LICENSE.md + +library + exposed-modules: + Test.Syd.Webdriver + other-modules: + Paths_sydtest_webdriver + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , http-client + , http-types + , monad-control + , mtl + , network + , network-uri + , path + , path-io + , port-utils + , sydtest + , sydtest-typed-process + , sydtest-wai + , transformers-base + , typed-process + , webdriver + default-language: Haskell2010 + +test-suite sydtest-webdriver-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Syd.Webdriver.App + Test.Syd.WebdriverSpec + Paths_sydtest_webdriver + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + sydtest-discover:sydtest-discover + build-depends: + base >=4.7 && <5 + , http-types + , network-uri + , sydtest + , sydtest-wai + , sydtest-webdriver + , wai + 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/Webdriver/App.hs b/test/Test/Syd/Webdriver/App.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Webdriver/App.hs @@ -0,0 +1,9 @@ +module Test.Syd.Webdriver.App where + +import Network.HTTP.Types as HTTP +import Network.Wai as Wai + +exampleApplication :: Wai.Application +exampleApplication req sendResp = do + lb <- strictRequestBody req + sendResp $ responseLBS HTTP.ok200 (requestHeaders req) lb diff --git a/test/Test/Syd/WebdriverSpec.hs b/test/Test/Syd/WebdriverSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/WebdriverSpec.hs @@ -0,0 +1,20 @@ +module Test.Syd.WebdriverSpec (spec) where + +import Network.URI +import Test.Syd +import Test.Syd.Wai +import Test.Syd.Webdriver +import Test.Syd.Webdriver.App + +spec :: Spec +spec = exampleAppSpec $ do + it "can navigate to home" $ + openPath "/" + +exampleAppSpec :: WebdriverSpec () -> Spec +exampleAppSpec = webdriverSpec $ \_ -> do + portNumber <- applicationSetupFunc exampleApplication + let uriStr = "http://127.0.0.1:" <> show portNumber + case parseURI uriStr of + Nothing -> liftIO $ expectationFailure $ "Failed to parse uri as string: " <> show uriStr + Just uri -> pure (uri, ())