Shrink index and minimal test file output support

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

@@ -27,7 +27,7 @@ import           Ouroboros.Network.PeerSelection.RelayAccessPoint (PortNumber)
 import           Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..),
                    WarmValency (..))
 
-import           Control.Monad (unless)
+import           Control.Monad (unless, when)
 import           Control.Tracer (Tracer (..), nullTracer, traceWith)
 import           Data.Aeson (Value, encode, encodeFile, object, throwDecode, (.=))
 import qualified Data.ByteString.Lazy.Char8 as BSL8
@@ -36,7 +36,8 @@ import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Map (Map)
 import qualified Data.Map as M
 import qualified Data.Map.Merge.Lazy as M
-import           Data.Maybe (fromJust)
+import           Data.Maybe (fromJust, isJust, isNothing)
+import           Data.Set (Set)
 import qualified Data.Set as S
 import           Data.Traversable
 import qualified Network.Socket as Socket
@@ -56,12 +57,60 @@ import           Test.Consensus.PointSchedule
 import           Test.Consensus.PointSchedule.Peers (PeerId (..), getPeerIds, peersOnlyHonest)
 import           Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..), scheduleBlockPoint,
                    scheduleHeaderPoint, scheduleTipPoint)
-import           Test.QuickCheck (generate, scale)
+import           Test.QuickCheck (Arbitrary, generate, scale)
 import           Test.Util.TestBlock (TestBlock, unTestHash)
 
 import           ExitCodes
 import           Query
 import           Server (run)
+import           ShrinkIndex (ShrinkIndex, ShrinkTree, arbitraryShrinkTree)
+import qualified ShrinkIndex as Ix
+
+instance Arbitrary (GenesisTest TestBlock (PointSchedule TestBlock))
+
+data TestResult = TestSuccess | TestFailure deriving Eq
+
+-- | This function makes implicit reference to the fact that 'ExitCodes.Success'
+-- is defined as the empty status flag pattern.
+testResultToFlag :: TestResult -> Set StatusFlag
+testResultToFlag result = case result of
+  TestFailure -> S.singleton TestFailed
+  TestSuccess -> mempty
+
+-- | A 'ShrinkIndex' signaling whether shrinking should proceed.
+data ContinuationIndex = ContinueShrinkingWith ShrinkIndex
+                       | ShrinkNoMore ShrinkIndex
+
+-- | Update a possibly absent 'ShrinkIndex' according to the 'TestResult'
+-- and signal if shrinking should proceed.
+-- POSTCONDITION: Any 'ShrinkIndex' within a 'ContinuationIndex'
+-- corresponds to a node on the given 'ShrinkTree'.
+indexUpdate :: TestResult
+            -> ShrinkTree a
+            -> Maybe ShrinkIndex
+            -> ContinuationIndex
+indexUpdate res tree inputIndex = case (res, inputIndex) of
+  -- A direct (global) test pass.
+  (TestSuccess, Nothing) -> ShrinkNoMore mempty
+  -- Test pass with a shrink index.
+  (TestSuccess, Just ix)
+    -- Global test pass (in disguise).
+    | ix == mempty -> ShrinkNoMore mempty
+    -- Local test pass (current node is not a property counterexample).
+    | otherwise -> case Ix.succ tree ix of
+      -- If sibling nodes have been exhausted, rollback
+      -- to the parent index. 'fromJust' is safe here
+      -- because the only index without parent is the
+      -- empty index.
+      Nothing -> ShrinkNoMore $ fromJust $ Ix.parent ix
+      Just ix' -> ContinueShrinkingWith ix'
+  -- When the test fails, try to stretch.
+  (TestFailure, Nothing) -> case Ix.stretch tree mempty of
+                              Nothing -> ShrinkNoMore mempty
+                              Just ix -> ContinueShrinkingWith ix
+  (TestFailure, Just ix) -> case Ix.stretch tree ix of
+                              Nothing -> ShrinkNoMore ix
+                              Just ix' -> ContinueShrinkingWith ix'
 
 buildPeerMap :: PortNumber -> PointSchedule blk -> Map PeerId PortNumber
 buildPeerMap firstPort = M.fromList . flip zip [firstPort ..] . getPeerIds . psSchedule
@@ -117,26 +166,67 @@ main :: IO ()
 main = do
   args <- getArgs
   opts <- parseOptions args
