First version of sydtest-webdriver, sydtest-webdriver-yesod and sydte…

…st-webdriver-screenshot

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
+    '';
+}

nix/fonts.xsl

@@ -0,0 +1,30 @@
+<?xml version="1.0"?>
+
+<!--
+  This is an adaptation of https://github.com/NixOS/nixpkgs/blob/068984c00e0d4e54b6684d98f6ac47c92dcb642e/pkgs/development/libraries/fontconfig/make-fonts-conf.xsl
+-->
+
+<xsl:stylesheet version="1.0"
+                xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+                xmlns:str="http://exslt.org/strings"
+                extension-element-prefixes="str"
+  >
+
+
+  <xsl:param name="fontNames" />
+
+  <xsl:template match="/fontconfig">
+
+    <fontconfig>
+      <cachedir prefix="xdg">fontconfig</cachedir>
+
+
+      <xsl:for-each select="str:tokenize($fontNames)">
+        <dir>/etc/fonts/<xsl:value-of select="." />/share/fonts</dir>
+        <xsl:text>&#0010;</xsl:text>
+      </xsl:for-each>
+    </fontconfig>
+
+  </xsl:template>
+
+</xsl:stylesheet>

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";
     };
 

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}
   '';
 }

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

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
 

sydtest-webdriver-screenshot/.gitignore

@@ -0,0 +1 @@
+screenshot-comparison

sydtest-webdriver-screenshot/package.yaml

@@ -0,0 +1,38 @@
+name: sydtest-webdriver-screenshot
+version: 0.0.0.0
+
+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 

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
+                  ]
+    }

sydtest-webdriver-screenshot/sydtest-webdriver-screenshot.cabal

@@ -0,0 +1,54 @@
+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
+build-type:     Simple
+
+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

sydtest-webdriver-screenshot/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}

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)
+      "<html><body><h1>Hello World</h1><h2>Foo</h2><h3>Bar</h3><h4>Quux</h4></body></html>"

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, ())