Address review comments

* remove changelog entry * add explicit export list * use generic JSON derivation
IntersectMBO · Nov 12, 2024 · fce0ef5 · fce0ef5
1 parent ab60963
commit fce0ef5
Show file tree

Hide file tree

Showing 3 changed files with 34 additions and 40 deletions.
diff --git a/...consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md b/...consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md
diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs
@@ -2,10 +2,14 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-missing-export-lists #-}
 
 -- | Tooling to generate and validate (Praos) headers.
-module Cardano.Tools.Headers where
+module Cardano.Tools.Headers (
+    Options (..)
+  , ValidationResult (..)
+  , run
+  , validate
+  ) where
 
 import           Cardano.Crypto.DSIGN (deriveVerKeyDSIGN)
 import           Cardano.Crypto.VRF

diff --git a/...-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/...-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs
@@ -1,14 +1,24 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-missing-export-lists #-}
 
-module Test.Ouroboros.Consensus.Protocol.Praos.Header where
+module Test.Ouroboros.Consensus.Protocol.Praos.Header (
+    GeneratorContext (..)
+  , MutatedHeader (..)
+  , Mutation (..)
+  , Sample (..)
+  , expectedError
+  , genContext
+  , genMutatedHeader
+  , genSample
+  , generateSamples
+  ) where
 
 import           Cardano.Crypto.DSIGN
                      (DSIGNAlgorithm (SignKeyDSIGN, genKeyDSIGN, rawSerialiseSignKeyDSIGN),
@@ -38,7 +48,7 @@ import           Cardano.Protocol.TPraos.OCert (KESPeriod (..), OCert (..),
                      OCertSignable (..))
 import           Cardano.Slotting.Block (BlockNo (..))
 import           Cardano.Slotting.Slot (SlotNo (..))
-import           Data.Aeson ((.:), (.=))
+import           Data.Aeson (defaultOptions, (.:), (.=))
 import qualified Data.Aeson as Json
 import           Data.Bifunctor (second)
 import           Data.ByteString (ByteString)
@@ -53,14 +63,15 @@ import           Data.Proxy (Proxy (..))
 import           Data.Ratio ((%))
 import           Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import           Data.Word (Word64)
+import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Protocol.Praos (PraosValidationErr (..))
 import           Ouroboros.Consensus.Protocol.Praos.Header (Header,
                      HeaderBody (..), pattern Header)
 import           Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF, mkInputVRF,
                      vrfLeaderValue)
 import           Ouroboros.Consensus.Protocol.TPraos (StandardCrypto)
 import           Test.QuickCheck (Gen, arbitrary, choose, frequency, generate,
-                     getPositive, resize, shrinkList, sized, suchThat, vectorOf)
+                     getPositive, resize, sized, suchThat, vectorOf)
 
 -- * Test Vectors
 
@@ -93,9 +104,6 @@ genMutatedHeader context = do
     mutation <- genMutation header
     mutate context header mutation
 
-shrinkSample :: Sample -> [Sample]
-shrinkSample Sample{sample} = Sample <$> shrinkList (const []) sample
-
 mutate :: GeneratorContext -> Header StandardCrypto -> Mutation -> Gen (GeneratorContext, MutatedHeader)
 mutate context header mutation =
     second (\h -> MutatedHeader{header = h, mutation}) <$> mutated
@@ -172,28 +180,12 @@ data Mutation
       MutateCounterOver1
     | -- | Mutate certificate counter to be lower than expected
       MutateCounterUnder
-    deriving (Eq, Show)
+    deriving (Eq, Show, Generic)
 
 instance Json.ToJSON Mutation where
-    toJSON = \case
-        NoMutation -> "NoMutation"
-        MutateKESKey -> "MutateKESKey"
-        MutateColdKey -> "MutateColdKey"
-        MutateKESPeriod -> "MutateKESPeriod"
-        MutateKESPeriodBefore -> "MutateKESPeriodBefore"
-        MutateCounterOver1 -> "MutateCounterOver1"
-        MutateCounterUnder -> "MutateCounterUnder"
-
-instance Json.FromJSON Mutation where
-    parseJSON = \case
-        "NoMutation" -> pure NoMutation
-        "MutateKESKey" -> pure MutateKESKey
-        "MutateColdKey" -> pure MutateColdKey
-        "MutateKESPeriod" -> pure MutateKESPeriod
-        "MutateKESPeriodBefore" -> pure MutateKESPeriodBefore
-        "MutateCounterOver1" -> pure MutateCounterOver1
-        "MutateCounterUnder" -> pure MutateCounterUnder
-        _ -> fail "Invalid mutation"
+    toEncoding = Json.genericToEncoding defaultOptions
+
+instance Json.FromJSON Mutation
 
 expectedError :: Mutation -> (PraosValidationErr StandardCrypto -> Bool)
 expectedError = \case
@@ -226,14 +218,15 @@ genMutation header =
         , (1, pure MutateKESPeriod)
         , (1, pure MutateKESPeriodBefore)
         , (1, pure MutateCounterUnder)
-        ] <> maybeCounterOver1
-     where
-       Header body _ = header
-       OCert{ocertN} = hbOCert body
-       maybeCounterOver1 =
-         if ocertN > 10
-           then [(1, pure MutateCounterOver1)]
-           else []
+        ]
+            <> maybeCounterOver1
+  where
+    Header body _ = header
+    OCert{ocertN} = hbOCert body
+    maybeCounterOver1 =
+        if ocertN > 10
+            then [(1, pure MutateCounterOver1)]
+            else []
 
 data MutatedHeader = MutatedHeader
     { header   :: !(Header StandardCrypto)