speedup tests

cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -16,24 +17,31 @@ module Cardano.Mock.Forging.Interpreter
   , MockBlock (..)
   , NodeId (..)
   , initInterpreter
+  , withInterpreter
   , forgeNext
   , forgeNextAfter
   , registerAllStakeCreds
   , withAlonzoLedgerState
   , withShelleyLedgerState
   ) where
 
+import           Cardano.Prelude (bimap)
+
 import           Control.Monad
 import           Control.Monad.Except
 import           Control.Tracer
+import           Data.Aeson
+import qualified Data.List as List
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.SOP.Strict (NS (S, Z))
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
+import           Data.Word (Word64)
 import           GHC.Generics
 import           NoThunks.Class (OnlyCheckWhnfNamed (..))
+import           System.Directory
 
 import           Ouroboros.Consensus.Block hiding (blockMatchesHeader)
 import qualified Ouroboros.Consensus.Block as Block
@@ -69,6 +77,7 @@ data Interpreter = Interpreter
   , iState :: StrictMVar IO InterpreterState
   , iTracerForge :: Tracer IO (ForgeStateInfo CardanoBlock)
   , iTopLeverConfig :: TopLevelConfig CardanoBlock
+  , iFingerMode :: FingerprintMode
   }
 
 data InterpreterState = InterpreterState
@@ -78,9 +87,74 @@ data InterpreterState = InterpreterState
   -- ^ The first slot to try the next block
   , isNextBlockNo :: !BlockNo
   -- ^ the block number of the block to be forged
+  , isFingerprint :: Fingerprint
+  -- ^ newest first list of slots where blocks were succesfully produced.
   } deriving Generic
     deriving NoThunks via OnlyCheckWhnfNamed "InterpreterState" InterpreterState
 
+-- | Vrf and leader election is pseudo-random.
+-- Running a simulation multiple times, will always give the same result.
+-- So afer the first simulation, we can reuse the slots, stored in some file
+-- to avoid costly executions.
+-- 'SearchSlots' mode starts from an empty list of slots and progressively
+-- fills the list. Eventually the list is dumbed to the 'FilePath'.
+-- 'ValidateSlots' mode starts from the list of slots and validates that the given
+-- leader can indeed forge the next slot every time.
+data FingerprintMode = SearchSlots FilePath | ValidateSlots
+
+newtype Fingerprint = Fingerprint [Word64]
+  deriving (Generic, FromJSON, ToJSON)
+
+mkFingerprint :: FilePath -> IO (FingerprintMode, Fingerprint)
+mkFingerprint path = do
+  print path
+  thereIsFile <- doesPathExist path
+  if thereIsFile then do
+    mfingerPrint <- eitherDecodeFileStrict path
+    fingerPrint <- either (throwIO . FingerprintDecodeError) pure mfingerPrint
+    -- we need to reverse since this is newest first
+    pure (ValidateSlots, fingerPrint)
+  else
+    pure (SearchSlots path, emptyFingerprint)
+
+isSearchingMode :: FingerprintMode -> Bool
+isSearchingMode (SearchSlots _) = True
+isSearchingMode _ = False
+
+-- | Given the current slot, return the slot to test and the next 'Fingerprint'
+getFingerTipSlot :: FingerprintMode -> Fingerprint -> SlotNo -> Either ForgingError SlotNo
+getFingerTipSlot mode fingerprint currentSlotNo = case mode of
+  SearchSlots _
+    -> Right currentSlotNo
+  ValidateSlots | Just slotNo <- fst <$> unconsFingerprint fingerprint
+    -> Right slotNo
+  _ -> Left $ EmptyFingerprint currentSlotNo
+
+addSlot :: Fingerprint -> SlotNo -> Fingerprint
+addSlot (Fingerprint slots) slot = Fingerprint (unSlotNo slot : slots)
+
+unconsFingerprint :: Fingerprint -> Maybe (SlotNo, Fingerprint)
+unconsFingerprint (Fingerprint slots) =
+  bimap SlotNo Fingerprint <$> List.uncons slots
+
+lengthSlots :: Fingerprint -> Int
+lengthSlots (Fingerprint slots) = length slots
+
+emptyFingerprint :: Fingerprint
+emptyFingerprint = Fingerprint []
+
+reverseFingerprint :: Fingerprint -> Fingerprint
+reverseFingerprint (Fingerprint slots) = Fingerprint $ reverse slots
+
+finalizeFingerprint :: Interpreter -> IO ()
+finalizeFingerprint inter = do
+    interState <- readMVar $ iState inter
+    case iFingerMode inter of
+      SearchSlots fp -> do
+        print $ "Dumping slots to " <> fp
+        encodeFile fp $ reverseFingerprint $ isFingerprint interState
+      ValidateSlots -> pure ()
+
 deriving instance Generic (ChainDB CardanoBlock)
 
 deriving instance NoThunks (Forecast a)
@@ -89,17 +163,20 @@ deriving instance Generic (Forecast a)
 
 initInterpreter :: ProtocolInfo IO CardanoBlock
                 -> Tracer IO (ForgeStateInfo CardanoBlock)
