module Main (main) where

import qualified Cardano.Configuration.CliArgs as CLI
import Cardano.Ledger.BaseTypes (StrictMaybe (SJust))
import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano
import qualified Cardano.Tools.DBAnalyser.Run as DBAnalyser
import Cardano.Tools.DBAnalyser.Types
import qualified Cardano.Tools.DBImmutaliser.Run as DBImmutaliser
import qualified Cardano.Tools.DBSynthesizer.Run as DBSynthesizer
import Cardano.Tools.DBSynthesizer.Types
import qualified Cardano.Tools.DBTruncater.Run as DBTruncater
import qualified Cardano.Tools.DBTruncater.Types as DBTruncater
import Data.String (fromString)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Cardano.Block
import Ouroboros.Consensus.Leios.Types (EbHash (..), LeiosPoint (..))
import Ouroboros.Consensus.Storage.LeiosDB
  ( LeiosDbReader (testScanEbPoints)
  , LeiosDbWriter (writeEbPoint)
  , Promise (await)
  , withLeiosDBSQLite
  , withReader
  , withWriter
  )
import qualified Test.Cardano.Tools.DBAnalyser.NodeConfig
import qualified Test.Cardano.Tools.Headers
import Test.Tasty
import Test.Tasty.HUnit
import Test.Util.TestEnv

nodeConfig, chainDB, bulkCredentials :: FilePath
nodeConfig :: [Char]
nodeConfig = [Char]
"ouroboros-consensus-cardano/test/tools-test/disk/config/config.json"
chainDB :: [Char]
chainDB = [Char]
"ouroboros-consensus-cardano/test/tools-test/disk/chaindb"
bulkCredentials :: [Char]
bulkCredentials = [Char]
"ouroboros-consensus-cardano/test/tools-test/disk/config/bulk-creds-k2.json"

-- | A tenth of an epoch, then a further 8192 slots: enough for both steps to
-- forge hundreds of blocks, small enough for the analysis to stay quick. The
-- tool also accepts block and epoch limits ('ForgeLimitBlock',
-- 'ForgeLimitEpoch').
testSynthOptionsCreate :: DBSynthesizerOptions
testSynthOptionsCreate :: DBSynthesizerOptions
testSynthOptionsCreate =
  DBSynthesizerOptions
    { synthLimit :: ForgeLimit
synthLimit = SlotNo -> ForgeLimit
ForgeLimitSlot SlotNo
43200
    , synthOpenMode :: DBSynthesizerOpenMode
synthOpenMode = DBSynthesizerOpenMode
OpenCreateForce
    }

testSynthOptionsAppend :: DBSynthesizerOptions
testSynthOptionsAppend :: DBSynthesizerOptions
testSynthOptionsAppend =
  DBSynthesizerOptions
    { synthLimit :: ForgeLimit
synthLimit = SlotNo -> ForgeLimit
ForgeLimitSlot SlotNo
8192
    , synthOpenMode :: DBSynthesizerOpenMode
synthOpenMode = DBSynthesizerOpenMode
OpenAppend
    }

-- | The forgers of the fixture chain: two pools whose credentials are in a bulk
-- credentials file, and which the fixture Shelley genesis gives all the stake.
testCredentials :: CLI.Credentials
testCredentials :: Credentials
testCredentials =
  Credentials
CLI.emptyCredentials{CLI.bulkCredentialsFile = SJust bulkCredentials}

