{-# 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
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
    Screenshot -> Path Abs File
screenshotFile :: !(Path Abs File),
    -- | Decoded image
    Screenshot -> Image PixelRGB8
screenshotImage :: !(Picture.Image PixelRGB8)
  }

-- | Take a screenshot and turn it into a golden test.
goldenScreenshotHere :: FilePath -> WebdriverTestM app (GoldenTest Screenshot)
goldenScreenshotHere :: forall app. String -> WebdriverTestM app (GoldenTest Screenshot)
goldenScreenshotHere String
fp = String -> ByteString -> GoldenTest Screenshot
pureGoldenScreenshot String
fp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
wd ByteString
WD.screenshot

-- | Make a golden test for a given screenshot in lazy 'LB.ByteString' form.
pureGoldenScreenshot :: FilePath -> LB.ByteString -> GoldenTest Screenshot
pureGoldenScreenshot :: String -> ByteString -> GoldenTest Screenshot
pureGoldenScreenshot String
fp ByteString
contents =
  GoldenTest
    { goldenTestRead :: IO (Maybe Screenshot)
goldenTestRead = do
        Path Rel File
relFile <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
fp
        Path Abs Dir
currentDir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
        let resolvedFile :: Path Abs File
resolvedFile = Path Abs Dir
currentDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
        Maybe ByteString
mContents <- forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
SB.readFile forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
fromAbsFile Path Abs File
resolvedFile
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe ByteString
mContents forall a b. (a -> b) -> a -> b
$ \ByteString
cts -> do
          case ByteString -> Either String DynamicImage
decodePng ByteString
cts of
            Left String
err -> forall a. String -> IO a
die String
err
            Right DynamicImage
dynamicImage ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                Screenshot
                  { screenshotFile :: Path Abs File
screenshotFile = Path Abs File
resolvedFile,
                    screenshotImage :: Image PixelRGB8
screenshotImage = DynamicImage -> Image PixelRGB8
convertRGB8 DynamicImage
dynamicImage
                  },
      goldenTestProduce :: IO Screenshot
goldenTestProduce = do
        Image PixelRGB8
image <- ByteString -> IO (Image PixelRGB8)
normaliseImage ByteString
contents
        Path Rel File
relFile <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
fp
        Path Abs Dir
tempDir <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
"screenshot-comparison"
        let tempFile :: Path Abs File
tempFile = Path Abs Dir
tempDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
        forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs File
tempFile
        -- Write it to a file so we can compare it if it differs.
        forall pixel. PngSavable pixel => String -> Image pixel -> IO ()
writePng (Path Abs File -> String
fromAbsFile Path Abs File
tempFile) Image PixelRGB8
image
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          Screenshot
            { screenshotFile :: Path Abs File
screenshotFile = Path Abs File
tempFile,
              screenshotImage :: Image PixelRGB8
screenshotImage = Image PixelRGB8
image
            },
      goldenTestWrite :: Screenshot -> IO ()
goldenTestWrite = \(Screenshot Path Abs File
_ Image PixelRGB8
actual) -> do
        Path Rel File
relFile <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
fp
        Path Abs Dir
currentDir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
        let resolvedFile :: Path Abs File
resolvedFile = Path Abs Dir
currentDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
        forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs File
resolvedFile
        forall pixel. PngSavable pixel => String -> Image pixel -> IO ()
writePng (Path Abs File -> String
fromAbsFile Path Abs File
resolvedFile) Image PixelRGB8
actual,
      goldenTestCompare :: Screenshot -> Screenshot -> Maybe Assertion
goldenTestCompare = \(Screenshot Path Abs File
actualPath Image PixelRGB8
actual) (Screenshot Path Abs File
expectedPath Image PixelRGB8
expected) ->
        if Image PixelRGB8
actual forall a. Eq a => a -> a -> Bool
== Image PixelRGB8
expected
          then forall a. Maybe a
Nothing
          else
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
              String -> Assertion
ExpectationFailed forall a b. (a -> b) -> a -> b
$
                [String] -> String
unlines
                  [ String
"Screenshots differ.",
                    String
"expected: " forall a. Semigroup a => a -> a -> a
<> Path Abs File -> String
fromAbsFile Path Abs File
expectedPath,
                    String
"actual: " forall a. Semigroup a => a -> a -> a
<> Path Abs File -> String
fromAbsFile Path Abs File
actualPath
                  ]
    }

debugScreenshot :: FilePath -> WebdriverTestM app ()
debugScreenshot :: forall app. String -> WebdriverTestM app ()
debugScreenshot String
fp = do
  ByteString
contents <- forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
wd ByteString
screenshot
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Image PixelRGB8
image <- ByteString -> IO (Image PixelRGB8)
normaliseImage ByteString
contents
    forall pixel. PngSavable pixel => String -> Image pixel -> IO ()
writePng String
fp Image PixelRGB8
image

normaliseImage :: LB.ByteString -> IO (Image PixelRGB8)
normaliseImage :: ByteString -> IO (Image PixelRGB8)
normaliseImage ByteString
contents = do
  let sb :: ByteString
sb = ByteString -> ByteString
LB.toStrict ByteString
contents
  case ByteString -> Either String DynamicImage
decodePng ByteString
sb of
    Left String
err -> forall a. HasCallStack => String -> IO a
expectationFailure forall a b. (a -> b) -> a -> b
$ String
"Could not parse screenshot as png: " forall a. Semigroup a => a -> a -> a
<> String
err
    Right DynamicImage
dynamicImage -> do
      let image :: Image PixelRGB8
image = DynamicImage -> Image PixelRGB8
convertRGB8 DynamicImage
dynamicImage
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Image PixelRGB8
image