{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-incomplete-record-updates #-}
{-# 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
data Screenshot = Screenshot
{
Screenshot -> Path Abs File
screenshotFile :: !(Path Abs File),
Screenshot -> Image PixelRGB8
screenshotImage :: !(Picture.Image PixelRGB8)
}
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
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
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