From aac96e2e520a4fca97bccd3403721dc0036b026f Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Tue, 19 Apr 2022 14:31:47 +0200 Subject: [PATCH] First version of sydtest-webdriver, sydtest-webdriver-yesod and sydtest-webdriver-screenshot --- nix/fonts-conf.nix | 46 ++++ nix/fonts.xsl | 30 +++ nix/overlay.nix | 30 +++ shell.nix | 5 + stack.yaml | 4 + sydtest-wai/sydtest-wai.cabal | 2 +- sydtest-webdriver-screenshot/.gitignore | 1 + sydtest-webdriver-screenshot/LICENSE.md | 5 + sydtest-webdriver-screenshot/package.yaml | 48 ++++ .../src/Test/Syd/Webdriver/Screenshot.hs | 90 +++++++ .../sydtest-webdriver-screenshot.cabal | 63 +++++ sydtest-webdriver-screenshot/test/Spec.hs | 1 + .../test/Test/Syd/Webdriver/Screenshot/App.hs | 14 ++ .../test/Test/Syd/Webdriver/ScreenshotSpec.hs | 22 ++ .../test_resources/home.png | Bin 0 -> 12366 bytes sydtest-webdriver-yesod/LICENSE.md | 5 + sydtest-webdriver-yesod/package.yaml | 52 ++++ .../src/Test/Syd/Webdriver/Yesod.hs | 108 +++++++++ .../sydtest-webdriver-yesod.cabal | 65 +++++ sydtest-webdriver-yesod/test/Spec.hs | 1 + .../test/Test/Syd/Webdriver/Yesod/App.hs | 28 +++ .../test/Test/Syd/Webdriver/YesodSpec.hs | 20 ++ sydtest-webdriver/LICENSE.md | 5 + sydtest-webdriver/package.yaml | 54 +++++ sydtest-webdriver/src/Test/Syd/Webdriver.hs | 228 ++++++++++++++++++ sydtest-webdriver/sydtest-webdriver.cabal | 67 +++++ sydtest-webdriver/test/Spec.hs | 1 + .../test/Test/Syd/Webdriver/App.hs | 9 + .../test/Test/Syd/WebdriverSpec.hs | 20 ++ sydtest/package.yaml | 1 - sydtest/sydtest.cabal | 1 - 31 files changed, 1023 insertions(+), 3 deletions(-) create mode 100644 nix/fonts-conf.nix create mode 100644 nix/fonts.xsl create mode 100644 sydtest-webdriver-screenshot/.gitignore create mode 100644 sydtest-webdriver-screenshot/LICENSE.md create mode 100644 sydtest-webdriver-screenshot/package.yaml create mode 100644 sydtest-webdriver-screenshot/src/Test/Syd/Webdriver/Screenshot.hs create mode 100644 sydtest-webdriver-screenshot/sydtest-webdriver-screenshot.cabal create mode 100644 sydtest-webdriver-screenshot/test/Spec.hs create mode 100644 sydtest-webdriver-screenshot/test/Test/Syd/Webdriver/Screenshot/App.hs create mode 100644 sydtest-webdriver-screenshot/test/Test/Syd/Webdriver/ScreenshotSpec.hs create mode 100644 sydtest-webdriver-screenshot/test_resources/home.png create mode 100644 sydtest-webdriver-yesod/LICENSE.md create mode 100644 sydtest-webdriver-yesod/package.yaml create mode 100644 sydtest-webdriver-yesod/src/Test/Syd/Webdriver/Yesod.hs create mode 100644 sydtest-webdriver-yesod/sydtest-webdriver-yesod.cabal create mode 100644 sydtest-webdriver-yesod/test/Spec.hs create mode 100644 sydtest-webdriver-yesod/test/Test/Syd/Webdriver/Yesod/App.hs create mode 100644 sydtest-webdriver-yesod/test/Test/Syd/Webdriver/YesodSpec.hs create mode 100644 sydtest-webdriver/LICENSE.md create mode 100644 sydtest-webdriver/package.yaml create mode 100644 sydtest-webdriver/src/Test/Syd/Webdriver.hs create mode 100644 sydtest-webdriver/sydtest-webdriver.cabal create mode 100644 sydtest-webdriver/test/Spec.hs create mode 100644 sydtest-webdriver/test/Test/Syd/Webdriver/App.hs create mode 100644 sydtest-webdriver/test/Test/Syd/WebdriverSpec.hs diff --git a/nix/fonts-conf.nix b/nix/fonts-conf.nix new file mode 100644 index 00000000..656d7c71 --- /dev/null +++ b/nix/fonts-conf.nix @@ -0,0 +1,46 @@ +{ lib +, stdenv +, libxslt +, fontconfig +, lndir +, roboto +, twitter-color-emoji +}: + +# Chromium reads FONTCONFIG_SYSROOT, and uses that instead of / for all font-related filepaths +# Chromium also reads FONTCONFIG_PATH, but always also reads FONTCONFIG_SYSROOT/etc/fonts/font.conf so you cannot override fonts, only add to them +# so here we have to nix build of something that looks like / with everything font-related, (which I could only do based on the strace output showing me which things it tries to read in FONTCONFIG_SYSROOT) +# and then set FONTCONFIG_SYSROOT to that. +# and I only found FONTCONFIG_SYSROOT by looking through the chromium source code +let + fonts = { + "roboto" = roboto; + "twitter" = twitter-color-emoji; + }; + fontNames = builtins.attrNames fonts; +in +stdenv.mkDerivation { + name = "fonts-config"; + unpackPhase = "true"; + nativeBuildInputs = [ libxslt lndir ]; + buildInputs = [ fontconfig ]; + inherit fontNames; + installPhase = + let singleDir = name: fontPkg: '' + echo ${fontPkg} + ln -s ${fontPkg} $out/etc/fonts/${name} + ''; + in + '' + mkdir -p $out/etc/fonts + + ${lib.concatStringsSep "\n" (lib.mapAttrsToList singleDir fonts)} + + mkdir -p $out/fonts + xsltproc \ + --stringparam fontNames "$fontNames" \ + --path ${fontconfig.out}/share/xml/fontconfig \ + ${./fonts.xsl} ${fontconfig.out}/etc/fonts/fonts.conf \ + > $out/etc/fonts/fonts.conf + ''; +} diff --git a/nix/fonts.xsl b/nix/fonts.xsl new file mode 100644 index 00000000..e75a5782 --- /dev/null +++ b/nix/fonts.xsl @@ -0,0 +1,30 @@ + + + + + + + + + + + + + fontconfig + + + + /etc/fonts//share/fonts + + + + + + + diff --git a/nix/overlay.nix b/nix/overlay.nix index d8568332..ad3bee1b 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -78,6 +78,36 @@ with final.haskell.lib; unset NIX_REDIRECTS LD_PRELOAD ''; }); + "sydtest-webdriver" = overrideCabal (sydtestPkg "sydtest-webdriver") (old: { + testDepends = (old.testDepends or [ ]) ++ (with final; [ + chromedriver + chromium + selenium-server-standalone + ]); + preConfigure = (old.preConfigure or "") + '' + export FONTCONFIG_SYSROOT=${final.callPackage ./fonts-conf.nix {}} + ''; + }); + "sydtest-webdriver-screenshot" = overrideCabal (sydtestPkg "sydtest-webdriver-screenshot") (old: { + testDepends = (old.testDepends or [ ]) ++ (with final; [ + chromedriver + chromium + selenium-server-standalone + ]); + preConfigure = (old.preConfigure or "") + '' + export FONTCONFIG_SYSROOT=${final.callPackage ./fonts-conf.nix {}} + ''; + }); + "sydtest-webdriver-yesod" = overrideCabal (sydtestPkg "sydtest-webdriver-yesod") (old: { + testDepends = (old.testDepends or [ ]) ++ (with final; [ + chromedriver + chromium + selenium-server-standalone + ]); + preConfigure = (old.preConfigure or "") + '' + export FONTCONFIG_SYSROOT=${final.callPackage ./fonts-conf.nix {}} + ''; + }); "sydtest-misbehaved-test-suite" = sydtestPkg "sydtest-misbehaved-test-suite"; }; diff --git a/shell.nix b/shell.nix index c4fc34aa..ee9986a8 100644 --- a/shell.nix +++ b/shell.nix @@ -1,20 +1,25 @@ let pkgs = import ./nix/pkgs.nix { }; pre-commit = import ./nix/pre-commit.nix; + fontconfigDir = pkgs.callPackage ./nix/fonts-conf.nix { }; in pkgs.haskell.lib.buildStackProject { name = "sydtest-shell"; buildInputs = with pkgs; [ + chromedriver + chromium coreutils mongodb niv postgresql rabbitmq-server redis + selenium-server-standalone zlib ] ++ pre-commit.tools; shellHook = '' export TMPDIR=/tmp ${pre-commit.check.shellHook} + export FONTCONFIG_SYSROOT=${fontconfigDir} ''; } diff --git a/stack.yaml b/stack.yaml index 5a5af534..96eb797c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -16,9 +16,13 @@ packages: - sydtest-servant - sydtest-typed-process - sydtest-wai +- sydtest-webdriver +- sydtest-webdriver-screenshot +- sydtest-webdriver-yesod - sydtest-yesod - sydtest-misbehaved-test-suite + extra-deps: - envparse-0.4.1@sha256:989902e6368532548f61de1fa245ad2b39176cddd8743b20071af519a709ce30,2842 - github: NorfairKing/safe-coloured-text diff --git a/sydtest-wai/sydtest-wai.cabal b/sydtest-wai/sydtest-wai.cabal index cea8969f..76ed0032 100644 --- a/sydtest-wai/sydtest-wai.cabal +++ b/sydtest-wai/sydtest-wai.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack diff --git a/sydtest-webdriver-screenshot/.gitignore b/sydtest-webdriver-screenshot/.gitignore new file mode 100644 index 00000000..b30ed6c1 --- /dev/null +++ b/sydtest-webdriver-screenshot/.gitignore @@ -0,0 +1 @@ +screenshot-comparison diff --git a/sydtest-webdriver-screenshot/LICENSE.md b/sydtest-webdriver-screenshot/LICENSE.md new file mode 100644 index 00000000..bfc3c11e --- /dev/null +++ b/sydtest-webdriver-screenshot/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/sydtest-webdriver-screenshot/package.yaml b/sydtest-webdriver-screenshot/package.yaml new file mode 100644 index 00000000..cc7835fd --- /dev/null +++ b/sydtest-webdriver-screenshot/package.yaml @@ -0,0 +1,48 @@ +name: sydtest-webdriver-screenshot +version: 0.0.0.0 +license: OtherLicense +license-file: LICENSE.md +author: "Tom Sydney Kerckhove" +maintainer: "syd@cs-syd.eu" +copyright: "Copyright (c) 2022 Tom Sydney Kerckhove" +category: Testing +synopsis: A webdriver screenshot companion library for sydtest + +extra-source-files: +- LICENSE.md + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + dependencies: + - JuicyPixels + - bytestring + - http-types + - mtl + - network-uri + - path + - path-io + - sydtest + - sydtest-wai + - sydtest-webdriver + - webdriver + +tests: + sydtest-webdriver-screenshot-test: + main: Spec.hs + source-dirs: test + build-tools: sydtest-discover + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - http-types + - network-uri + - sydtest + - sydtest-wai + - sydtest-webdriver + - sydtest-webdriver-screenshot + - wai diff --git a/sydtest-webdriver-screenshot/src/Test/Syd/Webdriver/Screenshot.hs b/sydtest-webdriver-screenshot/src/Test/Syd/Webdriver/Screenshot.hs new file mode 100644 index 00000000..fc3a1eef --- /dev/null +++ b/sydtest-webdriver-screenshot/src/Test/Syd/Webdriver/Screenshot.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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.Screenshot where + +import Codec.Picture as Picture +import Control.Monad.Reader +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import Path +import Path.IO +import System.Exit +import Test.Syd +import Test.Syd.Webdriver +import Test.WebDriver as WD + +-- | A screenshot with location +data Screenshot = Screenshot + { -- | File location for comparisons + screenshotFile :: !(Path Abs File), + -- | Decoded image + screenshotImage :: !(Picture.Image PixelRGB8) + } + +-- | Take a screenshot and turn it into a golden test. +goldenScreenshotHere :: FilePath -> WebdriverTestM app (GoldenTest Screenshot) +goldenScreenshotHere fp = pureGoldenScreenshot fp <$> WD.screenshot + +-- | Make a golden test for a given screenshot in lazy 'LB.ByteString' form. +pureGoldenScreenshot :: FilePath -> LB.ByteString -> GoldenTest Screenshot +pureGoldenScreenshot fp contents = + GoldenTest + { goldenTestRead = do + relFile <- parseRelFile fp + currentDir <- getCurrentDir + let resolvedFile = currentDir relFile + mContents <- forgivingAbsence $ SB.readFile $ fromAbsFile resolvedFile + forM mContents $ \cts -> do + case decodePng cts of + Left err -> die err + Right dynamicImage -> + pure $ + Screenshot + { screenshotFile = resolvedFile, + screenshotImage = convertRGB8 dynamicImage + }, + goldenTestProduce = do + let sb = LB.toStrict contents + case decodePng sb of + Left err -> expectationFailure $ "Could not parse screenshot as png: " <> err + Right dynamicImage -> do + let image = convertRGB8 dynamicImage + relFile <- parseRelFile fp + tempDir <- resolveDir' "screenshot-comparison" + let tempFile = tempDir relFile + ensureDir $ parent tempFile + -- Write it to a file so we can compare it if it differs. + writePng (fromAbsFile tempFile) image + pure $ + Screenshot + { screenshotFile = tempFile, + screenshotImage = image + }, + goldenTestWrite = \(Screenshot _ actual) -> do + relFile <- parseRelFile fp + currentDir <- getCurrentDir + let resolvedFile = currentDir relFile + ensureDir $ parent resolvedFile + writePng (fromAbsFile resolvedFile) actual, + goldenTestCompare = \(Screenshot actualPath actual) (Screenshot expectedPath expected) -> + if actual == expected + then Nothing + else + Just $ + ExpectationFailed $ + unlines + [ "Screenshots differ.", + "expected: " <> fromAbsFile expectedPath, + "actual: " <> fromAbsFile actualPath + ] + } diff --git a/sydtest-webdriver-screenshot/sydtest-webdriver-screenshot.cabal b/sydtest-webdriver-screenshot/sydtest-webdriver-screenshot.cabal new file mode 100644 index 00000000..92ae5355 --- /dev/null +++ b/sydtest-webdriver-screenshot/sydtest-webdriver-screenshot.cabal @@ -0,0 +1,63 @@ +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-screenshot +version: 0.0.0.0 +synopsis: A webdriver screenshot companion library for sydtest +category: Testing +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright (c) 2022 Tom Sydney Kerckhove +license: OtherLicense +license-file: LICENSE.md +build-type: Simple +extra-source-files: + LICENSE.md + +library + exposed-modules: + Test.Syd.Webdriver.Screenshot + other-modules: + Paths_sydtest_webdriver_screenshot + hs-source-dirs: + src + build-depends: + JuicyPixels + , base >=4.7 && <5 + , bytestring + , http-types + , mtl + , network-uri + , path + , path-io + , sydtest + , sydtest-wai + , sydtest-webdriver + , webdriver + default-language: Haskell2010 + +test-suite sydtest-webdriver-screenshot-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Syd.Webdriver.Screenshot.App + Test.Syd.Webdriver.ScreenshotSpec + Paths_sydtest_webdriver_screenshot + 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 + , sydtest-webdriver-screenshot + , wai + default-language: Haskell2010 diff --git a/sydtest-webdriver-screenshot/test/Spec.hs b/sydtest-webdriver-screenshot/test/Spec.hs new file mode 100644 index 00000000..ebed7e1c --- /dev/null +++ b/sydtest-webdriver-screenshot/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/sydtest-webdriver-screenshot/test/Test/Syd/Webdriver/Screenshot/App.hs b/sydtest-webdriver-screenshot/test/Test/Syd/Webdriver/Screenshot/App.hs new file mode 100644 index 00000000..99b9182b --- /dev/null +++ b/sydtest-webdriver-screenshot/test/Test/Syd/Webdriver/Screenshot/App.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Syd.Webdriver.Screenshot.App where + +import Network.HTTP.Types as HTTP +import Network.Wai as Wai + +exampleApplication :: Wai.Application +exampleApplication req sendResp = + sendResp $ + responseLBS + HTTP.ok200 + (requestHeaders req) + "