-  res <-
-    try @_ @SomeException $
-      runServer (optPort opts) (optSocketPath opts) (optOutputTopologyFile opts)
-  exitWithStatus $ case res of
-    Left _ -> InternalError
-    Right True -> Success
-    Right False -> Flags $ S.singleton TestFailed
-
-zipMaps :: Ord k => Map k a -> Map k b -> Map k (a, b)
-zipMaps = M.merge M.dropMissing M.dropMissing $ M.zipWithMatched $ const (,)
 
-runServer :: PortNumber -> FilePath -> FilePath -> IO Bool
-runServer firstPort socketPath outputTopologyPath = do
+  -- The test should be parsed from `optTestFile`, but its chain and acceptance
+  -- criteria are hard coded for convenience until the @testgen@ utility is implemented.
   -- 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.
-  chain <- generate $ scale (flip div 10) $ do
+  chain0 <- generate $ scale (flip div 10) $ do
     gt <- genChains $ pure 1
     pure $ gt {gtSchedule = rollbackSchedule 1 $ gtBlockTree gt}
 
+  let tree = arbitraryShrinkTree chain0
+      inputIndex = optShrinkIndex opts
+  chain <- case inputIndex of
+    -- Note that both no index and the empty index should
+    -- return the original chain. See [NOTE: shrink-index-properties]
+    Nothing -> pure chain0
+    Just ix -> case Ix.lookup ix tree of
+      Nothing -> do
+        putStrLn "Incorrect shrink index"
+        exitWithStatus BadUsage
+      Just chain' -> pure chain'
+
+  res <-
+    try @_ @SomeException $
+      runServer
+        (optPort opts)
+        (optSocketPath opts)
+        (optOutputTopologyFile opts)
+        chain
+  case res of
+    Left _ -> exitWithStatus InternalError
+    Right testRes -> do
+      mightContinueShrinking <- case indexUpdate testRes tree inputIndex of
+        ContinueShrinkingWith ix -> do
+          print ix
+          pure $ S.singleton ContinueShrinking
+        -- This following case includes a minimal counterexample being found or
+        -- a global test pass. A check for the latter case is needed to
+        -- account for the edge case were the root node is a minimal
+        -- counterexample. 
+        ShrinkNoMore ix -> do
+          let isGlobalPass =
+                testRes == TestSuccess &&
+                 (isNothing inputIndex || inputIndex == Just mempty)
+          case isJust (optMinimalTestOutput opts) && not isGlobalPass of
+            -- 'fromJust' is safe here because the parent of an index generated
+            -- by 'indexUpdate' is always on the tree
+            True -> encodeFile (fromJust $ optMinimalTestOutput opts) (fromJust (Ix.lookup ix tree))
+            False -> print ix
+          pure mempty
+      exitWithStatus . Flags $ testResultToFlag testRes <> mightContinueShrinking
+
+zipMaps :: Ord k => Map k a -> Map k b -> Map k (a, b)
+zipMaps = M.merge M.dropMissing M.dropMissing $ M.zipWithMatched $ const (,)
+
+runServer :: PortNumber
+          -> FilePath
+          -> FilePath
+          -> GenesisTest TestBlock (PointSchedule TestBlock)
+          -> IO TestResult
+runServer firstPort socketPath outputTopologyPath chain = do
   let ps = gtSchedule chain
       peerMap = buildPeerMap firstPort ps
 
@@ -256,7 +346,11 @@ runServer firstPort socketPath outputTopologyPath = do
   for_ peerServers $ uninterruptibleCancel . snd
 
   -- Return the test's acceptance criteria.
-  pure $ not . hashOnTrunk . AF.headHash $ svSelectedChain sv
+  -- This should be parsed out of the test file parameter, but is currently
+  -- hard coded for convenience.
+  pure $ case not . hashOnTrunk . AF.headHash $ svSelectedChain sv of
+    False -> TestFailure
+    True -> TestSuccess
 
 
 --------------------------------------------------------------------------------
@@ -272,6 +366,10 @@ hashOnTrunk (BlockHash hash) = all (== 0) $ unTestHash hash
 -- chain of the given block tree.
 --
 -- PRECONDITION: Block tree with at least one alternative chain.
+-- NOTE: This function is currently used to hard code the test case generation,
+-- which is not part of the @test-runner@ functionality.
+-- TODO: Make sure to handle the previous precondition appropriately when
+-- implementing @testgen@.
 rollbackSchedule :: AF.HasHeader blk => Int -> BlockTree blk -> PointSchedule blk
 rollbackSchedule n blockTree =
     let branch = case btBranches blockTree of