Parse serialized test cases in shrink viewer tool

cardano-node/app/conformance-test-runner.hs

@@ -19,7 +19,9 @@ import           Cardano.Node.Protocol.Cardano (mkCardanoProtocolParams)
 import           Cardano.Node.Run ()
 import           Cardano.Node.Types (ConfigYamlFilePath (..), NodeProtocolConfiguration (..))
 import           Cardano.Protocol.Crypto (StandardCrypto)
+import qualified Data.Aeson as Aeson
 import           Ouroboros.Consensus.Block (GetHeader (getHeader), Header)
+import           Ouroboros.Consensus.Block.Abstract
 import           Ouroboros.Consensus.Cardano (CardanoBlock)
 import           IssueTestBlock ()
 import           Ouroboros.Consensus.Cardano.Node (CardanoProtocolParams, protocolInfoCardano)
@@ -72,6 +74,7 @@ import           System.Environment (getArgs)
 import           Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..), onTrunk,
                    prettyBlockTree)
 import           Test.Consensus.Genesis.Setup.GenChains
+import           Test.Consensus.Genesis.Tests (GenesisTestKey)
 import           Test.Consensus.OrphanInstances ()
 import           Test.Consensus.PeerSimulator.Config ()
 import           Test.Consensus.PeerSimulator.NodeLifecycle
@@ -84,13 +87,22 @@ import           Test.Consensus.PointSchedule
 import           Test.Consensus.PointSchedule.Peers (PeerId (..), getPeerIds, peersOnlyHonest)
 import           Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..), scheduleBlockPoint,
                    scheduleHeaderPoint, scheduleTipPoint)
+import qualified Test.Consensus.Serialize as Serialize
 import           Test.QuickCheck (generate, scale)
+import           Test.QuickCheck.Gen (Gen, unGen)
+import           Test.QuickCheck.Random (QCGen, newQCGen)
+import           Test.Util.TestBlock (TestBlock, unTestHash)
 
 import           ExitCodes
 import           Query
 import           Server (run)
-import qualified ShrinkIndex as Ix
-import           ShrinkIndex (ShrinkIndex, ShrinkTree, makeShrinkTree)
+-- TODO(nbloomf): ShrinkIndex was moved upstream to ouroboros-consensus-diffusion because it
+-- is used in the serialization of test cases, but the local version is still in cardano-node.
+-- We're importing both here qualified because both are used; this is not a long-term
+-- solution but it is not yet clear where is the best place to put it.
+import qualified ShrinkIndex as OldIx
+import qualified Test.Consensus.Genesis.ShrinkIndex as Ix
+import           Test.Consensus.Genesis.ShrinkIndex (ShrinkIndex, ShrinkTree, makeShrinkTree)
 
 instance ( NodeInitStorage (CardanoBlock StandardCrypto)) => HasPointScheduleTestParams (CardanoBlock StandardCrypto) where
   data ProtocolInfoArgs (CardanoBlock StandardCrypto) = CardanoInfoArgs (CardanoProtocolParams StandardCrypto)
@@ -117,7 +129,7 @@ instance ( NodeInitStorage (CardanoBlock StandardCrypto)) => HasPointScheduleTes
 shrinkGenesisTest :: GenesisTestFull blk -> [GenesisTestFull blk]
 shrinkGenesisTest _ = []
 
-data TestResult = TestSuccess | TestFailure deriving (Eq, Ord, Show, Enum, Bounded)
+data TestResult = TestSuccess | TestFailure deriving (Eq, Show)
 
 -- | This function makes implicit reference to the fact that 'ExitCodes.Success'
 -- is defined as the empty status flag pattern.
@@ -218,15 +230,19 @@ main = do
   -- Generate a random RollBack test chain. We divide the test size by 10 here
   -- because 'TestBlock's have a hardcoded size of 100---anything longer will
   -- crash when being deserialized.
