{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
{- | Properties of the pure parts of the document build commands: parsers,
string replacement, hashing, and the optics of the data types.
-}
module BuildTests (
buildTests,
) where
import qualified Data.ByteString.Lazy.Char8 as Char8
import Data.Char (isHexDigit)
import Data.List (isPrefixOf, isSuffixOf, nub)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Document.Build
import Gens (genInt, genString)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Laws (Laws, lensLaws, prismLaws)
genCommandLine :: Gen CommandLine
genCommandLine =
CommandLine <$> genString <*> Gen.list (Range.linear 0 4) genString
genBuildError :: Gen BuildError
genBuildError =
Gen.choice
[ ProcessFailed <$> genCommandLine <*> genString <*> genString
, ProcessOutputUnrecognised <$> genCommandLine <*> genString
, InputFileMissing <$> genString
, OutputFileMissing <$> genCommandLine <*> genString
, StringsMissing <$> genString <*> Gen.nonEmpty (Range.linear 1 3) genString
, FileTypeUnsupported <$> genString <*> Gen.list (Range.linear 0 3) genString
, FileNotInGit <$> genString
, FileNotUtf8 <$> genString
, BuildCycle <$> genCycle
, InputFilesTooFew <$> genString <*> Gen.int (Range.linear 0 10) <*> Gen.int (Range.linear 0 10)
, OutputNotInDirectory <$> genString <*> genString
, ShallowRepository <$> genString
]
genCycle :: Gen Cycle
genCycle =
let genStep = Step <$> genString <*> genString
genTrail = Trail <$> Gen.list (Range.linear 0 3) genStep
in Gen.choice
[ ReproducesInput <$> genString <*> genStep <*> genTrail
, RepeatsStep <$> genStep <*> genTrail
]
genTime :: Gen UTCTime
genTime =
posixSecondsToUTCTime . fromIntegral <$> Gen.int (Range.linear 0 2000000000)
genImageInfo :: Gen ImageInfo
genImageInfo =
ImageInfo
<$> Gen.element ["PNG", "JPEG", "GIF", "PDF"]
<*> Gen.int (Range.linear 1 10000)
<*> Gen.int (Range.linear 1 10000)
<*> (fromIntegral <$> Gen.int (Range.linear 1 1200))
<*> (fromIntegral <$> Gen.int (Range.linear 1 1200))
<*> Gen.element ["Undefined", "PixelsPerInch", "PixelsPerCentimeter"]
<*> Gen.element ["sRGB", "Gray", "CMYK"]
<*> Gen.element [1, 8, 16]
<*> Gen.int (Range.linear 1 100)
genWord :: Gen String
genWord =
Gen.string (Range.linear 1 20) Gen.alphaNum
genGitDetails :: Gen GitDetails
genGitDetails =
GitDetails
<$> genWord
<*> genWord
<*> genWord
<*> genWord
<*> genTime
<*> genWord
<*> genWord
<*> genTime
<*> Gen.string (Range.linear 0 40) (Gen.filter (`notElem` ("\NUL\n" :: String)) Gen.unicode)
<*> Gen.list (Range.linear 0 3) genWord
buildTests :: Laws
buildTests =
concat
[ lensLaws "commandLineProgram" commandLineProgram genCommandLine genString
, lensLaws "commandLineArguments" commandLineArguments genCommandLine (Gen.list (Range.linear 0 3) genString)
, lensLaws "imageWidth" imageWidth genImageInfo genInt
, lensLaws "imageColourspace" imageColourspace genImageInfo genString
, lensLaws "gitCommitHash" gitCommitHash genGitDetails genString
, lensLaws "gitCommitTime" gitCommitTime genGitDetails genTime
, lensLaws "gitAuthors" gitAuthors genGitDetails (Gen.list (Range.linear 0 3) genString)
, prismLaws "_ProcessFailed" _ProcessFailed genBuildError ((,,) <$> genCommandLine <*> genString <*> genString)
, prismLaws "_ProcessOutputUnrecognised" _ProcessOutputUnrecognised genBuildError ((,) <$> genCommandLine <*> genString)
, prismLaws "_InputFileMissing" _InputFileMissing genBuildError genString
, prismLaws "_OutputFileMissing" _OutputFileMissing genBuildError ((,) <$> genCommandLine <*> genString)
, prismLaws "_StringsMissing" _StringsMissing genBuildError ((,) <$> genString <*> Gen.nonEmpty (Range.linear 1 3) genString)
, prismLaws "_FileTypeUnsupported" _FileTypeUnsupported genBuildError ((,) <$> genString <*> Gen.list (Range.linear 0 3) genString)
, prismLaws "_FileNotInGit" _FileNotInGit genBuildError genString
, prismLaws "_FileNotUtf8" _FileNotUtf8 genBuildError genString
, prismLaws "_BuildCycle" _BuildCycle genBuildError genCycle
, prismLaws "_InputFilesTooFew" _InputFilesTooFew genBuildError ((,,) <$> genString <*> Gen.int (Range.linear 0 10) <*> Gen.int (Range.linear 0 10))
, prismLaws "_OutputNotInDirectory" _OutputNotInDirectory genBuildError ((,) <$> genString <*> genString)
, prismLaws "_ShallowRepository" _ShallowRepository genBuildError genString
, prismLaws "_BuildError" _BuildError genBuildError genBuildError
,
[ ("parsePdfinfoPages finds the page count", prop_parsePdfinfoPages)
, ("parseImageInfo round trip", prop_parseImageInfo)
, ("parseGitLog round trip", prop_parseGitLog)
, ("pageImagePaths has one path for each page", prop_pageImagePaths)
, ("replaceText with no pairs is the identity", prop_replaceTextEmpty)
, ("replaceText of a string with itself is the identity", prop_replaceTextSame)
, ("replaceText of an absent string is the identity", prop_replaceTextAbsent)
, ("sha256Hex is 64 hexadecimal digits", prop_sha256Hex)
, ("xmlEscape leaves no markup", prop_xmlEscape)
, ("shellQuote leaves no unquoted special characters", prop_shellQuote)
, ("flatExtension and zippedExtension are inverse", prop_flatZipped)
, ("buildErrorExitCode is distinct for each kind of error", prop_exitCodes)
, ("displayBuildError ends with a newline", prop_display)
]
]
prop_parsePdfinfoPages :: Property
prop_parsePdfinfoPages =
property $
do
n <- forAll (Gen.int (Range.linear 0 10000))
before <- forAll (Gen.list (Range.linear 0 4) (("Title: " <>) <$> genWord))
parsePdfinfoPages (unlines (before <> ["Pages: " <> show n, "Encrypted: no"])) === Just n
prop_parseImageInfo :: Property
prop_parseImageInfo =
property $
do
i@(ImageInfo m w h x y u c z n) <- forAll genImageInfo
parseImageInfo (unlines [m, show w, show h, show x, show y, u, c, show z, show n]) === Just i
prop_parseGitLog :: Property
prop_parseGitLog =
property $
do
g@(GitDetails h h' an ae at cn ce ct subject as) <- forAll genGitDetails
let seconds t = show (floor (utcTimeToPOSIXSeconds t) :: Integer)
parseGitLog (concatMap (<> "\NUL") [h, h', an, ae, seconds at, cn, ce, seconds ct] <> subject <> "\n") as === Just g
prop_pageImagePaths :: Property
prop_pageImagePaths =
property $
do
n <- forAll (Gen.int (Range.linear 1 50))
length (pageImagePaths n "public/report.pdf.png") === n
pageImagePaths n "public/report.pdf.gif" === ["public/report.pdf.gif"]
prop_replaceTextEmpty :: Property
prop_replaceTextEmpty =
property $
do
t <- Text.pack <$> forAll genString
replaceText [] t === t
prop_replaceTextSame :: Property
prop_replaceTextSame =
property $
do
a <- Text.pack <$> forAll genWord
t <- Text.pack <$> forAll genString
replaceText [(a, a)] t === t
prop_replaceTextAbsent :: Property
prop_replaceTextAbsent =
property $
do
t <- Text.pack <$> forAll (Gen.string (Range.linear 0 30) Gen.lower)
b <- Text.pack <$> forAll genString
replaceText [("0", b)] t === t
prop_sha256Hex :: Property
prop_sha256Hex =
property $
do
s <- forAll genString
let h = sha256Hex (Char8.pack s)
length h === 64
assert (all isHexDigit h)
prop_xmlEscape :: Property
prop_xmlEscape =
property $
do
s <- forAll genString
assert (all (`notElem` ("<>\"'" :: String)) (xmlEscape s))
prop_shellQuote :: Property
prop_shellQuote =
property $
do
s <- forAll genString
let q = shellQuote s
assert (q == s || ("'" `isPrefixOf` q && "'" `isSuffixOf` q))
prop_flatZipped :: Property
prop_flatZipped =
property $
do
e <- forAll (Gen.element ["odt", "ods", "odp", "odg"])
(flatExtension e >>= zippedExtension) === Just e
prop_exitCodes :: Property
prop_exitCodes =
withTests 1 . property $
let errors =
[ ProcessOutputUnrecognised (CommandLine "" []) ""
, InputFileMissing ""
, OutputFileMissing (CommandLine "" []) ""
, StringsMissing "" ("" NonEmpty.:| [])
, FileTypeUnsupported "" []
, FileNotInGit ""
, FileNotUtf8 ""
, BuildCycle (RepeatsStep (Step "" "") (Trail []))
, InputFilesTooFew "" 0 0
, OutputNotInDirectory "" ""
, ShallowRepository ""
]
codes = fmap buildErrorExitCode errors
in length (nub codes) === length codes
prop_display :: Property
prop_display =
property $
do
e <- forAll genBuildError
let d = displayBuildError e
assert ("\n" `isSuffixOf` d)