content: {-# LANGUAGE OverloadedLists #-}
  {-# LANGUAGE RankNTypes      #-}
  
  -- | Specification of 'Pos.Chain.Block.VAR'.
  
  module Test.Pos.Block.Logic.VarSpec
         ( spec
         ) where
  
  import           Universum hiding ((<>))
  
  import           Control.Monad.Random.Strict (MonadRandom (..), RandomGen,
                       evalRandT, uniform)
  import qualified Data.List as List
  import           Data.List.NonEmpty (NonEmpty ((:|)))
  import qualified Data.List.NonEmpty as NE
  import qualified Data.Ratio as Ratio
  import           Data.Semigroup ((<>))
  import           Formatting (sformat, (%))
  import           Serokell.Util (listJson)
  
  import           Test.Hspec (Spec, beforeAll_, describe)
  import           Test.Hspec.QuickCheck (modifyMaxSuccess)
  import           Test.QuickCheck.Gen (Gen (MkGen))
  import           Test.QuickCheck.Monadic (assert, pick, pre)
  import           Test.QuickCheck.Random (QCGen)
  
  import           Pos.Chain.Block (Blund, HeaderHash, headerHash)
  import           Pos.Chain.Genesis as Genesis (Config (..),
                       configBootStakeholders, configEpochSlots)
  import           Pos.Chain.Txp (TxpConfiguration)
  import           Pos.Core (ProtocolConstants (..), pcBlkSecurityParam)
  import           Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..),
                       nonEmptyNewestFirst, nonEmptyOldestFirst,
                       splitAtNewestFirst, toNewestFirst, _NewestFirst)
  import           Pos.Core.Slotting (MonadSlots (getCurrentSlot))
  import           Pos.DB.Block (verifyAndApplyBlocks, verifyBlocksPrefix)
  import           Pos.DB.Pure (dbPureDump)
  
  import           Pos.Generator.BlockEvent (BlockEvent' (..),
                       BlockEventApply' (..), BlockEventRollback' (..),
                       BlockScenario' (..))
  import           Pos.Generator.BlockEvent.DSL (BlockApplyResult (..),
                       BlockEventGenT, BlockRollbackFailure (..),
                       BlockRollbackResult (..), BlockScenario, Path, byChance,
                       emitBlockApply, emitBlockRollback,
                       enrichWithSnapshotChecking, pathSequence,
                       runBlockEventGenT)
  import qualified Pos.GState as GS
  import           Pos.Launcher (HasConfigurations)
  import           Pos.Util.Wlog (setupTestLogging)
  
  import           Test.Pos.Block.Logic.Event (BlockScenarioResult (..),
                       DbNotEquivalentToSnapshot (..), runBlockScenario)
  import           Test.Pos.Block.Logic.Mode (BlockProperty, BlockTestMode)
  import           Test.Pos.Block.Logic.Util (EnableTxPayload (..),
                       InplaceDB (..), bpGenBlock, bpGenBlocks,
                       bpGoToArbitraryState, getAllSecrets, satisfySlotCheck)
  import           Test.Pos.Block.Property (blockPropertySpec)
  import           Test.Pos.Configuration (HasStaticConfigurations,
                       withStaticConfigurations)
  import           Test.Pos.Util.QuickCheck.Property (splitIntoChunks,
                       stopProperty)
  
  -- stack test cardano-sl --fast --test-arguments "-m Test.Pos.Chain.Block.Var"
  spec :: Spec
  -- Unfortunatelly, blocks generation is quite slow nowdays.
  -- See CSL-1382.
  spec = beforeAll_ setupTestLogging $ withStaticConfigurations $ \txpConfig _ ->
      describe "Block.Logic.VAR" $ modifyMaxSuccess (min 4) $ do
          describe "verifyBlocksPrefix" $ verifyBlocksPrefixSpec txpConfig
          describe "verifyAndApplyBlocks" $ verifyAndApplyBlocksSpec txpConfig
          describe "applyBlocks" applyBlocksSpec
          describe "Block.Event" $ do
              describe "Successful sequence" $ blockEventSuccessSpec txpConfig
              describe "Apply through epoch" $ applyThroughEpochSpec txpConfig 0
              describe "Apply through epoch" $ applyThroughEpochSpec txpConfig 4
              describe "Fork - short" $ singleForkSpec txpConfig ForkShort
              describe "Fork - medium" $ singleForkSpec txpConfig ForkMedium
              describe "Fork - deep" $ singleForkSpec txpConfig ForkDeep
  
  ----------------------------------------------------------------------------
  -- verifyBlocksPrefix
  ----------------------------------------------------------------------------
  
  verifyBlocksPrefixSpec
      :: HasStaticConfigurations
      => TxpConfiguration
      -> Spec
  verifyBlocksPrefixSpec txpConfig = do
      blockPropertySpec verifyEmptyMainBlockDesc
                        (flip verifyEmptyMainBlock txpConfig)
      blockPropertySpec verifyValidBlocksDesc
                        (flip verifyValidBlocks txpConfig)
    where
      verifyEmptyMainBlockDesc =
          "verification of consistent empty main block " <>
          "created by the leader of the 0-th slot " <>
          "always succeeds for initial GState"
      verifyValidBlocksDesc =
          "verification of (hopefully) valid blocks " <>
          "generated by the block generator " <>
          "always succeeds for GState for which these blocks where generated " <>
          "as long as all these blocks are from the same epoch"
  
  verifyEmptyMainBlock :: HasConfigurations
                       => Genesis.Config
                       -> TxpConfiguration
                       -> BlockProperty ()
  verifyEmptyMainBlock genesisConfig txpConfig = do
      emptyBlock <- fst <$> bpGenBlock genesisConfig
                                       txpConfig
                                       (EnableTxPayload False)
                                       (InplaceDB False)
      curSlot <- getCurrentSlot $ configEpochSlots genesisConfig
      whenLeftM (lift $ verifyBlocksPrefix genesisConfig curSlot (one emptyBlock))
          $ stopProperty
          . pretty
  
  verifyValidBlocks
      :: HasConfigurations
      => Genesis.Config
      -> TxpConfiguration
      -> BlockProperty ()
  verifyValidBlocks genesisConfig txpConfig = do
      bpGoToArbitraryState
      blocks <- map fst . toList <$> bpGenBlocks genesisConfig
                                                txpConfig
                                                Nothing
                                                (EnableTxPayload True)
                                                (InplaceDB False)
      pre (not $ null blocks)
      let blocksToVerify = OldestFirst $ case blocks of
              -- impossible because of precondition (see 'pre' above)
              [] -> error "verifyValidBlocks: impossible"
              (block0:otherBlocks) ->
                  let (otherBlocks', _) = List.span isRight otherBlocks
                  in block0 :| otherBlocks'
  
      verRes <- lift $ satisfySlotCheck blocksToVerify $ verifyBlocksPrefix
          genesisConfig
          Nothing
          blocksToVerify
      whenLeft verRes $ stopProperty . pretty
  
  ----------------------------------------------------------------------------
  -- verifyAndApplyBlocks
  ----------------------------------------------------------------------------
  
  verifyAndApplyBlocksSpec :: HasStaticConfigurations
                           => TxpConfiguration
                           -> Spec
  verifyAndApplyBlocksSpec txpConfig =
      blockPropertySpec applyByOneOrAllAtOnceDesc $ \genesisConfig ->
          applyByOneOrAllAtOnce genesisConfig txpConfig (applier genesisConfig)
    where
      applier
          :: Genesis.Config
          -> OldestFirst NE Blund
          -> BlockTestMode ()
      applier genesisConfig blunds = do
          let blocks = map fst blunds
          -- we don't check current SlotId, because the applier is run twice
          -- and the check will fail the verification
          satisfySlotCheck blocks $ whenLeftM
              (verifyAndApplyBlocks genesisConfig txpConfig Nothing True blocks)
              throwM
      applyByOneOrAllAtOnceDesc =
          "verifying and applying blocks one by one leads " <>
          "to the same GState as verifying and applying them all at once " <>
          "as well as applying in chunks"
  
  ----------------------------------------------------------------------------
  -- applyBlocks
  ----------------------------------------------------------------------------
  
  -- Commented out because tests are slow.
  -- We can enable it later if we make tests much faster.
  
  applyBlocksSpec :: Spec
  applyBlocksSpec = pass
  -- applyBlocksSpec = do
  --     prop applyByOneOrAllAtOnceDesc (applyByOneOrAllAtOnce applier)
  --   where
  --     applier = applyBlocks True Nothing
  --     applyByOneOrAllAtOnceDesc =
  --         "applying blocks one by one leads to the same GState as " <>
  --         "applying them all at once"
  
  ----------------------------------------------------------------------------
  -- General functions
  ----------------------------------------------------------------------------
  
  applyByOneOrAllAtOnce
      :: HasConfigurations
      => Genesis.Config
      -> TxpConfiguration
      -> (OldestFirst NE Blund -> BlockTestMode ())
      -> BlockProperty ()
  applyByOneOrAllAtOnce genesisConfig txpConfig applier = do
      bpGoToArbitraryState
      blunds <- getOldestFirst <$> bpGenBlocks genesisConfig
                                               txpConfig
                                               Nothing
                                               (EnableTxPayload True)
                                               (InplaceDB False)
      pre (not $ null blunds)
      let blundsNE = OldestFirst (NE.fromList blunds)
      stateAfter1by1 <- lift $ GS.withClonedGState $ do
          mapM_ (applier . one) (getOldestFirst blundsNE)
          dbPureDump
      chunks             <- splitIntoChunks 5 (blunds)
      stateAfterInChunks <- lift $ GS.withClonedGState $ do
          mapM_ (applier . OldestFirst) chunks
          dbPureDump
      stateAfterAllAtOnce <- lift $ do
          applier blundsNE
          dbPureDump
      assert
          (  stateAfter1by1
          == stateAfterInChunks
          && stateAfterInChunks
          == stateAfterAllAtOnce
          )
  
  ----------------------------------------------------------------------------
  -- Block events
  ----------------------------------------------------------------------------
  
  blockEventSuccessSpec :: HasStaticConfigurations
                        => TxpConfiguration
                        -> Spec
  blockEventSuccessSpec txpConfig =
      blockPropertySpec blockEventSuccessDesc
                        (flip blockEventSuccessProp txpConfig)
    where
      blockEventSuccessDesc =
          "a sequence of interleaved block applications and rollbacks " <>
          "results in the original state of the blockchain"
  
  {- | This generator is carefully designed to cover multitude of success
     scenarios. Apply/rollback are interleaved in various ways, shown by diagrams below:
  
     0 -----a----> 2
     |             |        Synchronous apply/rollback
     0 <----r----- 2
  
     0 -a-> 1 -a-> 2
     |             |        Multiple apply per rollback
     0 <----r----- 2
  
     0 -----a----> 2
     |             |        Multiple rollback per apply
     0 <-r- 1 <-r- 2
  
     0 -a-> 3 -a-> 6 -a-> 9
     |                    |        Desynchronous apply/rollback
     0 <--r--- 4 <---r--- 9
  
     Furthermore, it allows nested forks (forks of forks), generates both unique
     and repeated forks, respects the 'blkSecurityParam', and can be used with
     'enrichWithSnapshotChecking'. (I would draw diagrams for these features as
     well, but they're barely readable in the ASCII format). Just trust me that
     this generator gives diverse block event sequences -- I spent an entire night
     and a few sheets of paper trying to figure out how to write it.
  -}
  
  genSuccessWithForks :: forall g m . (RandomGen g, Monad m)
                      => Genesis.Config
                      -> BlockEventGenT g m ()
  genSuccessWithForks genesisConfig = do
      emitBlockApply BlockApplySuccess $ pathSequence mempty ["0"]
      generateFork "0" []
      emitBlockApply BlockApplySuccess $ pathSequence "0" ["1", "2"]
      generateFork ("0" <> "1" <> "2") []
    where
      generateFork ::
             Path -- base path (from the main chain)
          -> NewestFirst [] Path -- current fork state
          -> BlockEventGenT g m ()
      generateFork basePath rollbackFork = do
          let
              forkLen    = length rollbackFork
              k          = (pcBlkSecurityParam . configProtocolConstants) genesisConfig
              wiggleRoom = fromIntegral k - forkLen
          stopFork <- byChance (if forkLen > 0 then 0.1 else 0)
          if stopFork
              then whenJust (nonEmptyNewestFirst rollbackFork) $
                   emitBlockRollback BlockRollbackSuccess
              else do
                  needRollback <-
                      -- forkLen=0                => needRollback 0%
                      -- forkLen=blkSecurityParam => needRollback 100%
                      byChance (realToFrac $ forkLen Ratio.% fromIntegral k)
                  if needRollback
                      then do
                          retreat <- getRandomR (1, forkLen)
                          whenJust (nonEmptyNewestFirst rollbackFork) $ \rollbackFork' -> do
                              -- forkLen > 0, therefore retreat > 0
                              let (over _NewestFirst NE.fromList -> before, after) = splitAtNewestFirst retreat rollbackFork'
                              emitBlockRollback BlockRollbackSuccess before
                              generateFork basePath after
                      else do
                          advance <- getRandomR (1, wiggleRoom)
                          relPaths <- OldestFirst <$> replicateM advance generateRelativePath1
                          whenJust (nonEmptyOldestFirst relPaths) $ \relPaths' -> do
                              let
                                  curPath = maybe basePath NE.head $ nonEmpty (getNewestFirst rollbackFork)
                                  paths = pathSequence curPath relPaths'
                              emitBlockApply BlockApplySuccess paths
                              generateFork basePath (over _NewestFirst toList (toNewestFirst paths) <> rollbackFork)
      generateRelativePath1 :: BlockEventGenT g m Path
      generateRelativePath1 =
          uniform (["rekt", "kek", "mems", "peka"] :: NE Path)
  
  blockPropertyScenarioGen
      :: HasConfigurations
      => Genesis.Config
      -> TxpConfiguration
      -> BlockEventGenT QCGen BlockTestMode ()
      -> BlockProperty BlockScenario
  blockPropertyScenarioGen genesisConfig txpConfig m =
      generate =<< getAllSecrets
    where
      generate secrets = do
          let genStakeholders = configBootStakeholders genesisConfig
          g <- pick $ MkGen $ \qc _ -> qc
          bs <- lift $ flip evalRandT g $ runBlockEventGenT genesisConfig
                                                  txpConfig
                                                  secrets
                                                  genStakeholders
                                                  m
          if not (uniqueBlockApply bs)
              then generate secrets
              else pure bs
  
  
  -- | Return 'True' if the applied blocks (taking into account rollbacks) results
  -- in a unique set of block hashes. The generator tests will fail if the
  -- generated blocks (accounting for rollback) are not unique.
  uniqueBlockApply :: BlockScenario -> Bool
  uniqueBlockApply (BlockScenario bs) =
      let ys = foldScenario [] bs in
      ys == ordNub ys
    where
      foldScenario :: [HeaderHash] -> [BlockEvent' Blund] -> [HeaderHash]
      foldScenario !acc [] = List.sort acc
      foldScenario !acc (x:xs) =
          case x of
              BlkEvApply ea ->
                  foldScenario ((map headerHash . toList $ toNewestFirst (_beaInput ea)) ++ acc) xs
              BlkEvRollback re ->
                  foldScenario (rollback (map headerHash . toList $ getNewestFirst (_berInput re)) acc) xs
              BlkEvSnap _ ->
                  foldScenario acc xs
  
      rollback :: [HeaderHash] -> [HeaderHash] -> [HeaderHash]
      rollback _ [] = []
      rollback [] acc = acc
      rollback (r:rs) (x:xs) =
          if (r == x)
              then rollback rs xs
              else error $ sformat
                      ("uniqueBlockApply: rollback failed " % listJson % " " % listJson)
                          (r:rs) (x:xs)
  
  prettyScenario :: BlockScenario -> Text
  prettyScenario scenario = pretty (fmap (headerHash . fst) scenario)
  
  blockEventSuccessProp
      :: HasConfigurations => Genesis.Config -> TxpConfiguration -> BlockProperty ()
  blockEventSuccessProp genesisConfig txpConfig = do
      scenario <- blockPropertyScenarioGen genesisConfig
                                           txpConfig
                                           (genSuccessWithForks genesisConfig)
      let (scenario', checkCount) = enrichWithSnapshotChecking scenario
      when (checkCount <= 0) $ stopProperty $
          "No checks were generated, this is a bug in the test suite: " <>
          prettyScenario scenario'
      runBlockScenarioAndVerify genesisConfig txpConfig scenario'
  
  runBlockScenarioAndVerify
      :: HasConfigurations
      => Genesis.Config
      -> TxpConfiguration
      -> BlockScenario
      -> BlockProperty ()
  runBlockScenarioAndVerify genesisConfig txpConfig bs = verifyBlockScenarioResult
      =<< lift (runBlockScenario genesisConfig txpConfig bs)
  
  verifyBlockScenarioResult :: BlockScenarioResult -> BlockProperty ()
  verifyBlockScenarioResult = \case
      BlockScenarioFinishedOk -> return ()
      BlockScenarioUnexpectedSuccess -> stopProperty $
          "Block scenario unexpected success"
      BlockScenarioUnexpectedFailure e -> stopProperty $
          "Block scenario unexpected failure: " <>
          pretty e
      BlockScenarioDbChanged d ->
          let DbNotEquivalentToSnapshot snapId dbDiff = d in
          stopProperty $
              "Block scenario resulted in a change to the blockchain" <>
              " relative to the " <> show snapId <> " snapshot:\n" <>
              show dbDiff
  
  ----------------------------------------------------------------------------
  -- Multi-epoch
  ----------------------------------------------------------------------------
  
  -- Input: the amount of blocks after crossing.
  applyThroughEpochSpec
      :: HasStaticConfigurations
      => TxpConfiguration
      -> Int
      -> Spec
  applyThroughEpochSpec txpConfig afterCross =
      blockPropertySpec applyThroughEpochDesc $ \genesisConfig ->
          applyThroughEpochProp genesisConfig txpConfig afterCross
    where
      applyThroughEpochDesc =
        "apply a sequence of blocks that spans through epochs (additional blocks after crossing: " ++
        show afterCross ++ ")"
  
  applyThroughEpochProp :: HasConfigurations
                        => Genesis.Config
                        -> TxpConfiguration
                        -> Int
                        -> BlockProperty ()
  applyThroughEpochProp genesisConfig txpConfig afterCross = do
      scenario <- blockPropertyScenarioGen genesisConfig txpConfig $ do
          let
              approachEpochEdge =
                  pathSequence mempty . OldestFirst . NE.fromList $
                  replicate (fromIntegral (configEpochSlots genesisConfig) - 1) "a"
              crossEpochEdge =
                  pathSequence (NE.last $ getOldestFirst approachEpochEdge) $
                  OldestFirst . NE.fromList $
                  -- 2 blocks to ensure that we cross,
                  -- then some additional blocks
                  replicate (afterCross + 2) "x"
          emitBlockApply BlockApplySuccess approachEpochEdge
          emitBlockApply BlockApplySuccess crossEpochEdge
      runBlockScenarioAndVerify genesisConfig txpConfig scenario
  
  ----------------------------------------------------------------------------
  -- Forks
  ----------------------------------------------------------------------------
  
  singleForkSpec :: HasStaticConfigurations
                 => TxpConfiguration
                 -> ForkDepth
                 -> Spec
  singleForkSpec txpConfig fd = blockPropertySpec singleForkDesc
      $ \genesisConfig -> singleForkProp genesisConfig txpConfig fd
    where
      singleForkDesc =
        "a blockchain of length q<=(9.5*k) blocks can switch to a fork " <>
        "of length j>i with a common prefix i, rollback depth d=q-i"
  
  singleForkProp :: HasConfigurations
                 => Genesis.Config
                 -> TxpConfiguration
                 -> ForkDepth
                 -> BlockProperty ()
  singleForkProp genesisConfig txpConfig fd = do
      scenario <- blockPropertyScenarioGen genesisConfig txpConfig $ genSingleFork genesisConfig fd
      runBlockScenarioAndVerify genesisConfig txpConfig scenario
  
  data ForkDepth = ForkShort | ForkMedium | ForkDeep
  
  genSingleFork :: forall g m . (RandomGen g, Monad m)
                => Genesis.Config -> ForkDepth -> BlockEventGenT g m ()
  genSingleFork genesisConfig fd = do
      let k = pcK (configProtocolConstants genesisConfig)
      -- 'd' is how deeply in the chain the fork starts. In other words, it's how many
      -- blocks we're going to rollback (therefore must be >1).
      d <- getRandomR $ case fd of
          ForkShort  -> (1, if k > 1 then k-1 else 1)
          ForkMedium -> (if k > 2 then k - 2 else 1, k+2)
          ForkDeep   -> (k+1, div (k*3) 2 + 1)
      -- the depth must be <=k for a successful rollback.
      let expectSuccess = d <= k
      -- original blockchain max index q<(9.5*k)
      q <- getRandomR (d+1, 9 * k + div k 2)
      let
          -- max index of the common prefix. i>0 because d<q
          i = q-d
      -- fork blockchain max index j>i. the upper bound is arbitrary.
      -- dj=j-i
      dj <- getRandomR (1, d*2)
      -- now we can generate paths:
      --
      -- B0 - B1 - B2 - B3 - B4 - B5 - B6 - B7
      --              \
      --                C3 - C4 - C5 - C6
      --
      -- in this example, q=7, d=5, i=2, dj=4
      let
          nonEmptyCuz r [] = error ("Requirement failed: " <> r)
          nonEmptyCuz _ xs = NE.fromList xs
          commonPrefix = pathSequence mempty $
              OldestFirst . nonEmptyCuz "i > 0" $ replicate i "B"
          originalChain = pathSequence mempty $
              OldestFirst . nonEmptyCuz "q > 0" $ replicate q "B"
          rollbackChain = toNewestFirst . pathSequence (stimes i "B") $
              OldestFirst . nonEmptyCuz "d > 0" $ replicate d "B"
          forkChain = pathSequence (NE.last $ getOldestFirst commonPrefix) $
              OldestFirst . nonEmptyCuz "dj > 0" $ replicate dj "C"
      emitBlockApply BlockApplySuccess originalChain
      if expectSuccess
          then do
              emitBlockRollback BlockRollbackSuccess rollbackChain
              emitBlockApply BlockApplySuccess forkChain
          else do
              emitBlockRollback (BlockRollbackFailure BlkRbSecurityLimitExceeded) rollbackChain
  