testImmutaliserConfig :: DBImmutaliser.Opts
testImmutaliserConfig :: Opts
testImmutaliserConfig =
  DBImmutaliser.Opts
    { dbDirs :: DBDirs [Char]
DBImmutaliser.dbDirs =
        DBImmutaliser.DBDirs
          { immDBDir :: [Char]
DBImmutaliser.immDBDir = [Char]
chainDB [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/immutable"
          , volDBDir :: [Char]
DBImmutaliser.volDBDir = [Char]
chainDB [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/volatile"
          }
    , configFile :: [Char]
DBImmutaliser.configFile = [Char]
nodeConfig
    , verbose :: Bool
DBImmutaliser.verbose = Bool
False
    , dotOut :: Maybe [Char]
DBImmutaliser.dotOut = Maybe [Char]
forall a. Maybe a
Nothing
    , dryRun :: Bool
DBImmutaliser.dryRun = Bool
False
    }

testAnalyserConfig :: DBAnalyserConfig
testAnalyserConfig :: DBAnalyserConfig
testAnalyserConfig =
  DBAnalyserConfig
    { dbDir :: [Char]
dbDir = [Char]
chainDB
    , ldbBackend :: Maybe LedgerDBBackendFlags
ldbBackend = LedgerDBBackendFlags -> Maybe LedgerDBBackendFlags
forall a. a -> Maybe a
Just LedgerDBBackendFlags
InMemFlag
    , verbose :: Bool
verbose = Bool
False
    , selectDB :: SelectDB
selectDB = WithOrigin SlotNo -> SelectDB
SelectImmutableDB WithOrigin SlotNo
forall t. WithOrigin t
Origin
    , validation :: Maybe ValidateBlocks
validation = ValidateBlocks -> Maybe ValidateBlocks
forall a. a -> Maybe a
Just ValidateBlocks
ValidateAllBlocks
    , analysis :: AnalysisName
analysis = AnalysisName
CountBlocks
    , confLimit :: Limit
confLimit = Limit
Unlimited
    }

-- | The truncater cuts the chain back to this slot. Far enough into the
-- synthesized chain that a block precedes it, and far enough from its end that
-- blocks follow it.
truncateAfter :: SlotNo
truncateAfter :: SlotNo
truncateAfter = SlotNo
4096

testTruncaterConfig :: DBTruncater.DBTruncaterConfig
testTruncaterConfig :: DBTruncaterConfig
testTruncaterConfig =
  DBTruncater.DBTruncaterConfig
    { dbDir :: [Char]
DBTruncater.dbDir = [Char]
chainDB
    , truncateAfter :: TruncateAfter
DBTruncater.truncateAfter = SlotNo -> TruncateAfter
DBTruncater.TruncateAfterSlot SlotNo
truncateAfter
    , verbose :: Bool
DBTruncater.verbose = Bool
False
    }

testBlockArgs :: Cardano.Args (CardanoBlock StandardCrypto)
testBlockArgs :: Args (CardanoBlock StandardCrypto)
testBlockArgs = [Char]
-> Maybe PBftSignatureThreshold
-> Args (CardanoBlock StandardCrypto)
Cardano.CardanoBlockArgs [Char]
nodeConfig Maybe PBftSignatureThreshold
forall a. Maybe a
Nothing

-- | How many blocks each synthesis step is expected to forge.
--
-- Empirical, but not arbitrary: the setup is deterministic, so a change in these
-- means the forging loop, the leader schedule or the way a configuration becomes
-- a protocol changed. Pinning them catches what a mere @> 0@ would not.
--
-- The create step covers slots 0..43199 and the append step a further 8192, so
-- the counts differ. To re-baseline, take what db-synthesizer prints as
-- @forged and adopted N blocks@.
expectedForgedCreate, expectedForgedAppend :: Int
expectedForgedCreate :: Int
expectedForgedCreate = Int
2189
expectedForgedAppend :: Int
expectedForgedAppend = Int
407

-- 1. step: synthesize a ChainDB from scratch and count the amount of blocks forged.
-- 2. step: append to the previous ChainDB and coutn the amount of blocks forged.
-- 3. step: copy the VolatileDB into the ImmutableDB.
-- 4. step: analyze the ImmutableDB resulting from previous steps and confirm the total block count.
-- 5. step: write a LeiosDb next to the chain, truncate both, and confirm the LeiosDb kept
--    only the EB announced below the cut and the chain shrank.

-- | A multi-step test covering synthesis and analysis of a Cardano chain:
--
-- 1. synthesize a ChainDB from scratch from a node configuration file and the
--    forging credentials it names, and count the blocks forged;
-- 2. append to that ChainDB and count the blocks forged;
-- 3. copy the VolatileDB into the ImmutableDB;
-- 4. analyse the resulting ImmutableDB and confirm the total block count.
--
-- Steps 1 and 2 cover the path from a configuration file to a forging protocol:
-- cardano-config parses it and "Cardano.Tools.Credentials" decodes the
-- credentials into leader credentials.
blockCountTest :: (String -> IO ()) -> Assertion
blockCountTest :: ([Char] -> IO ()) -> IO ()
blockCountTest [Char] -> IO ()
logStep = do
  [Char] -> IO ()
logStep [Char]
"building the protocol from the node configuration"
  (shelleyGenesis, protocol) <- [Char] -> Credentials -> IO (ShelleyGenesis, CardanoProtocol)
DBSynthesizer.initialize [Char]
nodeConfig Credentials
testCredentials

  logStep "running synthesis - create"
  resultCreate <-
    DBSynthesizer.synthesize genTxs testSynthOptionsCreate shelleyGenesis chainDB protocol
  assertForged "create" expectedForgedCreate resultCreate

  logStep "running synthesis - append"
  resultAppend <-
    DBSynthesizer.synthesize genTxs testSynthOptionsAppend shelleyGenesis chainDB protocol
  assertForged "append" expectedForgedAppend resultAppend

  logStep "copy volatile to immutable DB"
  DBImmutaliser.run testImmutaliserConfig

  logStep "running analysis"
  resultAnalysis <- DBAnalyser.analyse testAnalyserConfig testBlockArgs

  let blockCount = Int
expectedForgedCreate Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
expectedForgedAppend
  resultAnalysis == Just (ResultCountBlock blockCount)
    @? "wrong number of blocks encountered during analysis \
       \ (counted: "
      ++ show resultAnalysis
      ++ "; expected: "
      ++ show blockCount
      ++ ")"

  logStep "writing a LeiosDb next to the chain"
  -- DBSynthesizer writes no leios.vol.db and leios.imm.db, so the test writes
  -- them. The kept EB is announced below the truncation slot, and the dropped
  -- one above every block the synthesis forged. The handle is closed before
  -- the truncater runs: it opens the files itself and VACUUMs them.
  let volLeiosDb = [Char]
chainDB [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/leios.vol.db"
      immLeiosDb = [Char]
chainDB [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/leios.imm.db"
      keptEb = SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
0 (Char -> EbHash
mkEbHash Char
'1')
      droppedEb = SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
500000 (Char -> EbHash
mkEbHash Char
'2')
  withLeiosDBSQLite mempty volLeiosDb immLeiosDb $ \LeiosDbHandle IO
leiosDb ->
    LeiosDbHandle IO -> (LeiosDbWriter IO -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadThrow m =>
LeiosDbHandle m -> (LeiosDbWriter m -> m a) -> m a
withWriter LeiosDbHandle IO
leiosDb ((LeiosDbWriter IO -> IO ()) -> IO ())
-> (LeiosDbWriter IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LeiosDbWriter IO
con ->
      (LeiosPoint -> IO ()) -> [LeiosPoint] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\LeiosPoint
point -> Promise IO () -> IO ()
forall (m :: * -> *) a. Promise m a -> m a
await (Promise IO () -> IO ()) -> IO (Promise IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter IO
-> HasCallStack => LeiosPoint -> Word32 -> IO (Promise IO ())
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack => LeiosPoint -> Word32 -> m (Promise m ())
writeEbPoint LeiosDbWriter IO
con LeiosPoint
point Word32
500) [LeiosPoint
keptEb, LeiosPoint
droppedEb]

  logStep "running truncation"
  DBTruncater.truncate testTruncaterConfig testBlockArgs

  ebPoints <- withLeiosDBSQLite mempty volLeiosDb immLeiosDb $ \LeiosDbHandle IO
leiosDb ->
    LeiosDbHandle IO
-> (LeiosDbReader IO -> IO [(SlotNo, EbHash)])
-> IO [(SlotNo, EbHash)]
forall (m :: * -> *) a.
MonadThrow m =>
LeiosDbHandle m -> (LeiosDbReader m -> m a) -> m a
withReader LeiosDbHandle IO
leiosDb LeiosDbReader IO -> IO [(SlotNo, EbHash)]
LeiosDbReader IO -> HasCallStack => IO [(SlotNo, EbHash)]
forall (m :: * -> *).
LeiosDbReader m -> HasCallStack => m [(SlotNo, EbHash)]
testScanEbPoints
  ebPoints == [(0, pointEbHash keptEb)]
    @? "the LeiosDb does not hold the kept EB alone: " ++ show ebPoints

  logStep "running analysis after truncation"
  resultTruncated <- DBAnalyser.analyse testAnalyserConfig testBlockArgs
  -- The leader schedule picks the slots, so the surviving count is not known
  -- here. Check only that the chain shrank and is not empty.
  case resultTruncated of
    Just (ResultCountBlock Int
countAfter) ->
      (Int
countAfter Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
countAfter Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
blockCount)
        Bool -> [Char] -> IO ()
forall t.
(AssertionPredicable t, HasCallStack) =>
t -> [Char] -> IO ()
@? [Char]
"truncation left "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
countAfter
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
blockCount
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" blocks"
    Maybe AnalysisResult
_ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"analysis after truncation returned " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe AnalysisResult -> [Char]
forall a. Show a => a -> [Char]
show Maybe AnalysisResult
resultTruncated
 where
  genTxs :: p -> p -> p -> p -> f [a]
genTxs p
_ p
_ p
_ p
_ = [a] -> f [a]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  assertForged :: [Char] -> Int -> ForgeResult -> IO ()
assertForged [Char]
step Int
expected ForgeResult
result =
    [Char] -> Int -> Int -> IO ()
forall a. (Eq a, Show a, HasCallStack) => [Char] -> a -> a -> IO ()
assertEqual
      ([Char]
"wrong number of blocks forged during the " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
step [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" step")
      Int
expected
      (ForgeResult -> Int
resultForged ForgeResult
result)

  mkEbHash :: Char -> EbHash
mkEbHash Char
c = ByteString -> EbHash
MkEbHash ([Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
32 Char
c))

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"cardano-tools"
    [ [Char] -> (([Char] -> IO ()) -> IO ()) -> TestTree
testCaseSteps [Char]
"synthesize and analyse: blockCount\n" ([Char] -> IO ()) -> IO ()
blockCountTest
    , TestTree
Test.Cardano.Tools.DBAnalyser.NodeConfig.tests
    , [Char] -> (([Char] -> IO ()) -> IO ()) -> TestTree
testCaseSteps [Char]
"synthesize, analyse and truncate\n" ([Char] -> IO ()) -> IO ()
blockCountTest
    , TestTree
Test.Cardano.Tools.Headers.tests
    ]

main :: IO ()
IO ()
main = TestEnvConfig -> TestTree -> IO ()
defaultMainWithTestEnv TestEnvConfig
defaultTestEnvConfig TestTree
tests