+                -> FilePath
                 -> IO Interpreter
-initInterpreter pinfo traceForge = do
+initInterpreter pinfo traceForge fingerprintFile = do
   forging <- pInfoBlockForging pinfo
   let topLeverCfg = pInfoConfig pinfo
   let initSt = pInfoInitLedger pinfo
   let ledgerView = mkForecast topLeverCfg initSt
+  (mode, fingerprint) <- mkFingerprint fingerprintFile
   let initState = InterpreterState
         { isChain = initChainDB topLeverCfg initSt
         , isForecast = ledgerView
         , isSlot = SlotNo 0
         , isNextBlockNo = BlockNo 0
+        , isFingerprint = fingerprint
         }
   print $ initChainDB topLeverCfg initSt
   stvar <- newMVar initState
@@ -108,12 +185,40 @@ initInterpreter pinfo traceForge = do
     , iState = stvar
     , iTracerForge = traceForge
     , iTopLeverConfig = topLeverCfg
+    , iFingerMode = mode
     }
 
-forgeNextAfter :: Interpreter -> SlotNo -> MockBlock -> IO CardanoBlock
+withInterpreter :: ProtocolInfo IO CardanoBlock
+                -> Tracer IO (ForgeStateInfo CardanoBlock)
+                -> FilePath
+                -> (Interpreter -> IO a)
+                -> IO a
+withInterpreter p t f action = do
+  interpreter <- initInterpreter p t f
+  a <- action interpreter
+  finalizeFingerprint interpreter
+  pure a
+
+addOrValidateSlot :: FingerprintMode
+                  -> Fingerprint
+                  -> CardanoBlock
+                  -> Either ForgingError Fingerprint
+addOrValidateSlot mode fingerprint blk =
+  case mode of
+    SearchSlots _ -> Right $ addSlot fingerprint (blockSlot blk)
+    ValidateSlots -> case unconsFingerprint fingerprint of
+      Nothing -> Left $ EmptyFingerprint (blockSlot blk)
+      Just (slotNo, fingerPrint') | slotNo == (blockSlot blk)
+        -> Right fingerPrint'
+      Just (slotNo, fingerPrint')
+        -- The validation here is unecessary, since we have used the slot to
+        -- forge the block. But we do it nontheless as a sanity check.
+        -> Left $ NotExpectedSlotNo (blockSlot blk) slotNo (lengthSlots fingerPrint')
+
+forgeNextAfter :: Interpreter -> Word64 -> MockBlock -> IO CardanoBlock
 forgeNextAfter interpreter skipSlots testBlock = do
     modifyMVar (iState interpreter) $ \st ->
-      pure $ (st { isSlot = isSlot st + skipSlots }, ())
+      pure $ (st { isSlot = isSlot st + SlotNo skipSlots }, ())
     forgeNext interpreter testBlock
 
 forgeNext :: Interpreter -> MockBlock -> IO CardanoBlock
@@ -122,27 +227,45 @@ forgeNext interpreter testBlock = do
     case Map.lookup (unNodeId $ node testBlock) (iForging interpreter) of
       Nothing -> throwIO $ NonExistantNode (node testBlock)
       Just forging -> do
-        blk <- tryConsecutiveSlots interState forging 0 (isSlot interState)
+        (blk, fingerprint) <- tryOrValidateSlot interState forging
         let !chain' = extendChainDB (isChain interState) blk
         let !newSt = currentState chain'
         let newInterState = InterpreterState
               { isChain = chain'
               , isForecast = mkForecast cfg newSt
               , isSlot = blockSlot blk + 1
               , isNextBlockNo = blockNo blk + 1
+              , isFingerprint = fingerprint
               }
         _ <- swapMVar (iState interpreter) newInterState
         pure blk
   where
     cfg = iTopLeverConfig interpreter
 
-    tryConsecutiveSlots :: InterpreterState
-                        -> BlockForging IO CardanoBlock
-                        -> Int
-                        -> SlotNo
-                        -> IO CardanoBlock
-    tryConsecutiveSlots interState blockForging numberOfTries currentSlot = do
-      let tryNext :: IO CardanoBlock = tryConsecutiveSlots interState blockForging (numberOfTries + 1) (currentSlot + 1)
+    tryOrValidateSlot :: InterpreterState
+                      -> BlockForging IO CardanoBlock
+                      -> IO (CardanoBlock, Fingerprint)
+    tryOrValidateSlot interState blockForging = do
+      currentSlot <- throwLeft $
+        getFingerTipSlot (iFingerMode interpreter) (isFingerprint interState) (isSlot interState)
+      trySlots interState blockForging 0 currentSlot (isSearchingMode (iFingerMode interpreter))
+
+    trySlots :: InterpreterState
+             -> BlockForging IO CardanoBlock
+             -> Int
+             -> SlotNo
+             -> Bool
+             -> IO (CardanoBlock, Fingerprint)
+    trySlots interState blockForging numberOfTries currentSlot searching = do
+      let callFailed = if searching
+            then trySlots interState blockForging (numberOfTries + 1) (currentSlot + 1) searching
+            else throwIO $ FailedToValidateSlot currentSlot (lengthSlots (isFingerprint interState))
+
+          callSuccedded blk = do
+            fingerprint' <- throwLeft $
+                addOrValidateSlot (iFingerMode interpreter) (isFingerprint interState) blk
+            pure (blk, fingerprint')
+
       when (numberOfTries > 1000) (throwIO WentTooFar)
 
       -- We require the ticked ledger view in order to construct the ticked
@@ -177,13 +300,13 @@ forgeNext interpreter testBlock = do
         ForgeStateUpdateError err -> do
           Text.putStrLn $ Text.unwords
             ["TraceForgeStateUpdateError", textShow currentSlot, textShow err]
-          tryNext
+          callFailed
         CannotForge cannotForge -> do
           Text.putStrLn $ Text.unwords
             ["TraceNodeCannotForge", textShow currentSlot, textShow cannotForge]
-          tryNext
+          callFailed
         NotLeader ->
-          tryNext
+          callFailed
         ShouldForge proof -> do
           -- Tick the ledger state for the 'SlotNo' we're producing a block for
           let tickedLedgerSt :: Ticked (LedgerState CardanoBlock)
@@ -202,7 +325,7 @@ forgeNext interpreter testBlock = do
             tickedLedgerSt
             txs'
             proof
-          pure blk
+          callSuccedded blk
 
     -- We will probably not use it and wait for ledger to provide a way to construct
     -- Validated Tx in an unsafe way.
@@ -282,3 +405,7 @@ mkForecast cfg st =
 
 textShow :: Show a => a -> Text
 textShow = Text.pack . show
+
+throwLeft :: Either ForgingError a -> IO a
+throwLeft (Right a) = pure a
+throwLeft (Left err) = throwIO err

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs

@@ -71,7 +71,7 @@ consTxBody ins outs fees certs wdrl =
       ins
       outs
       (StrictSeq.fromList certs)
-      (Wdrl mempty)
+      wdrl
       fees
       (SlotNo 1000000000) -- TODO ttl
       Strict.SNothing

cardano-chain-gen/src/Cardano/Mock/Forging/Types.hs

@@ -35,6 +35,10 @@ data ForgingError =
   | ExpectedAlonzoState
   | ExpectedShelleyState
   | UnexpectedEra
+  | EmptyFingerprint SlotNo
+  | FailedToValidateSlot SlotNo Int
+  | NotExpectedSlotNo SlotNo SlotNo Int
+  | FingerprintDecodeError String
   deriving (Show, Exception)
 
 data UTxOIndex = UTxOIndex Int | UTxOAddress (Addr StandardCrypto)

cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs

@@ -10,8 +10,8 @@ import           Control.Monad.Trans.Except (runExceptT)
 import           Control.Tracer (nullTracer)
 import           Data.Text (Text)
 import qualified Data.Text as Text
-import           System.FilePath.Posix ((</>))
 import           System.Directory
+import           System.FilePath.Posix (takeFileName , (</>))
 
 import           Ouroboros.Consensus.Config
 import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus
@@ -95,13 +95,21 @@ withFullConfig :: FilePath -> FilePath
 withFullConfig staticDir mutableDir action iom migr = do
   recreateDir mutableDir
   cfg <- mkConfig staticDir mutableDir
-  interpreter <- initInterpreter (protocolInfoForging cfg) nullTracer
-  let initSt = Consensus.pInfoInitLedger $ protocolInfo cfg
-  -- TODO: get 42 from config
-  mockServer <- forkServerThread @CardanoBlock iom (topLevelConfig cfg) initSt (NetworkMagic 42) $ unSocketPath (enpSocketPath $ syncNodeParams cfg)
-  -- we dont forge dbsync here. Just prepare it as an action
-  let dbSync = async $ runDbSyncNode emptyMetricsSetters True migr (syncNodeParams cfg)
-  action interpreter mockServer dbSync
+  fingerFile <- prepareFingerprintFile staticDir mutableDir
+  withInterpreter (protocolInfoForging cfg) nullTracer fingerFile $ \interpreter -> do
+    let initSt = Consensus.pInfoInitLedger $ protocolInfo cfg
+    -- TODO: get 42 from config
+    mockServer <- forkServerThread @CardanoBlock iom (topLevelConfig cfg) initSt (NetworkMagic 42) $ unSocketPath (enpSocketPath $ syncNodeParams cfg)
+    -- we dont fork dbsync here. Just prepare it as an action
+    let dbSync = async $ runDbSyncNode emptyMetricsSetters True migr (syncNodeParams cfg)
+    action interpreter mockServer dbSync
+
+prepareFingerprintFile :: FilePath -> FilePath -> IO FilePath
+prepareFingerprintFile staticDir mutableDir = do
+  let testLabel = takeFileName mutableDir
+  let dir = staticDir </> "fingerprints"
+  createDirectoryIfMissing True dir
+  pure $ dir </> testLabel
 
 recreateDir :: FilePath -> IO ()
 recreateDir path = do