Merge #489

489: Assert that `ChainValidationState` is in normal form in `epochValid` prop r=ruhatch a=intricate I've added an option to `Test.Cardano.Chain.Block.Validation.tests` which either enables or disables an assertion to ensure that the `ChainValidationState` is always in normal form after validating each epoch. - In our existing `cardano-ledger-test` test-suite, we specify **not** to assert that the `ChainValidationState` is in normal form (`NoAssertNF`). - Added a new test executable, `epoch-validation-normal-form-test`, in which we specify to assert that the `ChainValidationState` is in normal form (`AssertNF`). I've also added a new CI job which builds and executes this without `hpc` coverage. The new test executable and CI job was added as a means of circumventing an "issue" which was encountered in our existing CI job. Because our existing CI job builds with `hpc` (`ghc -fhpc`/`stack --coverage`), thunks are introduced throughout our program for `hpc`'s program coverage measurement purposes and this prevents us from accurately determining whether a given expression is in normal form. So, following @erikd's advice, I've introduced this new test executable (which will be built without `hpc`) which basically just calls upon `Test.Cardano.Chain.Block.Validation.tests` and provides it with an argument of `AssertNF`. This way, we can still build and test our normal test-suite with code coverage and also test this new normal form assertion in a separate CI job. ### Notes The function [`heap_view_closurePtrs`](https://gitlab.haskell.org/ghc/ghc/blob/3bdf0d01ff47977830ada30ce85f174098486e23/rts/Heap.c#L79) in [`ghc/rts/Heap.c`](https://gitlab.haskell.org/ghc/ghc/blob/3bdf0d01ff47977830ada30ce85f174098486e23/rts/Heap.c) currently does not handle closures of type `CONSTR_NOCAF` and, as a result, it `fprintf`s a message to `stderr` every time it encounters one: `"closurePtrs: Cannot handle type CONSTR_NOCAF yet"`. Since the `isNormalForm` function utilizes this function it could get a bit "spammy" if we run into `CONSTR_NOCAF`s when running the test-suite. However, I've only seen that `CompactTxInUtxo`s are allocated as `CONSTR_NOCAF`s when we compile with `-O2`. In our CI jobs, we tend to use `stack --fast` (`-O0`) so we don't see this sort of spammy output to `stderr` in the logs. It's also worth noting that [Joachim Breitner has recently raised a PR with `ghc` for specifically handling `CONSTR_NOCAF` objects in `heap_view_closurePtrs`](https://gitlab.haskell.org/ghc/ghc/merge_requests/867) Co-authored-by: Luke Nadur <19835357+intricate@users.noreply.github.com> Co-authored-by: Rupert Horlick <rupert.horlick@iohk.io>
IntersectMBO · Jun 10, 2019 · 7f5263e · 7f5263e
2 parents 3a62c8c + 69cfac4
commit 7f5263e
Show file tree

Hide file tree

Showing 23 changed files with 247 additions and 75 deletions.
diff --git a/.buildkite/pipeline.yml b/.buildkite/pipeline.yml
@@ -1,9 +1,6 @@
 steps:
   - label: 'stack rebuild'
     env:
-      AWS_REGION: us-west-1
-      S3_BUCKET: appveyor-ci-cache
-      CACHE_S3_MAX_SIZE: 2500MB
       STACK_ROOT: "/build/cardano-ledger.stack"
     command:
       # cache-s3 needs a build directory that is the same across all buildkite agents.
@@ -16,13 +13,6 @@ steps:
     agents:
       system: x86_64-linux
 
-  # - label: 'brittany'
-  #   command:
-  #     - "nix-build scripts/brittany -o check-brittany"
-  #     - "./check-brittany"
-  #   agents:
-  #     system: x86_64-linux
-
   - label: 'nix-tools'
     command: 'scripts/buildkite/check-nix-tools.sh'
     agents:

diff --git a/.stack-to-nix.cache b/.stack-to-nix.cache
diff --git a/cabal.project b/cabal.project
@@ -18,12 +18,12 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-prelude
-  tag: a136c4242b9c9f6124b811329bc8ccdfd86c514e
+  tag: cca3c4f8da1de19321e96a5a7cca376bc6c37637
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-prelude
-  tag: a136c4242b9c9f6124b811329bc8ccdfd86c514e
+  tag: cca3c4f8da1de19321e96a5a7cca376bc6c37637
   subdir: test
 
 source-repository-package

diff --git a/cardano-ledger/cardano-ledger.cabal b/cardano-ledger/cardano-ledger.cabal
@@ -17,6 +17,11 @@ flag development
     default: False
     manual: True
 
+flag test-normal-form
+    description: Test ledger state normal form during epoch validation
+    default: False
+    manual: True
+
 library
   hs-source-dirs:      src
   exposed-modules:
@@ -263,3 +268,50 @@ test-suite cardano-ledger-test
 
   if (!flag(development))
     ghc-options:         -Werror
+
+test-suite epoch-validation-normal-form-test
+  if (!flag(test-normal-form))
+   buildable: False
+
+  hs-source-dirs:      test
+  main-is:             NormalFormTest.hs
+  type:                exitcode-stdio-1.0
+
+  other-modules:
+                       Test.Cardano.Chain.Block.Validation
+                       Test.Cardano.Chain.Config
+                       Test.Cardano.Mirror
+                       Test.Options
+
+  build-depends:       base
+                     , bytestring
+                     , cardano-binary
+                     , cardano-ledger
+                     , cardano-crypto-test
+                     , cardano-crypto-wrapper
+                     , cardano-prelude
+                     , cardano-prelude-test
+                     , containers
+                     , directory
+                     , filepath
+                     , formatting
+                     , hedgehog
+                     , optparse-applicative
+                     , resourcet
+                     , silently
+                     , streaming
+                     , tasty
+                     , tasty-hedgehog
+
+  default-language:    Haskell2010
+  default-extensions:  NoImplicitPrelude
+
+  ghc-options:         -Weverything
+                       -fno-warn-all-missed-specialisations
+                       -fno-warn-missing-import-lists
+                       -fno-warn-safe
+                       -fno-warn-unsafe
+                       "-with-rtsopts=-K450K -M500M"
+
+  if (!flag(development))
+    ghc-options:         -Werror
diff --git a/cardano-ledger/src/Cardano/Chain/Common/Address.hs b/cardano-ledger/src/Cardano/Chain/Common/Address.hs
@@ -74,7 +74,13 @@ import Formatting
   (Format, bprint, build, builder, formatToString, later, sformat)
 import qualified Formatting.Buildable as B
 import Text.JSON.Canonical
-  (FromJSON(..), FromObjectKey(..), JSValue(..), ToJSON(..), ToObjectKey(..))
+  ( FromJSON(..)
+  , FromObjectKey(..)
+  , JSValue(..)
+  , ToJSON(..)
+  , ToObjectKey(..)
+  , toJSString
+  )
 
 import Cardano.Binary
   ( DecoderError(..)
@@ -173,7 +179,7 @@ instance B.Buildable [Address] where
   build = bprint listJson
 
 instance Monad m => ToObjectKey m Address where
-  toObjectKey = pure . formatToString addressF
+  toObjectKey = pure . toJSString . formatToString addressF
 
 instance MonadError SchemaError m => FromObjectKey m Address where
   fromObjectKey = fmap Just . parseJSString fromCBORTextAddress . JSString

diff --git a/cardano-ledger/src/Cardano/Chain/Common/KeyHash.hs b/cardano-ledger/src/Cardano/Chain/Common/KeyHash.hs
@@ -17,7 +17,8 @@ import Control.Monad.Except (MonadError)
 import Data.Aeson (FromJSONKey, ToJSONKey)
 import Formatting (formatToString)
 import Formatting.Buildable (Buildable)
-import Text.JSON.Canonical (FromObjectKey(..), JSValue(..), ToObjectKey(..))
+import Text.JSON.Canonical
+  (FromObjectKey(..), JSValue(..), ToObjectKey(..), toJSString)
 
 import Cardano.Binary (FromCBOR, ToCBOR)
 import Cardano.Chain.Common.AddressHash
@@ -41,12 +42,12 @@ newtype KeyHash = KeyHash
              )
 
 instance Monad m => ToObjectKey m KeyHash where
-    toObjectKey = pure . formatToString hashHexF . unKeyHash
+  toObjectKey = pure . toJSString . formatToString hashHexF . unKeyHash
 
 instance MonadError SchemaError m => FromObjectKey m KeyHash where
-    fromObjectKey = fmap (Just . KeyHash)
-        . parseJSString decodeAbstractHash
-        . JSString
+  fromObjectKey = fmap (Just . KeyHash)
+    . parseJSString decodeAbstractHash
+    . JSString
 
 hashKey :: VerificationKey -> KeyHash
 hashKey = KeyHash . addressHash
diff --git a/cardano-ledger/src/Cardano/Chain/Delegation/Certificate.hs b/cardano-ledger/src/Cardano/Chain/Delegation/Certificate.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeSynonymInstances  #-}
 

diff --git a/cardano-ledger/src/Cardano/Chain/Update/Validation/Interface.hs b/cardano-ledger/src/Cardano/Chain/Update/Validation/Interface.hs
@@ -235,7 +235,9 @@ registerVote env st vote = do
   let
     appVersions' =
       currentSlot `seq`
-      M.fromList $! [ (svAppName sv, (svNumber sv, currentSlot))
+      M.fromList $! [ let !svAppName' = svAppName sv
+                          !svNumber'  = svNumber sv
+                      in (svAppName', (svNumber', currentSlot))
                     | (!pid, !sv) <- M.toList registeredSoftwareUpdateProposals
                     , pid `elem` M.keys confirmedProposals'
                     ]

diff --git a/cardano-ledger/test/NormalFormTest.hs b/cardano-ledger/test/NormalFormTest.hs
@@ -0,0 +1,34 @@
+{-|
+This module basically just runs the mainnet epoch validation tests from
+"Test.Cardano.Chain.Block.Validation" but provided a 'ShouldAssertNF' value of
+'AssertNF'.
+
+We've created a separate test executable for this as, in our typical CI jobs,
+we utilize @hpc@ (i.e. building with @ghc -fhpc@ or @stack --coverage@) for
+providing code coverage. @hpc@ appears to introduce thunks around our Haskell
+expressions for its program coverage measurement purposes which prevents us
+from accurately determining whether a given expression is in normal form. As a
+result, we have another CI job which will build and run this test executable
+without @hpc@.
+-}
+
+module Main
+  ( main
+  )
+where
+
+import Cardano.Prelude
+
+import System.IO.Silently (hSilence)
+
+import Test.Options (ShouldAssertNF (..), mainWithTestScenario, tsGroupToTree)
+
+import qualified Test.Cardano.Chain.Block.Validation
+
+
+main :: IO ()
+main =
+  hSilence [stderr]
+    . mainWithTestScenario
+    . tsGroupToTree
+    $ Test.Cardano.Chain.Block.Validation.tests AssertNF
diff --git a/cardano-ledger/test/Test/Cardano/Chain/Block/Validation.hs b/cardano-ledger/test/Test/Cardano/Chain/Block/Validation.hs
@@ -10,7 +10,6 @@ module Test.Cardano.Chain.Block.Validation
 where
 
 import Cardano.Prelude
-import Test.Cardano.Prelude
 
 import Control.Monad.Trans.Resource (ResIO, runResourceT)
 import qualified Data.Map.Strict as M
@@ -20,8 +19,10 @@ import Streaming (Of(..), Stream, hoist)
 import qualified Streaming.Prelude as S
 
 import Hedgehog
-  ( Property
+  ( Group(..)
+  , Property
   , PropertyT
+  , annotate
   , assert
   , discover
   , evalEither
@@ -37,7 +38,7 @@ import System.Environment (lookupEnv)
 import Cardano.Chain.Block
   ( ABlockOrBoundary(..)
   , ChainValidationError
-  , ChainValidationState
+  , ChainValidationState(..)
   , SigningHistory(..)
   , blockSlot
   , initialChainValidationState
@@ -54,15 +55,24 @@ import Cardano.Crypto (VerificationKey)
 import Test.Cardano.Chain.Config (readMainetCfg)
 import Test.Cardano.Crypto.Gen (genVerificationKey)
 import Test.Cardano.Mirror (mainnetEpochFiles)
-import Test.Options (TestScenario(..), TSGroup, TSProperty, concatTSGroups)
+import Test.Options
+  (ShouldAssertNF(..), TestScenario(..), TSGroup, TSProperty, concatTSGroups)
 
 
 -- | These tests perform chain validation over mainnet epoch files
-tests :: TSGroup
-tests = concatTSGroups [const $$discover, $$discoverPropArg]
-
-ts_prop_mainnetEpochsValid :: TSProperty
-ts_prop_mainnetEpochsValid scenario = withTests 1 . property $ do
+tests :: ShouldAssertNF -> TSGroup
+tests shouldAssertNF = concatTSGroups
+  [ const $$discover
+  , \scenario -> Group
+    "Test.Cardano.Chain.Block.Validation"
+    [ ( "ts_prop_mainnetEpochsValid"
+      , ts_prop_mainnetEpochsValid shouldAssertNF scenario
+      )
+    ]
+  ]
+
+ts_prop_mainnetEpochsValid :: ShouldAssertNF -> TSProperty
+ts_prop_mainnetEpochsValid shouldAssertNF scenario = withTests 1 . property $ do
   menv <- liftIO $ lookupEnv "CARDANO_MAINNET_MIRROR"
   assert $ isJust menv
 
@@ -84,8 +94,15 @@ ts_prop_mainnetEpochsValid scenario = withTests 1 . property $ do
 
   let stream = parseEpochFilesWithBoundary (configEpochSlots config) files
 
+  annotate ("Did you build with `ghc -fhpc` or `stack --coverage`?\n"
+    <> "If so, please be aware that hpc will introduce thunks around "
+    <> "expressions for its program coverage measurement purposes and "
+    <> "this assertion can fail as a result.\n"
+    <> "Otherwise, for some reason, the `ChainValidationState` is not in "
+    <> "normal form.")
+
   result <- (liftIO . runResourceT . runExceptT)
-    (foldChainValidationState config cvs stream)
+    (foldChainValidationState shouldAssertNF config cvs stream)
 
   void $ evalEither result
 
@@ -96,26 +113,40 @@ data Error
   deriving (Eq, Show)
 
 
-
 -- | Fold chain validation over a 'Stream' of 'Block's
 foldChainValidationState
-  :: Genesis.Config
+  :: ShouldAssertNF
+  -> Genesis.Config
   -> ChainValidationState
   -> Stream (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
   -> ExceptT Error ResIO ChainValidationState
-foldChainValidationState config cvs blocks =
-  S.foldM_ validate (pure cvs) pure (hoist (withExceptT ErrorParseError) blocks)
+foldChainValidationState shouldAssertNF config cvs blocks = S.foldM_
+  validate
+  (pure cvs)
+  pure
+  (hoist (withExceptT ErrorParseError) blocks)
  where
   validate
-     :: Monad m
-     => ChainValidationState
-     -> ABlockOrBoundary ByteString
-     -> ExceptT Error m ChainValidationState
+    :: MonadIO m
+    => ChainValidationState
+    -> ABlockOrBoundary ByteString
+    -> ExceptT Error m ChainValidationState
   validate c b =
-    withExceptT (ErrorChainValidationError (blockOrBoundarySlot b)) $
-      case b of
-        ABOBBoundary bvd   -> updateChainBoundary c bvd
-        ABOBBlock    block -> updateBlock config c block
+    withExceptT (ErrorChainValidationError (blockOrBoundarySlot b))
+      $ case b of
+          ABOBBoundary bvd -> do
+            case shouldAssertNF of
+              AssertNF -> do
+                isNF <- liftIO $ isNormalForm $! c
+                unless
+                  isNF
+                  (  panic
+                  $  "ChainValidationState not in normal form at slot: "
+                  <> show (cvsLastSlot c)
+                  )
+              NoAssertNF -> pure ()
+            updateChainBoundary c bvd
+          ABOBBlock block -> updateBlock config c block
 
   blockOrBoundarySlot :: ABlockOrBoundary a -> Maybe FlatSlotId
   blockOrBoundarySlot = \case

diff --git a/cardano-ledger/test/Test/Options.hs b/cardano-ledger/test/Test/Options.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications  #-}
 
@@ -12,6 +13,8 @@ module Test.Options
   , TSGroup
   , concatGroups
   , concatTSGroups
+  , tsGroupToTree
+  , ShouldAssertNF (..)
   )
 where
 
@@ -21,7 +24,10 @@ import Test.Cardano.Prelude
 import GHC.Stack (withFrozenCallStack)
 
 import Hedgehog (Gen, Group(..), Property, PropertyT, TestLimit, withTests)
-import Test.Tasty (TestTree, defaultMainWithIngredients, includingOptions)
+import Hedgehog.Internal.Property (GroupName(..), PropertyName(..))
+import Test.Tasty
+  (TestTree, askOption, defaultMainWithIngredients, includingOptions, testGroup)
+import Test.Tasty.Hedgehog (testProperty)
 import Test.Tasty.Ingredients (Ingredient(..), composeReporters)
 import Test.Tasty.Ingredients.Basic (consoleTestReporter, listingTests)
 import Test.Tasty.Options
@@ -77,6 +83,13 @@ concatGroups gs@(g : _) = Group (groupName g) (concat $ groupProperties <$> gs)
 concatTSGroups :: [TSGroup] -> TSGroup
 concatTSGroups gs ts = concatGroups $ ($ ts) <$> gs
 
+tsGroupToTree :: TSGroup -> TestTree
+tsGroupToTree tsGroup = askOption $ \scenario -> case tsGroup scenario of
+  Group { groupName, groupProperties } -> testGroup
+    (unGroupName groupName)
+    (uncurry testProperty . first unPropertyName <$> groupProperties)
+
+
 -- | Convenient alias for TestScenario-dependent @Property@s
 type TSProperty = TestScenario -> Property
 
@@ -131,3 +144,12 @@ withTestsTS
   -> Property
 withTestsTS count prop scenario =
   withTests (scenarioScaled count scenario) prop
+
+--------------------------------------------------------------------------------
+-- ShouldAssertNF
+--------------------------------------------------------------------------------
+
+data ShouldAssertNF
+  = AssertNF
+  | NoAssertNF
+  deriving (Eq, Show)