{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Test.Aeson.Internal.GoldenSpecs where
import Control.Exception
import Control.Monad
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.ByteString.Lazy hiding (putStrLn)
import Data.Proxy
import Data.Typeable
import Prelude hiding (readFile, writeFile)
import System.Directory
import System.FilePath
import System.Random
import Test.Aeson.Internal.RandomSamples
import Test.Aeson.Internal.Utils
import Test.Hspec
import Test.QuickCheck
goldenSpecs :: (Typeable a, Arbitrary a, ToJSON a, FromJSON a) =>
Settings -> Proxy a -> Spec
goldenSpecs settings proxy = goldenSpecsWithNote settings proxy Nothing
goldenSpecsWithNote :: forall a. (Typeable a, Arbitrary a, ToJSON a, FromJSON a) =>
Settings -> Proxy a -> Maybe String -> Spec
goldenSpecsWithNote settings@Settings{..} proxy mNote = do
typeNameInfo <- runIO $ mkTypeNameInfo settings proxy
goldenSpecsWithNotePlain settings typeNameInfo mNote
goldenSpecsWithNotePlain :: forall a. (Arbitrary a, ToJSON a, FromJSON a) =>
Settings -> TypeNameInfo a -> Maybe String -> Spec
goldenSpecsWithNotePlain settings@Settings{..} typeNameInfo@(TypeNameInfo{typeNameTypeName}) mNote = do
let proxy = Proxy :: Proxy a
let goldenFile = mkGoldenFile typeNameInfo
note = maybe "" (" " ++) mNote
describe ("JSON encoding of " ++ addBrackets (unTypeName typeNameTypeName) ++ note) $
it ("produces the same JSON as is found in " ++ goldenFile) $ do
exists <- doesFileExist goldenFile
if exists
then compareWithGolden typeNameInfo proxy goldenFile comparisonFile
else createGoldenfile settings proxy goldenFile
compareWithGolden :: forall a .
( Arbitrary a, ToJSON a, FromJSON a) =>
TypeNameInfo a -> Proxy a -> FilePath -> ComparisonFile ->IO ()
compareWithGolden typeNameInfo proxy goldenFile comparisonFile = do
goldenSeed <- readSeed =<< readFile goldenFile
sampleSize <- readSampleSize =<< readFile goldenFile
newSamples <- mkRandomSamples sampleSize proxy goldenSeed
whenFails (writeComparisonFile newSamples) $ do
goldenBytes <- readFile goldenFile
goldenSamples :: RandomSamples a <-
either (throwIO . ErrorCall) return $
eitherDecode' goldenBytes
if encode newSamples == encode goldenSamples
then return ()
else do
putStrLn $
"\n" ++
"WARNING: Encoding new random samples do not match " ++ goldenFile ++ ".\n" ++
" Testing round-trip decoding/encoding of golden file."
if encodePretty goldenSamples == goldenBytes
then return ()
else do
writeReencodedComparisonFile goldenSamples
expectationFailure $ "Serialization has changed. Compare golden file with " ++ faultyReencodedFilePath ++ "."
where
whenFails :: forall b c . IO c -> IO b -> IO b
whenFails = flip onException
filePath =
case comparisonFile of
FaultyFile -> mkFaultyFile typeNameInfo
OverwriteGoldenFile -> goldenFile
faultyReencodedFilePath = mkFaultyReencodedFile typeNameInfo
writeComparisonFile newSamples = do
writeFile filePath (encodePretty newSamples)
putStrLn $
"\n" ++
"INFO: Written the current encodings into " ++ filePath ++ "."
writeReencodedComparisonFile samples = do
writeFile faultyReencodedFilePath (encodePretty samples)
putStrLn $
"\n" ++
"INFO: Written the reencoded goldenFile into " ++ faultyReencodedFilePath ++ "."
createGoldenfile :: forall a . (Arbitrary a, ToJSON a) =>
Settings -> Proxy a -> FilePath -> IO ()
createGoldenfile Settings{..} proxy goldenFile = do
createDirectoryIfMissing True (takeDirectory goldenFile)
rSeed <- randomIO
rSamples <- mkRandomSamples sampleSize proxy rSeed
writeFile goldenFile (encodePretty rSamples)
putStrLn $
"\n" ++
"WARNING: Running for the first time, not testing anything.\n" ++
" Created " ++ goldenFile ++ " containing random samples,\n" ++
" will compare JSON encodings with this from now on.\n" ++
" Please, consider putting " ++ goldenFile ++ " under version control."
mkGoldenFile :: TypeNameInfo a -> FilePath
mkGoldenFile (TypeNameInfo{typeNameTopDir,typeNameModuleName,typeNameTypeName}) =
case typeNameModuleName of
Nothing -> unTopDir typeNameTopDir </> unTypeName typeNameTypeName <.> "json"
Just moduleName -> unTopDir typeNameTopDir </> unModuleName moduleName </> unTypeName typeNameTypeName <.> "json"
mkFaultyFile :: TypeNameInfo a -> FilePath
mkFaultyFile (TypeNameInfo {typeNameTypeName,typeNameModuleName, typeNameTopDir}) =
case unModuleName <$> typeNameModuleName of
Nothing -> unTopDir typeNameTopDir </> unTypeName typeNameTypeName <.> "faulty" <.> "json"
Just moduleName -> unTopDir typeNameTopDir </> moduleName </> unTypeName typeNameTypeName <.> "faulty" <.> "json"
mkFaultyReencodedFile :: TypeNameInfo a -> FilePath
mkFaultyReencodedFile (TypeNameInfo {typeNameTypeName,typeNameModuleName, typeNameTopDir}) =
case unModuleName <$> typeNameModuleName of
Nothing -> unTopDir typeNameTopDir </> unTypeName typeNameTypeName <.> "faulty" <.> "reencoded" <.> "json"
Just moduleName -> unTopDir typeNameTopDir </> moduleName </> unTypeName typeNameTypeName <.> "faulty" <.> "reencoded" <.> "json"
mkRandomSamples :: forall a . Arbitrary a =>
Int -> Proxy a -> Int -> IO (RandomSamples a)
mkRandomSamples sampleSize Proxy rSeed = RandomSamples rSeed <$> generate gen
where
correctedSampleSize = if sampleSize <= 0 then 1 else sampleSize
gen :: Gen [a]
gen = setSeed rSeed $ replicateM correctedSampleSize (arbitrary :: Gen a)