module Test.Cardano.Tools.Headers (tests) where

import Cardano.Tools.Headers (ValidationResult (..), validate)
import qualified Data.Aeson as Json
import Data.Function ((&))
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy.Encoding (decodeUtf8)
import Test.Ouroboros.Consensus.Protocol.Praos.Header
  ( genContext
  , genMutatedHeader
  , genSample
  )
import Test.QuickCheck
  ( Property
  , counterexample
  , forAll
  , forAllBlind
  , label
  , property
  , (===)
  )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"HeaderValidation"
    [ [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"roundtrip To/FromJSON samples" Property
prop_roundtrip_json_samples
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"validate legit header" Property
prop_validate_legit_header
    ]

prop_roundtrip_json_samples :: Property
prop_roundtrip_json_samples :: Property
prop_roundtrip_json_samples =
  Gen Sample -> (Sample -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Sample
genSample ((Sample -> Property) -> Property)
-> (Sample -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Sample
sample ->
    let encoded :: ByteString
encoded = Sample -> ByteString
forall a. ToJSON a => a -> ByteString
Json.encode Sample
sample
        decoded :: Either [Char] Sample
decoded = ByteString -> Either [Char] Sample
forall a. FromJSON a => ByteString -> Either [Char] a
Json.eitherDecode ByteString
encoded
     in Either [Char] Sample
decoded Either [Char] Sample -> Either [Char] Sample -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Sample -> Either [Char] Sample
forall a b. b -> Either a b
Right Sample
sample

prop_validate_legit_header :: Property
prop_validate_legit_header :: Property
prop_validate_legit_header =
  Gen GeneratorContext -> (GeneratorContext -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen GeneratorContext
genContext ((GeneratorContext -> Property) -> Property)
-> (GeneratorContext -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \GeneratorContext
context ->
    Gen (GeneratorContext, MutatedHeader)
-> ((GeneratorContext, MutatedHeader) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (GeneratorContext -> Gen (GeneratorContext, MutatedHeader)
genMutatedHeader GeneratorContext
context) (((GeneratorContext, MutatedHeader) -> Property) -> Property)
-> ((GeneratorContext, MutatedHeader) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(GeneratorContext
context', MutatedHeader
header) ->
      GeneratorContext -> MutatedHeader -> Property -> Property
forall {prop} {a} {a}.
(Testable prop, ToJSON a, Show a) =>
a -> a -> prop -> Property
annotate GeneratorContext
context' MutatedHeader
header (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        case GeneratorContext -> MutatedHeader -> ValidationResult
validate GeneratorContext
context' MutatedHeader
header of
          Valid Mutation
mut -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
label (Mutation -> [Char]
forall a. Show a => a -> [Char]
show Mutation
mut)
          Invalid Mutation
mut [Char]
err -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Expected: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Mutation -> [Char]
forall a. Show a => a -> [Char]
show Mutation
mut [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\nError: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err)
 where
  annotate :: a -> a -> prop -> Property
annotate a
context a
header =
    [Char] -> prop -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
      ( [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
          [ [Char]
"context:"
          , a -> [Char]
forall a. ToJSON a => a -> [Char]
asJson a
context
          , [Char]
"header:"
          , a -> [Char]
forall a. Show a => a -> [Char]
show a
header
          ]
      )

  asJson :: Json.ToJSON a => a -> String
  asJson :: forall a. ToJSON a => a -> [Char]
asJson = Text -> [Char]
LT.unpack (Text -> [Char]) -> (a -> Text) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
Json.encode