-  chain0 <- generate $ scale (`div` 10) $ do
-    gt <- genChains $ pure 1
-    pure $ gt {gtSchedule = rollbackSchedule 1 $ gtBlockTree gt}
+  seedGen <- newQCGen -- This will come from @testgen@ in the future.
+  let
+    quickCheckGenSize = 30
+    genChain = scale (flip div 10) $ do
+      gt <- genChains $ pure 1
+      pure $ gt {gtSchedule = rollbackSchedule 1 $ gtBlockTree gt}
+    chain0 = unGen genChain seedGen quickCheckGenSize
 
   let tree = makeShrinkTree shrinkGenesisTest chain0
       inputIndex = optShrinkIndex opts
   -- Note that both no index and the empty index must
   -- return the original chain. See [NOTE: shrink-index-properties]
-  chain <- case Ix.lookup (fold inputIndex) tree of
+  chain <- case Ix.lookup (foldMap convertShrinkIndex inputIndex) tree of
     Nothing -> do
       putStrLn "Incorrect shrink index"
       exitWithStatus BadUsage
@@ -239,10 +255,11 @@ main = do
         (optSimPeerPort opts)
         (optOutputTopologyFile opts)
         chain
+        seedGen
   case res of
     Left _ -> exitWithStatus InternalError
     Right testRes -> do
-      mightContinueShrinking <- case indexUpdate testRes tree (fold inputIndex) of
+      mightContinueShrinking <- case indexUpdate testRes tree (foldMap convertShrinkIndex inputIndex) of
         ContinueShrinkingWith ix -> do
           print ix
           pure $ S.singleton ContinueShrinking
@@ -254,11 +271,18 @@ main = do
           let isGlobalSuccess =
                 testRes == TestSuccess &&
                  (isNothing inputIndex || inputIndex == Just mempty)
+              testVersion = Serialize.TestVersion 1
+
+              -- When @testgen@ is implemented and we have real test case input, the
+              -- missing seed and test key will come from there.
+              serialize :: GenesisTestFull TestBlock -> Aeson.Value
+              serialize testCase = Serialize.serializeReifiedTestCase
+                Serialize.FormatVersionOne $ Serialize.toReifiedTestCase @_ @() -- TODO(nbloomf): test key type will be GenesisTestKey
+                  (error "main: test key not available") testVersion (gtBlockTree testCase)
+                  (gtSchedule testCase) ix (error "main: seed not available")
           case (optMinimalTestOutput opts, not isGlobalSuccess, Ix.lookup ix tree) of
