sydtest-webdriver-screenshot (empty) → 0.0.0.0

raw patch · 6 files changed

+195/−0 lines, 6 filesdep +JuicyPixelsdep +basedep +bytestring

Dependencies added: JuicyPixels, base, bytestring, http-types, mtl, network-uri, path, path-io, sydtest, sydtest-wai, sydtest-webdriver, sydtest-webdriver-screenshot, wai, webdriver

Files

LICENSE.md +5/−0
src/Test/Syd/Webdriver/Screenshot.hs +90/−0
sydtest-webdriver-screenshot.cabal +63/−0
test/Spec.hs +1/−0
test/Test/Syd/Webdriver/Screenshot/App.hs +14/−0
test/Test/Syd/Webdriver/ScreenshotSpec.hs +22/−0

+ LICENSE.md view

@@ -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.

+ src/Test/Syd/Webdriver/Screenshot.hs view

@@ -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.cabal view

@@ -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

+ test/Spec.hs view

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

+ test/Test/Syd/Webdriver/Screenshot/App.hs view

@@ -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>"

+ test/Test/Syd/Webdriver/ScreenshotSpec.hs view

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