{-|
Module      : Test.Aeson.Internal.GoldenSpecs
Description : Golden tests for Arbitrary
Copyright   : (c) Plow Technologies, 2016
License     : BSD3
Maintainer  : mchaver@gmail.com
Stability   : Beta

Internal module, use at your own risk.
-}

{-# 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.ByteString.Lazy hiding (putStrLn)
import           Data.Int (Int32)
import           Data.Maybe (isJust)
import           Data.Proxy
import           Data.Typeable

import           Prelude hiding (readFile, writeFile)

import           System.Directory
import           System.Environment (lookupEnv)
import           System.FilePath
import           System.Random

import           Test.Aeson.Internal.RandomSamples
import           Test.Aeson.Internal.Utils
import           Test.Hspec
import           Test.HUnit.Lang (HUnitFailure)
import           Test.QuickCheck

-- | Tests to ensure that JSON encoding has not unintentionally changed. This
-- could be caused by the following:
--
-- - A type's instances of `ToJSON` or 'FromJSON' have changed.
-- - Selectors have been edited, added or deleted.
-- - You have changed version of Aeson the way Aeson serialization has changed
--   works.
--
-- If you run this function and the golden files do not
-- exist, it will create them for each constructor. It they do exist, it will
-- compare with golden file if it exists. Golden file encodes json format of a
-- type. It is recommended that you put the golden files under revision control
-- to help monitor changes.
goldenSpecs :: (Typeable a, Arbitrary a, ToJSON a, FromJSON a) =>
  Settings -> Proxy a -> Spec
goldenSpecs :: Settings -> Proxy a -> Spec
goldenSpecs settings :: Settings
settings proxy :: Proxy a
proxy = Settings -> Proxy a -> Maybe String -> Spec
forall a.
(Typeable a, Arbitrary a, ToJSON a, FromJSON a) =>
Settings -> Proxy a -> Maybe String -> Spec
goldenSpecsWithNote Settings
settings Proxy a
proxy Maybe String
forall a. Maybe a
Nothing

-- | same as 'goldenSpecs' but has the option of passing a note to the
-- 'describe' function.
goldenSpecsWithNote :: forall a. (Typeable a, Arbitrary a, ToJSON a, FromJSON a) =>
  Settings -> Proxy a -> Maybe String -> Spec
goldenSpecsWithNote :: Settings -> Proxy a -> Maybe String -> Spec
goldenSpecsWithNote settings :: Settings
settings@Settings{..} proxy :: Proxy a
proxy mNote :: Maybe String
mNote = do
  TypeNameInfo a
typeNameInfo    <- IO (TypeNameInfo a) -> SpecM () (TypeNameInfo a)
forall r a. IO r -> SpecM a r
runIO (IO (TypeNameInfo a) -> SpecM () (TypeNameInfo a))
-> IO (TypeNameInfo a) -> SpecM () (TypeNameInfo a)
forall a b. (a -> b) -> a -> b
$ Settings -> Proxy a -> IO (TypeNameInfo a)
forall a.
(Arbitrary a, Typeable a) =>
Settings -> Proxy a -> IO (TypeNameInfo a)
mkTypeNameInfo Settings
settings Proxy a
proxy
  Settings -> TypeNameInfo a -> Maybe String -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a) =>
Settings -> TypeNameInfo a -> Maybe String -> Spec
goldenSpecsWithNotePlain Settings
settings TypeNameInfo a
typeNameInfo Maybe String
mNote

-- | same as 'goldenSpecsWithNote' but does not require a Typeable, Eq or Show instance.
goldenSpecsWithNotePlain :: forall a. (Arbitrary a, ToJSON a, FromJSON a) =>
  Settings -> TypeNameInfo a -> Maybe String -> Spec
goldenSpecsWithNotePlain :: Settings -> TypeNameInfo a -> Maybe String -> Spec
goldenSpecsWithNotePlain settings :: Settings
settings@Settings{..} typeNameInfo :: TypeNameInfo a
typeNameInfo@(TypeNameInfo{TypeName
typeNameTypeName :: forall a. TypeNameInfo a -> TypeName
typeNameTypeName :: TypeName
typeNameTypeName}) mNote :: Maybe String
mNote = do
  let proxy :: Proxy a
proxy = Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a  
  let goldenFile :: String
goldenFile = TypeNameInfo a -> String
forall a. TypeNameInfo a -> String
mkGoldenFile TypeNameInfo a
typeNameInfo
      note :: String
note = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) Maybe String
mNote

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe ("JSON encoding of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
addBrackets  (TypeName -> String
unTypeName TypeName
typeNameTypeName) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
note) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it ("produces the same JSON as is found in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
goldenFile) (IO () -> Spec) -> IO () -> Spec
forall a b. (a -> b) -> a -> b
$ do
      Bool
exists <- String -> IO Bool
doesFileExist String
goldenFile
      let fixIfFlag :: e -> IO ()
fixIfFlag err :: e
err = do
            Bool
doFix <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "RECREATE_BROKEN_GOLDEN"
            if Bool
doFix
              then Settings -> Proxy a -> String -> IO ()
forall a.
(Arbitrary a, ToJSON a) =>
Settings -> Proxy a -> String -> IO ()
createGoldenfile Settings
settings Proxy a
proxy String
goldenFile
              else e -> IO ()
forall e a. Exception e => e -> IO a
throwIO e
err
      if Bool
exists
        then TypeNameInfo a -> Proxy a -> String -> ComparisonFile -> IO ()
forall a.
(Arbitrary a, ToJSON a, FromJSON a) =>
TypeNameInfo a -> Proxy a -> String -> ComparisonFile -> IO ()
compareWithGolden TypeNameInfo a
typeNameInfo Proxy a
proxy String
goldenFile ComparisonFile
comparisonFile
          IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`catches` [ (HUnitFailure -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(HUnitFailure
err :: HUnitFailure) -> HUnitFailure -> IO ()
forall e. Exception e => e -> IO ()
fixIfFlag HUnitFailure
err)
                    , (AesonDecodeError -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(AesonDecodeError
err :: AesonDecodeError) -> AesonDecodeError -> IO ()
forall e. Exception e => e -> IO ()
fixIfFlag AesonDecodeError
err)
                    ]
        else do
          Bool
doCreate <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "CREATE_MISSING_GOLDEN"
          if Bool
doCreate
            then Settings -> Proxy a -> String -> IO ()
forall a.
(Arbitrary a, ToJSON a) =>
Settings -> Proxy a -> String -> IO ()
createGoldenfile Settings
settings Proxy a
proxy String
goldenFile
            else HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Missing golden file: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
goldenFile

    
-- | The golden files already exist. Serialize values with the same seed from
-- the golden file and compare the with the JSON in the golden file.
compareWithGolden :: forall a .
  ( Arbitrary a, ToJSON a, FromJSON a) =>
  TypeNameInfo a ->  Proxy a  -> FilePath -> ComparisonFile ->IO ()
compareWithGolden :: TypeNameInfo a -> Proxy a -> String -> ComparisonFile -> IO ()
compareWithGolden typeNameInfo :: TypeNameInfo a
typeNameInfo proxy :: Proxy a
proxy goldenFile :: String
goldenFile comparisonFile :: ComparisonFile
comparisonFile = do
  Int32
goldenSeed <- ByteString -> IO Int32
readSeed (ByteString -> IO Int32) -> IO ByteString -> IO Int32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
readFile String
goldenFile
  Int
sampleSize <- ByteString -> IO Int
readSampleSize (ByteString -> IO Int) -> IO ByteString -> IO Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
readFile String
goldenFile
  RandomSamples a
newSamples <- Int -> Proxy a -> Int32 -> IO (RandomSamples a)
forall a.
Arbitrary a =>
Int -> Proxy a -> Int32 -> IO (RandomSamples a)
mkRandomSamples Int
sampleSize Proxy a
proxy Int32
goldenSeed
  IO () -> IO () -> IO ()
forall b c. IO c -> IO b -> IO b
whenFails (RandomSamples a -> IO ()
forall a. ToJSON a => a -> IO ()
writeComparisonFile RandomSamples a
newSamples) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ByteString
goldenBytes <- String -> IO ByteString
readFile String
goldenFile
    RandomSamples a
goldenSamples :: RandomSamples a <- ByteString -> IO (RandomSamples a)
forall a. FromJSON a => ByteString -> IO a
aesonDecodeIO ByteString
goldenBytes
    if RandomSamples a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys RandomSamples a
newSamples ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== RandomSamples a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys RandomSamples a
goldenSamples
      then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else do
        -- fallback to testing roundtrip decoding/encoding of golden file
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
          "WARNING: Encoding new random samples do not match " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
goldenFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
          "  Testing round-trip decoding/encoding of golden file."
        if RandomSamples a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys RandomSamples a
goldenSamples ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
goldenBytes
          then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else do
            RandomSamples a -> IO ()
forall a. ToJSON a => a -> IO ()
writeReencodedComparisonFile RandomSamples a
goldenSamples
            HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Serialization has changed. Compare golden file with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
faultyReencodedFilePath String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
  where
    whenFails :: forall b c . IO c -> IO b -> IO b
    whenFails :: IO c -> IO b -> IO b
whenFails = (IO b -> IO c -> IO b) -> IO c -> IO b -> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO b -> IO c -> IO b
forall a b. IO a -> IO b -> IO a
onException
    filePath :: String
filePath =
      case ComparisonFile
comparisonFile of
        FaultyFile -> TypeNameInfo a -> String
forall a. TypeNameInfo a -> String
mkFaultyFile TypeNameInfo a
typeNameInfo
        OverwriteGoldenFile -> String
goldenFile
    faultyReencodedFilePath :: String
faultyReencodedFilePath = TypeNameInfo a -> String
forall a. TypeNameInfo a -> String
mkFaultyReencodedFile TypeNameInfo a
typeNameInfo
    writeComparisonFile :: a -> IO ()
writeComparisonFile newSamples :: a
newSamples = do
      String -> ByteString -> IO ()
writeFile String
filePath (a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys a
newSamples)
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
        "INFO: Written the current encodings into " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filePath String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
    writeReencodedComparisonFile :: a -> IO ()
writeReencodedComparisonFile samples :: a
samples = do
      String -> ByteString -> IO ()
writeFile String
faultyReencodedFilePath (a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys a
samples)
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
        "INFO: Written the reencoded goldenFile into " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
faultyReencodedFilePath String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."

-- | The golden files do not exist. Create it.
createGoldenfile :: forall a . (Arbitrary a, ToJSON a) =>
  Settings -> Proxy a -> FilePath -> IO ()
createGoldenfile :: Settings -> Proxy a -> String -> IO ()
createGoldenfile Settings{..} proxy :: Proxy a
proxy goldenFile :: String
goldenFile = do
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
goldenFile)
  Int32
rSeed <- IO Int32
forall a. Random a => IO a
randomIO
  RandomSamples a
rSamples <- Int -> Proxy a -> Int32 -> IO (RandomSamples a)
forall a.
Arbitrary a =>
Int -> Proxy a -> Int32 -> IO (RandomSamples a)
mkRandomSamples Int
sampleSize Proxy a
proxy Int32
rSeed
  String -> ByteString -> IO ()
writeFile String
goldenFile (RandomSamples a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys RandomSamples a
rSamples)

  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    "WARNING: Running for the first time, not testing anything.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    "  Created " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
goldenFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ " containing random samples,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    "  will compare JSON encodings with this from now on.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    "  Please, consider putting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
goldenFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ " under version control."

-- | Create the file path for the golden file. Optionally use the module name to
-- help avoid name collissions. Different modules can have types of the same
-- name.
mkGoldenFile ::  TypeNameInfo a -> FilePath
mkGoldenFile :: TypeNameInfo a -> String
mkGoldenFile (TypeNameInfo{TopDir
typeNameTopDir :: forall a. TypeNameInfo a -> TopDir
typeNameTopDir :: TopDir
typeNameTopDir,Maybe ModuleName
typeNameModuleName :: forall a. TypeNameInfo a -> Maybe ModuleName
typeNameModuleName :: Maybe ModuleName
typeNameModuleName,TypeName
typeNameTypeName :: TypeName
typeNameTypeName :: forall a. TypeNameInfo a -> TypeName
typeNameTypeName}) =
  case Maybe ModuleName
typeNameModuleName of
    Nothing         -> TopDir -> String
unTopDir TopDir
typeNameTopDir String -> String -> String
</> TypeName -> String
unTypeName TypeName
typeNameTypeName String -> String -> String
<.> "json"
    Just moduleName :: ModuleName
moduleName -> TopDir -> String
unTopDir TopDir
typeNameTopDir String -> String -> String
</> ModuleName -> String
unModuleName ModuleName
moduleName String -> String -> String
</> TypeName -> String
unTypeName TypeName
typeNameTypeName String -> String -> String
<.> "json"