-            -- TODO: Encoding is commented out for now because
-            -- the test file format is not available yet.
-            (Just minimalTestFilePath, True, Just chain') -> pure () -- encodeFile minimalTestFilePath chain'
-            (Nothing, True, Just chain') -> pure () -- print $ encode chain'
+            (Just minimalTestFilePath, True, Just chain') -> encodeFile minimalTestFilePath $ serialize chain'
+            (Nothing, True, Just chain') -> print $ encode $ serialize chain'
             _ -> pure ()
           pure mempty
       exitWithStatus . Flags $ testResultToFlag testRes <> mightContinueShrinking
@@ -396,10 +420,9 @@ runServer nutPort firstPort outputTopologyPath (GenesisTest {gtSchedule, gtSecur
   for_ peerServers $ uninterruptibleCancel . snd
 
   -- Return the test's acceptance criteria.
-
   -- This should be parsed out of the test file parameter and computed from
   -- the 'StateView', but is currently hard coded for convenience.
-  pure . boolToTestResult $ not . onTrunk gtBlockTree $ getTipPoint $ castTip tip
+  pure . boolToTestResult $ not . onTrunk gtBlockTree $ getTipPoint $ castTip tiprporate feedback)
 
 --------------------------------------------------------------------------------
 -- The remainder of this file is copied from the ouroboros-consensus
@@ -435,3 +458,8 @@ rollbackSchedule n blockTree =
     banalSchedulePoints = concatMap banalSchedulePoints' . AF.toOldestFirst
     banalSchedulePoints' :: blk -> [SchedulePoint blk]
     banalSchedulePoints' block = [scheduleTipPoint block, scheduleHeaderPoint block, scheduleBlockPoint block]
+
+-- | The 'ShrinkIndex' module is being moved to @ouroboros-consensus-diffusion@;
+-- this is a temporary shim until all references to the local module are removed.
+convertShrinkIndex :: OldIx.ShrinkIndex -> Ix.ShrinkIndex
+convertShrinkIndex (OldIx.Ix index) = Ix.path $ toList index

cardano-node/app/conformance-test-viewer.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Main (main) where
 
@@ -13,23 +15,31 @@ import           Prelude hiding (lookup)
 import           Control.Error.Util (failWith)
 import           Control.Monad.Except (ExceptT(), runExceptT, throwError, MonadError(..))
 import           Control.Monad.IO.Class (MonadIO(..), liftIO)
-import           Data.Aeson (eitherDecode, FromJSON(..), ToJSON(..))
+import           Data.Aeson (eitherDecode, FromJSON(..), ToJSON(..), withText)
+import qualified Data.Aeson as Aeson
 import           Data.Aeson.Encode.Pretty (encodePretty)
+import qualified Data.Aeson.KeyMap as Aeson
 import qualified Data.ByteString.Lazy as BS
 import           Data.Char (isDigit)
 import           Data.Function (on)
-import           Data.Proxy
 import           Data.List (groupBy)
+import qualified Data.Text as T () -- TODO: Waiting for test key parsing.
 import qualified ExitCodes as Exit
 import           Options.Applicative
-import           Ouroboros.Consensus.Byron.Ledger.Block
+import qualified Ouroboros.Network.AnchoredFragment as AF
 import           ShrinkIndex
 import           System.Environment (getArgs)
 import           System.IO (hPutStr, hPutStrLn, stderr)
+import           Test.Consensus.Genesis.Setup (ConformanceTest(..))
+import           Test.Consensus.Genesis.Tests (GenesisTestKey, testSuite)
+import           Test.Consensus.Genesis.TestSuite (at, getTest)
 import           Test.Consensus.OrphanInstances ()
-import           Test.Consensus.PointSchedule (GenesisTest, PointSchedule)
-import           Test.QuickCheck (Arbitrary(..))
+import           Test.Consensus.PeerSimulator.StateView (StateView(..))
+import           Test.Consensus.PointSchedule (GenesisTest(..), GenesisTestFull)
+import qualified Test.Consensus.Serialize as Serialize
+import qualified Test.QuickCheck.Gen as QC
 import           Text.Read (readEither)
+import           Test.Util.TestBlock (TestBlock)
 
 nameString, versionString :: String
 nameString    = "conformance-test-viewer"
@@ -41,7 +51,6 @@ data Options = Options
   { optInputPath    :: Maybe FilePath -- ^ Where to read input (default stdin)
   , optShrinkIndex  :: ShrinkIndex    -- ^ Which shrink of the input to analyze
   , optOutputPath   :: Maybe FilePath -- ^ Where to write output (default stdout)
-  , optTestCaseType :: TestCaseType   -- ^ For testing; specify a test case type
   , optMode         :: Mode
   } deriving (Eq, Show)
 
@@ -81,24 +90,16 @@ optionParser = Options
         [ metavar "FILE_PATH"
         , help "File path for writing output"
         ]))
-  <*> (option (eitherReader parseTestCaseType)
-    (long "type" <> mconcat
-      [ short 't'
-      , value GenesisTestTC
-      , metavar "TYPE"
-      , help "Which type of test case to parse"
-      ]))
   <*> pure ShowDescendant
 
 
 
 main :: IO ()
 main = do
-  args <- getArgs
-  opts <- getOptions args
+  opts <- getArgs >>= getOptions
 
   result <- runExceptT $ do
-    testCase <- getInputTestCase (optTestCaseType opts) (optInputPath opts)
+    testCase <- getInputTestCase (optInputPath opts)
     shrinkResult <- analyzeShrinkTree (optMode opts) (optShrinkIndex opts) testCase
     writeOutputTestCase (optOutputPath opts) shrinkResult
 
@@ -114,7 +115,10 @@ main = do
 -- we have to instantiate the input at a specific type. To achieve this
 -- we hide the concrete type `a` behind an existential.
 data ViewableTestCase where
-  TestCase :: (FromJSON a, ToJSON a, Arbitrary a) => a -> ViewableTestCase
+  TestCase
+    :: (a ~ GenesisTestFull blk, AF.HasHeader blk, Show blk)
+    => Serialize.ReifiedTestCase GenesisTestKey Serialize.BlockRep
+    -> a -> (a -> [a]) -> ViewableTestCase
 
 
 
@@ -131,44 +135,66 @@ getOptions args = do
       execCompletion compl nameString >>= putStr
       Exit.exitWithStatus Exit.Success
 
--- | Determine from the program options what type the input test
--- case should be instantiated at, and then read it.
 getInputTestCase
   :: (MonadError String m, MonadIO m)
-  => TestCaseType -> Maybe FilePath -> m ViewableTestCase
-getInputTestCase testCaseType inputPath = do
-  case testCaseType of
-    IntTC         -> readInputTestCase (Proxy :: Proxy Int)    inputPath
-    StringTC      -> readInputTestCase (Proxy :: Proxy String) inputPath
-    GenesisTestTC -> error "Genesis test not yet implemented!" -- readInputTestCase @(GenesisTest ByronBlock (PointSchedule ByronBlock)) -- TODO
-
--- | Read and parse a JSON-encoded test case either
--- from a file or from stdin.
-readInputTestCase
-  :: forall a m. (MonadError String m, MonadIO m)
-  => (ToJSON a, FromJSON a, Arbitrary a)
-  => Proxy a -> Maybe FilePath -> m ViewableTestCase
-readInputTestCase _ inputPath = do
+  => Maybe FilePath -> m ViewableTestCase
+getInputTestCase inputPath = do
   input <- liftIO $ maybe BS.getContents BS.readFile inputPath
-  fmap TestCase $ case eitherDecode input of
-    Right ok -> pure (ok :: a)
+  rawJson <- case eitherDecode input of
+    Right ok -> pure (ok :: Aeson.Value)
     Left err -> throwError $ "Input decoding error: " <> err
 
--- | Analyze the shrink tree of a value of any type that
--- implements `Arbitrary`, `FromJSON`, and `ToJSON`;
+  _rawKey <- case rawJson of
+    Aeson.Object o -> case Aeson.lookup "key" o of
+      Just (Aeson.String k) -> pure k
+      _ -> throwError "Malformed JSON: missing string field \"key\""
+    _ -> throwError "Malformed JSON: must be an object"
+  testKey <- error "getInputTestCase: test key parsing not yet implemented"
+    -- TODO(nbloomf): fix this once test keys are implemented
+    -- case parseKeyName (T.unpack rawKey) of
+    --  Just (k :: GenesisTestKey) -> pure k
+    --  Nothing -> throwError $ "Unrecognized test case key: " <> T.unpack rawKey
+
+  reifiedTestCase :: Serialize.ReifiedTestCase GenesisTestKey Serialize.BlockRep
+    <- case eitherDecode input of
+      Right ok -> pure ok
+      Left err -> throwError $ "Input decoding error: " <> err
+
+  let
+    -- The StateView is not used in the existing shrinkers, but if it ever
+    -- is we will need to update the serialized test cases to include it.
+    -- See @ouroboros-consensus-diffusion:Test.Consensus.PointSchedule.Shrinking@
+    stateView :: StateView TestBlock
+    stateView = error "getInputTestCase: Cannot construct an accurate StateView"
+
+    generator = ctGenerator conformanceTest
+    Serialize.Seed seed = Serialize.rtcSeed reifiedTestCase
+    conformanceTest = getTest . at testSuite $ testKey
+    -- QuickCheck's default size is 30, which we adjust to get the initial test case.
+    genesisTest = QC.unGen generator seed (ctMaxSize conformanceTest 30)
+    shrinker val = ctShrinker conformanceTest val stateView
+
+  pure $ TestCase reifiedTestCase genesisTest shrinker
+
+-- | Analyze the shrink tree of a value of any viewable test case;
 -- returns the resulting test case.
 analyzeShrinkTree
   :: (Monad m)
   => Mode -> ShrinkIndex -> ViewableTestCase -> ExceptT String m ViewableTestCase
-analyzeShrinkTree mode shrinkIndex (TestCase testCase) = fmap TestCase $
-  case mode of
+analyzeShrinkTree mode shrinkIndex (TestCase key testCase shrinker) =
+  let makeTestCase x = TestCase key x shrinker
+  in fmap makeTestCase $ case mode of
     ShowDescendant -> failWith "Descendant does not exist. :(" $
-      lookup shrinkIndex $ arbitraryShrinkTree testCase
+      lookup shrinkIndex $ ShrinkIndex.makeShrinkTree shrinker testCase
 
 writeOutputTestCase
   :: (MonadIO m) => Maybe FilePath -> ViewableTestCase -> m ()
-writeOutputTestCase outputPath (TestCase testCase) = do
-  let bytes = encodePretty testCase
+writeOutputTestCase outputPath (TestCase reifiedTestCase testCase _) = do
+  let
+    Serialize.ReifiedTestCase {..} = reifiedTestCase
+    bytes = encodePretty $ Serialize.serializeReifiedTestCase
+      Serialize.FormatVersionOne $ Serialize.toReifiedTestCase rtcTestKey rtcTestVersion
+        (gtBlockTree testCase) (gtSchedule testCase) rtcShrinkIndex rtcSeed
   liftIO $ case outputPath of
     Nothing -> BS.putStr bytes >> putStrLn ""
     Just oPath -> BS.writeFile oPath bytes
@@ -185,10 +211,3 @@ parseShrinkIndexOption :: String -> Either String ShrinkIndex
 parseShrinkIndexOption =
   fmap path . traverse readEither . filter (all isDigit) . groupBy bothDigits
   where bothDigits = on (&&) isDigit
-
-parseTestCaseType :: String -> Either String TestCaseType
-parseTestCaseType symbol = case symbol of
-  "int"     -> Right IntTC
-  "string"  -> Right StringTC
-  "genesis" -> Right GenesisTestTC
-  _ -> Left $ "Unrecognized test case type \"" <> symbol <> "\""

cardano-node/cardano-node.cabal

@@ -317,7 +317,6 @@ library conformance-testlib
                       , ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}
                       , ouroboros-consensus-diffusion:unstable-consensus-conformance-testlib
                       , ouroboros-network-api
-                      , aeson
                       , bytestring
                       , ouroboros-network-framework
                       , network
@@ -393,9 +392,11 @@ executable conformance-test-viewer
                       , errors
                       , mtl
                       , optparse-applicative
-                      , ouroboros-consensus-cardano
+                      , ouroboros-consensus:unstable-consensus-testlib
                       , ouroboros-consensus-diffusion:unstable-consensus-conformance-testlib
+                      , ouroboros-network-api
                       , QuickCheck
+                      , text
 
 executable conformance-test-gen
   import:               project-config

cardano-node/src-conformance-test/ShrinkIndex.hs

@@ -6,7 +6,7 @@
 -- | Indexing the shrinking tree
 module ShrinkIndex
   ( ShrinkTree,
-    ShrinkIndex,
+    ShrinkIndex(Ix),
     makeShrinkTree,
     arbitraryShrinkTree,
     arbitraryShrinkIndexWithin,