Hello World

Foo

Bar

Quux

" diff --git a/sydtest-webdriver-screenshot/test/Test/Syd/Webdriver/ScreenshotSpec.hs b/sydtest-webdriver-screenshot/test/Test/Syd/Webdriver/ScreenshotSpec.hs new file mode 100644 index 00000000..2d5dd9fb --- /dev/null +++ b/sydtest-webdriver-screenshot/test/Test/Syd/Webdriver/ScreenshotSpec.hs @@ -0,0 +1,22 @@ +module Test.Syd.Webdriver.ScreenshotSpec (spec) where + +import Network.URI +import Test.Syd +import Test.Syd.Wai +import Test.Syd.Webdriver +import Test.Syd.Webdriver.Screenshot +import Test.Syd.Webdriver.Screenshot.App + +spec :: Spec +spec = exampleAppSpec $ do + it "can make a screenshot of home" $ do + openPath "/" + goldenScreenshotHere "test_resources/home.png" + +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, ()) diff --git a/sydtest-webdriver-screenshot/test_resources/home.png b/sydtest-webdriver-screenshot/test_resources/home.png new file mode 100644 index 0000000000000000000000000000000000000000..820d3fcd451a10d2eeb77110b784d31f36f56edb GIT binary patch literal 12366 zcmeHNcT|(vwhtnpIDj*VTn2&RB1KU^kzT?KGUyGQlv=-krGrC8!%F3C_xxN zK#0N<_@W??{h9~%fp6U2Ssj5uR75VG|MAy58B3F4zgY$CeOQZ# z;&B#rICYO_|NhSWkKNbY1)_70q*|t1-7dRz>u2ccT9t>dRFqwKvr#!X^RWAl%@f(fa5v3h+{UTe-K82tGJ1Fsi4VtYgFmfZY*?0- z-PTE91h7USELVed^?@PB^*!?{>hQjEtZ$_E-(rnF9q46^(TB6Sm=_164Y--(;h&;- znd1-95CP_BaNvKMK=T*wK%1T%qi18s;HrxsR4?YwBcD!5GhbfC1tzr_bJYa07xxYH zkkL<()X>ooXuQHjjni4~z`_D-C}^Kxs@yZS zp&$A#M$whWQ9c;#jkPZyjf9sQc9&_R#a{x#9_%3wrfjQ(g|MbFjG@k-&z_iUux7_|D-w^ zE$Vnjn(>G*-<@i_^!72^kH<1=&KV%>P|FD>N@8jrzcxnhojiFmL8x;kVtdk>>ft># zzg)YLr5Cn!Q9d*24Pru;;=A@ylrhZ*)eIzDUc{a&ckj=qIV``&XDtnw!>Rpct_|Du zD=xy3YtLYF=6X~@E;1m-2)peA-yPo|_G8H@sN*pL0s?uuiJObV=IQDsU=JZHQ!S4K z(lvahEX?&}*+=e>{cPVxsY7j#&Pp9_Q$47ONA#S!dPrll2|dL`2ZS^z!bPRv5zzT03tN62G?wF}LMls~m$w;Q(e9*BsD$Y=QeM5R>pn{~?# z3=g}B#))evHM+J3k95tcb8nDP*eNRMY@V(#bG@jog{Kg`0NkgXPrpCEgwWTc{3Zpf z^sr1Xt~?hx^H3CLE+C;@(a;bH4s&pDkg|42sX99;rp&oBfp(R6-NM2G+Yr&;1onV_ zc}8Y$BG)(`kAUlEu5Y0l^=f^a?( zC@U-57A3hcnF7-5NIKA)*Ih7^V|@~KmzZa2YDz2wUd6-D>fUI5yky*ax+J)Dtz9zg z6qMd16zL0=CKkf?7GVI+l=99wb*V0HA>H2^=SJNSro2*-J2PH$ZQ?#O>TqM0#8lWy zeP?tkEb_f^yyWQgSfyt-U&8LIMr$MA0`2pqa5!ArpS!6*Q7DU|~M5JW=6pvA$a+mW`}gDDrv> z7U}$*V&^qkQ+ZjzSvaB7TR*9-tqq{rHT8`hN=c0NMYQo{EYr5gFHhvlT0BeN%cZS$ z$i&Z~PyzTJuO`72mB#Dd-rni(+@-XE!9kY?^YinyAuBzwvg=LvX_nslhnWUN2_6vY zb<6PkSzSMn(97_YgU>7s7N=uTXoz0$(ukLDbM!%UlXRJcHs>i@< zuhqR3IJ{5Rh++CJiSIuT%`Gd`bv-=1H7>(E&&Vh2)?{kKMjme4Th)N+q|s?(D76oV z{qj_?v_tM!OUq=kz5d!0bLUjBD+%2@t0On#O@#_Br6u&Fsd-vyUv+eB073aa0PmV= zA3W+p8Pu+8Ny#!af#-UexwyEf@4SnTctiM(&BBCzGmK~zhW``w(~fo3n}czhS@3mo z<*?&;xX&R`rB8Cl6HP*uu#}#VGLuI_QuJ{wU0tV+n4kVx3pL?yqQ0{ZLKvJNTF|F) zZ;R$3G38`}d4-loz?aY~3Sa5q2VDcHfKO*!WV@BT+$&|`@Nk%}&r}^QZ1IC~_A^Jb zOyw$Zb*~F}uc(Zk7unNLtWHI%H1%|m9(qlRo>l=T)7m?J-dYZFIq?ioFj->G=5-c=;-Oe z8Hp4!End?NFxcpI5P8f9rO6_8C-7wJx&}~khYZD{B}NFo^sb#Os=qV+ zpmW+t)FFxC;%8DU;YaH;mO{tNo2aR&Vp#H)v!er`9vju}l+)dq z_oS-v-!V2df$n`*!I_-EFdhdqti}4wwL{m_FwW~5-eXB{*$ZjxT+#}H;K?(k8U=XO zWrd8OA)8ct|IRly`sX-b3A7Oh*pAlc*y9YKQ0_8PW8e{y;12H;3wlHYduP_cRu3 zTT)e7Nrn z?}MJkEySWx1h2+QL{wHUPZ zbW9-o3Ku?e2&Qm^-$-MjzW{Te=MY(j6v56vd4wED=3UxaJCxFC zo)tXi-Yx|X2df1IZPo&oeDvs1i5)7X+IBHS3$Tqt$Rto3Z(hh4Z!He5yu2AFcIHOw zb1~KBy7iu=c}bH0-sUiVr8=BK#syd*9WxQ@h2{}O$voq=EyH5j!a`8mYK410uaIPh z?y9umBYOZTkca8*Q2JNt)z@mw0@lAyn*C*M_wS$JmW)AaWu9m7L8faAP%>XtYR&*; zuL@O9%8(%@n6kNfFX{ViYoz0(nmFt8G~CdQmjLvXeHf|oW_w(T<{OZSXPO^^tP-im zhB6^v`?LXrXbvwbExk=oAT&MTlP}O#XJc@=IAGsKw{oK{$OVC}uP$qn-Y$*xQi zkLj?VxJ?S$6K)2e_@m#d)IQB@u`joMZySpcEVVYrUN`iWH zvconAFU)E;hwRp8nXJCm9J|%CpXr}$yTuF$NtCVZj}S8;nf0TgT}dY>Yn_Sms0~4a z`hQGg7UlTf-(_oGET2@kio_*-XXS|taup$R%xNH#w)p)7kiZkov`=K(C>-h0oPEyZ z0?Kc3#|sh;{#RqQ*O&qx)@durSacH(7y9*VN%#ljZ;pT^jJUu+95?gU0b+f;F zmX3ltj6Ha>|!G-jxDVJLKX7wN9v!ppoE7|#<03_<%)&H`Y0xHi&%hIF56>q zYp-dgjDZ`k;IZn6-7Tf@zq3!{$~adI0O;-(31qGDYQI@#juTV@3V>Tf2QU*za5^=X ztY>QytGG8Zv;xXrFpCh03?S^(t3lyF>@SG_+nF36Yy%Lj4GTrZOyaEQ5V5vD6SOce zRUf8t?%e+HL##RCw1G6O4JOslsf+zhOn5)=94;k|mb>-oXq#!yL`&!d&xv+^Eg*fq zBSrEBzPh}#1DLE!5&1`enLcIC*|+02=|xPm)+~Zzf`O@Jy(ML1-%zB|ttYQUm zSdLlZIKKt)rDy-{#>a2rvZvX6QrB6jV_=@4c_yMD;I8Ja-t0Nw)#;|~i2w{JNUMCX zO611k(UJxB=cIBh@sGH+& zoeZ_{3&lwNFB#w%=0(2(eadU>+wAV{ZgbtWRw4LK3mDI<Z0Nx2E0nLrYLrI$(AR1{@a3Pa(*HC%|JV8if7yatItJKKeCBLhZ1L;Y zuiv~m292a`H!}8=Mvk)1c+x?fRcI>eys4|J1F3+B2gnOT<5+hI4Yr4R7l)C`ii(Oy z_`6e;u^}U6F5L+&&a1CtBp1p~v$Kdq<N>`muEF^wmly%g)ZIW zle`r<^0`n%(dxJq2-1;}k(bXAK)H500rVBX**%vj0}$XK!6zjrPX>>BQ<~;f#Ez+Z zjd%{DpavRhYO%+(&Qj_EiJyZOhh(MhZZFq^iynqQ8>fE2N}>q@PMej&^Ch-yB=;g6 zuyjafI2{z3nc<~HMc?ZLdy$>!G)gA@BkP?zH|x)EQF~t*GAk49tCp6PZkQ}H#trs_ z@4$qhm_@^y{1!`4at{n2eG^Ke3i1$I$@AU)FKo(PgO;t?8S_?e6a1%Z*4C+#NBJMl zt-3*XM?JgePX;I!0OrvEb$H+(pj5G|@*-|1vzkO7#EUB-d%cE2AO=AD#-%%jG>!tQ z-u>fK5qB$kUwmXzkC^TqU+T*KM9lVN2&~~O%7397M)xOET7}JZSL)UigjC&nzG39B zj14Rq+83Df>Xo!W`+Q6u0-QsZ=}T2NGwo}DEw`lHU2YQxKv7v#RFr@LHOEx7-%Z;J z4X=^IyGAVfB-ncIC$xfUSN_t=%QiNnAl0AyJ5as_g@q^dc0n`)M{KTO8*6Ir0t*de z1kw8fO$uPIm@J)YvWwnE1*?H7)HXtl%QQ9RUyr~ zMc1fMHjs}51ZDnGWkwlJF=@Tcy0L@kTV}^4B=0Yyo-+aDulFc9PUJWdgeC__93L&mZSN#K!lUzB3!XZ^ApKx&Sf5Hb0Y@7tE74{7oCHb+T`9Rb|cAxUPH2cRA z*AB3ML~(Q<`^OcW+pO}N;}#Aa00D5Kgu@O11{~7lBntoo2q#IhdgUBe= 4.7 && < 5 + +library: + source-dirs: src + dependencies: + - bytestring + - http-client + - http-types + - mtl + - network-uri + - path + - path-io + - sydtest + - sydtest-wai + - sydtest-webdriver + - sydtest-yesod + - text + - webdriver + - yesod + + + +tests: + sydtest-webdriver-yesod-test: + main: Spec.hs + source-dirs: test + build-tools: sydtest-discover + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - path + - path-io + - sydtest + - sydtest-webdriver + - sydtest-webdriver-yesod + - yesod diff --git a/sydtest-webdriver-yesod/src/Test/Syd/Webdriver/Yesod.hs b/sydtest-webdriver-yesod/src/Test/Syd/Webdriver/Yesod.hs new file mode 100644 index 00000000..f268bdb0 --- /dev/null +++ b/sydtest-webdriver-yesod/src/Test/Syd/Webdriver/Yesod.hs @@ -0,0 +1,108 @@ +{-# 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 appSetupFunc = webdriverSpec $ \man -> do + site <- appSetupFunc man + YesodClient {..} <- yesodClientSetupFunc man site + pure (yesodClientSiteURI, yesodClientSite) + +-- | Open a given yesod 'Route' +openRoute :: + Yesod.RenderRoute app => + Route app -> + WebdriverTestM app () +openRoute route = openRouteWithParams route [] + +-- | Open a given yesod 'Route' with parameters +openRouteWithParams :: + Yesod.RenderRoute app => + Route app -> + [(Text, Text)] -> + WebdriverTestM app () +openRouteWithParams route extraParams = do + let (pathPieces, queryParams) = Yesod.renderRoute route + let q = queryTextToQuery $ map (second Just) (queryParams <> extraParams) + let pathBSBuilder = encodePath pathPieces q + let pathBS = LB.toStrict (BB.toLazyByteString pathBSBuilder) + case TE.decodeUtf8' pathBS of + Left err -> + liftIO $ + expectationFailure $ + unlines + [ unwords + [ "Failed to decode path from bytestring:", + show pathBS + ], + show err + ] + Right t -> openPath $ T.unpack t + +-- | Get the current 'Route' +getCurrentRoute :: + Yesod.ParseRoute app => + WebdriverTestM app (Route app) +getCurrentRoute = do + currentUrl <- getCurrentURL + case parseURI currentUrl of + Nothing -> liftIO $ expectationFailure $ "Should have been able to parse the current url into an URI: " <> currentUrl + Just URI {..} -> do + let (textPieces, query_) = HTTP.decodePath $ TE.encodeUtf8 $ T.pack $ concat [uriPath, uriQuery] + queryPieces = map unJust $ HTTP.queryToQueryText query_ + case Yesod.parseRoute (textPieces, queryPieces) of + Nothing -> + liftIO $ + expectationFailure $ + unlines + [ "Should have been able to parse an App route from " <> currentUrl, + ppShow (textPieces, queryPieces) + ] + Just route -> pure route + where + unJust (a, Just b) = (a, b) + unJust (a, Nothing) = (a, "") diff --git a/sydtest-webdriver-yesod/sydtest-webdriver-yesod.cabal b/sydtest-webdriver-yesod/sydtest-webdriver-yesod.cabal new file mode 100644 index 00000000..0540bc9a --- /dev/null +++ b/sydtest-webdriver-yesod/sydtest-webdriver-yesod.cabal @@ -0,0 +1,65 @@ +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-yesod +version: 0.0.0.0 +synopsis: A webdriver+yesod companion library for sydtest +category: Testing +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright (c) 2022 Tom Sydney Kerckhove +license: OtherLicense +license-file: LICENSE.md +build-type: Simple +extra-source-files: + LICENSE.md + +library + exposed-modules: + Test.Syd.Webdriver.Yesod + other-modules: + Paths_sydtest_webdriver_yesod + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , bytestring + , http-client + , http-types + , mtl + , network-uri + , path + , path-io + , sydtest + , sydtest-wai + , sydtest-webdriver + , sydtest-yesod + , text + , webdriver + , yesod + default-language: Haskell2010 + +test-suite sydtest-webdriver-yesod-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Syd.Webdriver.Yesod.App + Test.Syd.Webdriver.YesodSpec + Paths_sydtest_webdriver_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 + , path + , path-io + , sydtest + , sydtest-webdriver + , sydtest-webdriver-yesod + , yesod + default-language: Haskell2010 diff --git a/sydtest-webdriver-yesod/test/Spec.hs b/sydtest-webdriver-yesod/test/Spec.hs new file mode 100644 index 00000000..ebed7e1c --- /dev/null +++ b/sydtest-webdriver-yesod/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/sydtest-webdriver-yesod/test/Test/Syd/Webdriver/Yesod/App.hs b/sydtest-webdriver-yesod/test/Test/Syd/Webdriver/Yesod/App.hs new file mode 100644 index 00000000..f585da57 --- /dev/null +++ b/sydtest-webdriver-yesod/test/Test/Syd/Webdriver/Yesod/App.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.Webdriver.Yesod.App where + +import Yesod + +data App = App {appSessionKeyFile :: !FilePath} + +mkYesod + "App" + [parseRoutes| + + / HomeR GET +|] + +instance Yesod App where + makeSessionBackend App {..} = Just <$> defaultClientSessionBackend 30 appSessionKeyFile + +instance RenderMessage App FormMessage where + renderMessage _ _ = defaultFormMessage + +getHomeR :: Handler Html +getHomeR = pure "Hello, world! (GET)" diff --git a/sydtest-webdriver-yesod/test/Test/Syd/Webdriver/YesodSpec.hs b/sydtest-webdriver-yesod/test/Test/Syd/Webdriver/YesodSpec.hs new file mode 100644 index 00000000..8ae6bfa7 --- /dev/null +++ b/sydtest-webdriver-yesod/test/Test/Syd/Webdriver/YesodSpec.hs @@ -0,0 +1,20 @@ +module Test.Syd.Webdriver.YesodSpec (spec) where + +import Path +import Path.IO +import Test.Syd +import Test.Syd.Path +import Test.Syd.Webdriver +import Test.Syd.Webdriver.Yesod +import Test.Syd.Webdriver.Yesod.App + +spec :: Spec +spec = exampleAppSpec $ do + it "can navigate to home" $ + openRoute HomeR + +exampleAppSpec :: WebdriverSpec App -> Spec +exampleAppSpec = webdriverYesodSpec $ \_ -> do + tdir <- tempDirSetupFunc "sydtest-yesod" + sessionKeyFile <- resolveFile tdir "client_session_key.aes" + pure $ App {appSessionKeyFile = fromAbsFile sessionKeyFile} diff --git a/sydtest-webdriver/LICENSE.md b/sydtest-webdriver/LICENSE.md new file mode 100644 index 00000000..bfc3c11e --- /dev/null +++ b/sydtest-webdriver/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/sydtest-webdriver/package.yaml b/sydtest-webdriver/package.yaml new file mode 100644 index 00000000..2de276fa --- /dev/null +++ b/sydtest-webdriver/package.yaml @@ -0,0 +1,54 @@ +name: sydtest-webdriver +version: 0.0.0.0 +license: OtherLicense +license-file: LICENSE.md +author: "Tom Sydney Kerckhove" +maintainer: "syd@cs-syd.eu" +copyright: "Copyright (c) 2022 Tom Sydney Kerckhove" +category: Testing +synopsis: A webdriver companion library for sydtest + +extra-source-files: +- LICENSE.md + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + dependencies: + - aeson + - 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 + + + +tests: + sydtest-webdriver-test: + main: Spec.hs + source-dirs: test + build-tools: sydtest-discover + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - http-types + - network-uri + - sydtest + - sydtest-wai + - sydtest-webdriver + - wai diff --git a/sydtest-webdriver/src/Test/Syd/Webdriver.hs b/sydtest-webdriver/src/Test/Syd/Webdriver.hs new file mode 100644 index 00000000..4defd4a6 --- /dev/null +++ b/sydtest-webdriver/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/sydtest-webdriver.cabal b/sydtest-webdriver/sydtest-webdriver.cabal new file mode 100644 index 00000000..43f04f88 --- /dev/null +++ b/sydtest-webdriver/sydtest-webdriver.cabal @@ -0,0 +1,67 @@ +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 +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright (c) 2022 Tom Sydney Kerckhove +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/sydtest-webdriver/test/Spec.hs b/sydtest-webdriver/test/Spec.hs new file mode 100644 index 00000000..ebed7e1c --- /dev/null +++ b/sydtest-webdriver/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/sydtest-webdriver/test/Test/Syd/Webdriver/App.hs b/sydtest-webdriver/test/Test/Syd/Webdriver/App.hs new file mode 100644 index 00000000..97a2365c --- /dev/null +++ b/sydtest-webdriver/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/sydtest-webdriver/test/Test/Syd/WebdriverSpec.hs b/sydtest-webdriver/test/Test/Syd/WebdriverSpec.hs new file mode 100644 index 00000000..a1b1a43c --- /dev/null +++ b/sydtest-webdriver/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, ()) diff --git a/sydtest/package.yaml b/sydtest/package.yaml index 57831aca..e4a18460 100644 --- a/sydtest/package.yaml +++ b/sydtest/package.yaml @@ -45,7 +45,6 @@ library: - split - stm - text - - yaml when: - condition: 'os(windows)' then: diff --git a/sydtest/sydtest.cabal b/sydtest/sydtest.cabal index cd13f33e..712b40f3 100644 --- a/sydtest/sydtest.cabal +++ b/sydtest/sydtest.cabal @@ -86,7 +86,6 @@ library , split , stm , text - , yaml if os(windows) build-depends: ansi-terminal