-- | Create the file path to save results from a failed golden test. Optionally
-- use the module name to help avoid name collisions.  Different modules can
-- have types of the same name.
mkFaultyFile :: TypeNameInfo a -> FilePath
mkFaultyFile :: TypeNameInfo a -> String
mkFaultyFile (TypeNameInfo {TypeName
typeNameTypeName :: TypeName
typeNameTypeName :: forall a. TypeNameInfo a -> TypeName
typeNameTypeName,Maybe ModuleName
typeNameModuleName :: Maybe ModuleName
typeNameModuleName :: forall a. TypeNameInfo a -> Maybe ModuleName
typeNameModuleName, TopDir
typeNameTopDir :: TopDir
typeNameTopDir :: forall a. TypeNameInfo a -> TopDir
typeNameTopDir})  =
  case ModuleName -> String
unModuleName (ModuleName -> String) -> Maybe ModuleName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModuleName
typeNameModuleName of
    Nothing         -> TopDir -> String
unTopDir TopDir
typeNameTopDir String -> String -> String
</> TypeName -> String
unTypeName TypeName
typeNameTypeName String -> String -> String
<.> "faulty" String -> String -> String
<.> "json"
    Just moduleName :: String
moduleName -> TopDir -> String
unTopDir TopDir
typeNameTopDir String -> String -> String
</>  String
moduleName String -> String -> String
</> TypeName -> String
unTypeName TypeName
typeNameTypeName String -> String -> String
<.> "faulty" String -> String -> String
<.> "json"

-- | Create the file path to save results from a failed fallback golden test. Optionally
-- use the module name to help avoid name collisions.  Different modules can
-- have types of the same name.
mkFaultyReencodedFile :: TypeNameInfo a -> FilePath
mkFaultyReencodedFile :: TypeNameInfo a -> String
mkFaultyReencodedFile (TypeNameInfo {TypeName
typeNameTypeName :: TypeName
typeNameTypeName :: forall a. TypeNameInfo a -> TypeName
typeNameTypeName,Maybe ModuleName
typeNameModuleName :: Maybe ModuleName
typeNameModuleName :: forall a. TypeNameInfo a -> Maybe ModuleName
typeNameModuleName, TopDir
typeNameTopDir :: TopDir
typeNameTopDir :: forall a. TypeNameInfo a -> TopDir
typeNameTopDir})  =
  case ModuleName -> String
unModuleName (ModuleName -> String) -> Maybe ModuleName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModuleName
typeNameModuleName of
    Nothing         -> TopDir -> String
unTopDir TopDir
typeNameTopDir String -> String -> String
</> TypeName -> String
unTypeName TypeName
typeNameTypeName String -> String -> String
<.> "faulty" String -> String -> String
<.> "reencoded" String -> String -> String
<.> "json"
    Just moduleName :: String
moduleName -> TopDir -> String
unTopDir TopDir
typeNameTopDir String -> String -> String
</>  String
moduleName String -> String -> String
</> TypeName -> String
unTypeName TypeName
typeNameTypeName String -> String -> String
<.> "faulty" String -> String -> String
<.> "reencoded"  String -> String -> String
<.> "json"

-- | Create a number of arbitrary instances of a type
-- a sample size and a random seed.
mkRandomSamples :: forall a . Arbitrary a =>
  Int -> Proxy a -> Int32 -> IO (RandomSamples a)
mkRandomSamples :: Int -> Proxy a -> Int32 -> IO (RandomSamples a)
mkRandomSamples sampleSize :: Int
sampleSize Proxy rSeed :: Int32
rSeed = Int32 -> [a] -> RandomSamples a
forall a. Int32 -> [a] -> RandomSamples a
RandomSamples Int32
rSeed ([a] -> RandomSamples a) -> IO [a] -> IO (RandomSamples a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [a] -> IO [a]
forall a. Gen a -> IO a
generate Gen [a]
gen
  where
    correctedSampleSize :: Int
correctedSampleSize = if Int
sampleSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 then 1 else Int
sampleSize
    gen :: Gen [a]
    gen :: Gen [a]
gen = Int -> Gen [a] -> Gen [a]
forall a. Int -> Gen a -> Gen a
setSeed (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
rSeed) (Gen [a] -> Gen [a]) -> Gen [a] -> Gen [a]
forall a b. (a -> b) -> a -> b
$ Int -> Gen a -> Gen [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
correctedSampleSize (Gen a
forall a. Arbitrary a => Gen a
arbitrary :: Gen a)