{-# 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 Codec.Picture.Types (createMutableImage, mutableImageData)
import Control.Monad
import Control.Monad.Reader
import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy as LB
import qualified Data.Vector.Storable as Vector
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 (ByteString -> GoldenTest Screenshot)
-> WebdriverTestM app ByteString
-> WebdriverTestM app (GoldenTest Screenshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WebdriverTestM app ByteString
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 <- String -> IO (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
fp
Path Abs Dir
currentDir <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
let resolvedFile :: Path Abs File
resolvedFile = Path Abs Dir
currentDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
Maybe ByteString
mContents <- IO ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
SB.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
fromAbsFile Path Abs File
resolvedFile
Maybe ByteString
-> (ByteString -> IO Screenshot) -> IO (Maybe Screenshot)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe ByteString
mContents ((ByteString -> IO Screenshot) -> IO (Maybe Screenshot))
-> (ByteString -> IO Screenshot) -> IO (Maybe Screenshot)
forall a b. (a -> b) -> a -> b
$ \ByteString
cts -> do
case ByteString -> Either String DynamicImage
decodePng ByteString
cts of
Left String
err -> String -> IO Screenshot
forall a. String -> IO a
die String
err
Right DynamicImage
dynamicImage ->
Screenshot -> IO Screenshot
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Screenshot -> IO Screenshot) -> Screenshot -> IO Screenshot
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 <- String -> IO (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
fp
Path Abs Dir
tempDir <- String -> IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
"screenshot-comparison"
let tempFile :: Path Abs File
tempFile = Path Abs Dir
tempDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs Dir -> IO ()) -> Path Abs Dir -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
tempFile
String -> Image PixelRGB8 -> IO ()
forall pixel. PngSavable pixel => String -> Image pixel -> IO ()
writePng (Path Abs File -> String
fromAbsFile Path Abs File
tempFile) Image PixelRGB8
image
Screenshot -> IO Screenshot
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Screenshot -> IO Screenshot) -> Screenshot -> IO Screenshot
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 <- String -> IO (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
fp
Path Abs Dir
currentDir <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
let resolvedFile :: Path Abs File
resolvedFile = Path Abs Dir
currentDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFile
Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs Dir -> IO ()) -> Path Abs Dir -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
resolvedFile
String -> Image PixelRGB8 -> IO ()
forall pixel. PngSavable pixel => String -> Image pixel -> IO ()
writePng (Path Abs File -> String
fromAbsFile Path Abs File
resolvedFile) Image PixelRGB8
actual,
goldenTestCompare :: Screenshot -> Screenshot -> IO (Maybe Assertion)
goldenTestCompare = \(Screenshot Path Abs File
actualPath Image PixelRGB8
actual) (Screenshot Path Abs File
expectedPath Image PixelRGB8
expected) ->
if Image PixelRGB8
actual Image PixelRGB8 -> Image PixelRGB8 -> Bool
forall a. Eq a => a -> a -> Bool
== Image PixelRGB8
expected
then Maybe Assertion -> IO (Maybe Assertion)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Assertion
forall a. Maybe a
Nothing
else do
Path Abs Dir
tempDir <- String -> IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
"screenshot-comparison"
Path Rel File
relFile <- String -> IO (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
fp
Path Rel File
diffRelFile <- String -> Path Rel File -> IO (Path Rel File)
forall (m :: * -> *) b.
MonadThrow m =>
String -> Path b File -> m (Path b File)
replaceExtension String
".diff" Path Rel File
relFile IO (Path Rel File)
-> (Path Rel File -> IO (Path Rel File)) -> IO (Path Rel File)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Path Rel File -> IO (Path Rel File)
forall (m :: * -> *) b.
MonadThrow m =>
String -> Path b File -> m (Path b File)
addExtension String
".png"
let diffFile :: Path Abs File
diffFile = Path Abs Dir
tempDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
diffRelFile
Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs Dir -> IO ()) -> Path Abs Dir -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
diffFile
String -> Image PixelRGB8 -> IO ()
forall pixel. PngSavable pixel => String -> Image pixel -> IO ()
writePng (Path Abs File -> String
fromAbsFile Path Abs File
diffFile) (Image PixelRGB8 -> Image PixelRGB8 -> Image PixelRGB8
computeImageDiff Image PixelRGB8
actual Image PixelRGB8
expected)
Maybe Assertion -> IO (Maybe Assertion)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Assertion -> IO (Maybe Assertion))
-> Maybe Assertion -> IO (Maybe Assertion)
forall a b. (a -> b) -> a -> b
$
Assertion -> Maybe Assertion
forall a. a -> Maybe a
Just (Assertion -> Maybe Assertion) -> Assertion -> Maybe Assertion
forall a b. (a -> b) -> a -> b
$
String -> Assertion
ExpectationFailed (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"Screenshots differ.",
String
"expected: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Path Abs File -> String
fromAbsFile Path Abs File
expectedPath,
String
"actual: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Path Abs File -> String
fromAbsFile Path Abs File
actualPath,
String
"diff: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Path Abs File -> String
fromAbsFile Path Abs File
diffFile,
String
"similarity: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show (Image PixelRGB8 -> Image PixelRGB8 -> Double
imageSimilarity Image PixelRGB8
actual Image PixelRGB8
expected)
]
}
imageSimilarity :: Image PixelRGB8 -> Image PixelRGB8 -> Double
imageSimilarity :: Image PixelRGB8 -> Image PixelRGB8 -> Double
imageSimilarity Image PixelRGB8
actual Image PixelRGB8
expected =
let width :: Int
width = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Image PixelRGB8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGB8
actual) (Image PixelRGB8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGB8
expected)
height :: Int
height = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Image PixelRGB8 -> Int
forall a. Image a -> Int
imageHeight Image PixelRGB8
actual) (Image PixelRGB8 -> Int
forall a. Image a -> Int
imageHeight Image PixelRGB8
expected)
in (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
width)) (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$
[Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$
((Int -> Double) -> [Int] -> [Double])
-> [Int] -> (Int -> Double) -> [Double]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Double) -> [Int] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map [Int
0 .. Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> Double) -> [Double]) -> (Int -> Double) -> [Double]
forall a b. (a -> b) -> a -> b
$ \Int
w ->
[Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$
((Int -> Double) -> [Int] -> [Double])
-> [Int] -> (Int -> Double) -> [Double]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Double) -> [Int] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map [Int
0 .. Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> Double) -> [Double]) -> (Int -> Double) -> [Double]
forall a b. (a -> b) -> a -> b
$ \Int
h ->
let actualPixel :: PixelRGB8
actualPixel = Image PixelRGB8 -> Int -> Int -> PixelRGB8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGB8
actual Int
w Int
h
expectedPixel :: PixelRGB8
expectedPixel = Image PixelRGB8 -> Int -> Int -> PixelRGB8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGB8
expected Int
w Int
h
in PixelRGB8 -> PixelRGB8 -> Double
diffPixel PixelRGB8
actualPixel PixelRGB8
expectedPixel
diffPixel :: PixelRGB8 -> PixelRGB8 -> Double
diffPixel :: PixelRGB8 -> PixelRGB8 -> Double
diffPixel (PixelRGB8 Pixel8
r1 Pixel8
g1 Pixel8
b1) (PixelRGB8 Pixel8
r2 Pixel8
g2 Pixel8
b2) =
if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Pixel8
r1 Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel8
r2, Pixel8
g1 Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel8
g2, Pixel8
b1 Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel8
b2]
then Double
1
else Double
0
computeImageDiff :: Image PixelRGB8 -> Image PixelRGB8 -> Image PixelRGB8
computeImageDiff :: Image PixelRGB8 -> Image PixelRGB8 -> Image PixelRGB8
computeImageDiff Image PixelRGB8
actual Image PixelRGB8
expected =
let width :: Int
width = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Image PixelRGB8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGB8
actual) (Image PixelRGB8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGB8
expected)
height :: Int
height = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Image PixelRGB8 -> Int
forall a. Image a -> Int
imageHeight Image PixelRGB8
actual) (Image PixelRGB8 -> Int
forall a. Image a -> Int
imageHeight Image PixelRGB8
expected)
in Image
{ imageWidth :: Int
imageWidth = Int
width,
imageHeight :: Int
imageHeight = Int
height,
imageData :: Vector (PixelBaseComponent PixelRGB8)
imageData = (forall s. ST s (MVector s (PixelBaseComponent PixelRGB8)))
-> Vector (PixelBaseComponent PixelRGB8)
forall a. Storable a => (forall s. ST s (MVector s a)) -> Vector a
Vector.create ((forall s. ST s (MVector s (PixelBaseComponent PixelRGB8)))
-> Vector (PixelBaseComponent PixelRGB8))
-> (forall s. ST s (MVector s (PixelBaseComponent PixelRGB8)))
-> Vector (PixelBaseComponent PixelRGB8)
forall a b. (a -> b) -> a -> b
$ do
MutableImage s PixelRGB8
mutableImage <- Int
-> Int
-> PixelRGB8
-> ST s (MutableImage (PrimState (ST s)) PixelRGB8)
forall px (m :: * -> *).
(Pixel px, PrimMonad m) =>
Int -> Int -> px -> m (MutableImage (PrimState m) px)
createMutableImage Int
width Int
height (Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
0 Pixel8
0 Pixel8
0)
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
w ->
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
h -> do
let actualPixel :: PixelRGB8
actualPixel = Image PixelRGB8 -> Int -> Int -> PixelRGB8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGB8
actual Int
w Int
h
expectedPixel :: PixelRGB8
expectedPixel = Image PixelRGB8 -> Int -> Int -> PixelRGB8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGB8
expected Int
w Int
h
MutableImage (PrimState (ST s)) PixelRGB8
-> Int -> Int -> PixelRGB8 -> ST s ()
forall a (m :: * -> *).
(Pixel a, PrimMonad m) =>
MutableImage (PrimState m) a -> Int -> Int -> a -> m ()
forall (m :: * -> *).
PrimMonad m =>
MutableImage (PrimState m) PixelRGB8
-> Int -> Int -> PixelRGB8 -> m ()
writePixel MutableImage s PixelRGB8
MutableImage (PrimState (ST s)) PixelRGB8
mutableImage Int
w Int
h (PixelRGB8 -> PixelRGB8 -> PixelRGB8
computePixelDiff PixelRGB8
actualPixel PixelRGB8
expectedPixel)
MVector s Pixel8 -> ST s (MVector s Pixel8)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MVector s Pixel8 -> ST s (MVector s Pixel8))
-> MVector s Pixel8 -> ST s (MVector s Pixel8)
forall a b. (a -> b) -> a -> b
$ MutableImage s PixelRGB8
-> MVector s (PixelBaseComponent PixelRGB8)
forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData MutableImage s PixelRGB8
mutableImage
}
computePixelDiff :: PixelRGB8 -> PixelRGB8 -> PixelRGB8
computePixelDiff :: PixelRGB8 -> PixelRGB8 -> PixelRGB8
computePixelDiff (PixelRGB8 Pixel8
r1 Pixel8
g1 Pixel8
b1) (PixelRGB8 Pixel8
r2 Pixel8
g2 Pixel8
b2) =
if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Pixel8
r1 Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Pixel8
r2, Pixel8
g1 Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Pixel8
g2, Pixel8
b1 Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Pixel8
b2]
then Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
0 Pixel8
255 Pixel8
0
else Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
0 Pixel8
0 Pixel8
0
debugScreenshot :: FilePath -> WebdriverTestM app ()
debugScreenshot :: forall app. String -> WebdriverTestM app ()
debugScreenshot String
fp = do
ByteString
contents <- WebdriverTestM app ByteString
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
wd ByteString
screenshot
IO () -> WebdriverTestM app ()
forall a. IO a -> WebdriverTestM app a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WebdriverTestM app ()) -> IO () -> WebdriverTestM app ()
forall a b. (a -> b) -> a -> b
$ do
Image PixelRGB8
image <- ByteString -> IO (Image PixelRGB8)
normaliseImage ByteString
contents
String -> Image PixelRGB8 -> IO ()
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 -> String -> IO (Image PixelRGB8)
forall a. HasCallStack => String -> IO a
expectationFailure (String -> IO (Image PixelRGB8)) -> String -> IO (Image PixelRGB8)
forall a b. (a -> b) -> a -> b
$ String
"Could not parse screenshot as png: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
Right DynamicImage
dynamicImage -> do
let image :: Image PixelRGB8
image = DynamicImage -> Image PixelRGB8
convertRGB8 DynamicImage
dynamicImage
Image PixelRGB8 -> IO (Image PixelRGB8)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Image PixelRGB8
image