{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Tests for the way db-analyser interprets a node configuration file.
--
-- The parsing itself is @cardano-config@'s job, but db-analyser derives a few
-- things from the result (the initial nonce, the hard-fork triggers, the
-- LedgerDB backend), and those derivations are what these tests pin down. They
-- run against the node configuration in @disk/config@, so they also catch the
-- silent failure mode of @cardano-config@ ignoring a key db-analyser depends on.
module Test.Cardano.Tools.DBAnalyser.NodeConfig (tests) where

import qualified Cardano.Configuration as Cfg
import qualified Cardano.Crypto.Hash.Class as CryptoClass
import qualified Cardano.Ledger.Api.Era as L
import Cardano.Ledger.BaseTypes (Nonce (..), ProtVer (..))
import Cardano.Ledger.Dijkstra.Genesis (DijkstraGenesis (..))
import Cardano.Ledger.Dijkstra.PParams (UpgradeDijkstraPParams (..))
import Cardano.Tools.Config
  ( ConfigError (..)
  , mkDijkstraGenesis
  , mkHardForkTriggers
  , mkInitialNonce
  , mkProtocolVersion
  , resolveNodeConfiguration
  )
import Cardano.Tools.DBAnalyser.Block.Cardano
  ( Args (CardanoBlockArgs)
  , mkLedgerDBBackend
  )
import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfoAndBackend)
import Cardano.Tools.DBAnalyser.Types
  ( LSMFlags (..)
  , LSMOptions (..)
  , LedgerDBBackend (..)
  , LedgerDBBackendFlags (..)
  , selectLedgerDBBackend
  )
import Control.Exception (try)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.List (isInfixOf)
import Data.Maybe (fromMaybe)
import Data.SOP.BasicFunctors (K (..))
import Data.SOP.Strict (hcollapse, hmap)
import Data.Word (Word32)
import Ouroboros.Consensus.Block (EpochNo (..))
import Ouroboros.Consensus.Cardano.Node
  ( CardanoHardForkTrigger (..)
  , CardanoHardForkTriggers (..)
  )
import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..))
import System.Directory (copyFile, listDirectory)
import System.FilePath (takeFileName, (</>))
import System.IO.Temp (withSystemTempDirectory)
import Test.Tasty
import Test.Tasty.HUnit

-- | The directory holding the node configuration these tests run against: a
-- Cardano configuration in the current @{ $schema, Version, Configuration }@
-- format, which sets @Test\<era\>HardForkAtEpoch@ for Shelley through Conway and
-- has no @LedgerDB@ section.
configDir :: FilePath
configDir :: [Char]
configDir = [Char]
"ouroboros-consensus-cardano/test/tools-test/disk/config"

configFile :: FilePath
configFile :: [Char]
configFile = [Char]
configDir [Char] -> [Char] -> [Char]
</> [Char]
"config.json"

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"NodeConfig"
    [ [Char] -> Assertion -> TestTree
testCase [Char]
"resolves with the expected warnings" Assertion
test_resolvesWithExpectedWarnings
    , [Char] -> Assertion -> TestTree
testCase [Char]
"hard-fork triggers" Assertion
test_hardForkTriggers
    , [Char] -> Assertion -> TestTree
testCase [Char]
"hard-fork triggers reject a gap" Assertion
test_hardForkTriggersGap
    , [Char] -> Assertion -> TestTree
testCase [Char]
"initial nonce hashes the Shelley genesis" Assertion
test_initialNonce
    , [Char] -> Assertion -> TestTree
testCase [Char]
"protocol version stops before the experimental era" Assertion
test_protocolVersion
    , [Char] -> Assertion -> TestTree
testCase [Char]
"protocol version covers the experimental era" Assertion
test_protocolVersionExperimental
    , [Char] -> Assertion -> TestTree
testCase [Char]
"Dijkstra genesis ignores the file when experimental is off" Assertion
test_dijkstraGenesisDefault
    , [Char] -> Assertion -> TestTree
testCase [Char]
"Dijkstra genesis comes from the file when experimental is on" Assertion
test_dijkstraGenesisFromFile
    , [Char] -> Assertion -> TestTree
testCase [Char]
"LedgerDB backend defaults to in-memory" Assertion
test_ledgerDBBackendDefault
    , [Char] -> Assertion -> TestTree
testCase [Char]
"LedgerDB LSM backend" Assertion
test_ledgerDBBackendLSM
    , [Char] -> Assertion -> TestTree
testCase [Char]
"LedgerDB LSM rejects an absolute path" Assertion
test_ledgerDBBackendLSMAbsolute
    , [Char] -> Assertion -> TestTree
testCase [Char]
"--lsm keeps the configured LSM settings" Assertion
test_lsmFlagKeepsConfig
    , [Char] -> Assertion -> TestTree
testCase [Char]
"--lsm-export prefers the configured export path" Assertion
test_lsmExportFlagConfigured
    , [Char] -> Assertion -> TestTree
testCase [Char]
"--lsm over a non-LSM configuration uses the defaults" Assertion
test_lsmFlagDefaults
    , [Char] -> Assertion -> TestTree
testCase [Char]
"a malformed configuration is a ConfigError" Assertion
test_malformedIsConfigError
    , [Char] -> Assertion -> TestTree
testCase [Char]
"builds a ProtocolInfo" Assertion
test_mkProtocolInfoAndBackend
    ]

{-------------------------------------------------------------------------------
  Configuration variants

  Rather than checking in a near-identical copy of the configuration for every
  case, the variants are derived from it at run time: the whole configuration
  directory is copied into a temporary directory, so that the genesis paths keep
  resolving, and the configuration file itself is patched there.
-------------------------------------------------------------------------------}

-- | The sections of the @Configuration@ envelope that these tests patch.
protocolSection, storageSection, testingSection :: [Aeson.Key]
protocolSection :: [Key]
protocolSection = [Key
"Configuration", Key
"Protocol"]
storageSection :: [Key]
storageSection = [Key
"Configuration", Key
"Storage"]
testingSection :: [Key]
testingSection = [Key
"Configuration", Key
"Testing"]

-- | Run an action on a copy of 'configFile' in which the section at the given
-- path has been extended with (or, for a 'Nothing' value, stripped of) the given
-- keys. Missing sections are created.
--
-- The path must lead into the @Configuration@ envelope. A key added at the top
-- level instead would not merely be ignored: it makes @cardano-config@ take the
-- whole file to be in the legacy format and migrate it on the fly, so the test
-- would silently exercise the legacy path rather than the current format.
withPatchedConfig ::
  [Aeson.Key] -> [(Aeson.Key, Maybe Aeson.Value)] -> (FilePath -> IO a) -> IO a
withPatchedConfig :: forall a. [Key] -> [(Key, Maybe Value)] -> ([Char] -> IO a) -> IO a
withPatchedConfig [Key]
section [(Key, Maybe Value)]
patches [Char] -> IO a
k = do
  case [Key]
section of
    Key
"Configuration" : Key
_ : [Key]
_ -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Key]
_ ->
      [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$
        [Char]
"patches must target a section under Configuration, not " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Key] -> [Char]
forall a. Show a => a -> [Char]
show [Key]
section
  [Char] -> ([Char] -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> m a) -> m a
withSystemTempDirectory [Char]
"db-analyser-config" (([Char] -> IO a) -> IO a) -> ([Char] -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \[Char]
tmpDir -> do
    entries <- [Char] -> IO [[Char]]
listDirectory [Char]
configDir
    mapM_ (\[Char]
e -> [Char] -> [Char] -> Assertion
copyFile ([Char]
configDir [Char] -> [Char] -> [Char]
</> [Char]
e) ([Char]
tmpDir [Char] -> [Char] -> [Char]
</> [Char]
e)) entries
    let patchedFile = [Char]
tmpDir [Char] -> [Char] -> [Char]
</> [Char] -> [Char]
takeFileName [Char]
configFile
    original <-
      Aeson.eitherDecodeFileStrict' patchedFile >>= \case
        Left [Char]
err -> [Char] -> IO Value
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> IO Value) -> [Char] -> IO Value
forall a b. (a -> b) -> a -> b
$ [Char]
"could not re-read the configuration: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err
        Right Value
value -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value
    patched <- patchAt section original
    BL.writeFile patchedFile (Aeson.encode patched)
    k patchedFile
 where
  patchAt :: [Key] -> Value -> IO Value
patchAt [] (Aeson.Object KeyMap Value
o) = Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> Value -> IO Value
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> Value
Aeson.Object (KeyMap Value -> Value) -> KeyMap Value -> Value
forall a b. (a -> b) -> a -> b
$ ((Key, Maybe Value) -> KeyMap Value -> KeyMap Value)
-> KeyMap Value -> [(Key, Maybe Value)] -> KeyMap Value
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Key, Maybe Value) -> KeyMap Value -> KeyMap Value
forall {v}. (Key, Maybe v) -> KeyMap v -> KeyMap v
applyPatch KeyMap Value
o [(Key, Maybe Value)]
patches
  patchAt (Key
key : [Key]
keys) (Aeson.Object KeyMap Value
o) = do
    inner <- [Key] -> Value -> IO Value
patchAt [Key]
keys (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (KeyMap Value -> Value
Aeson.Object KeyMap Value
forall a. Monoid a => a
mempty) (Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
key KeyMap Value
o))
    pure $ Aeson.Object $ KeyMap.insert key inner o
  patchAt [Key]
_ Value
_ =
    [Char] -> IO Value
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> IO Value) -> [Char] -> IO Value
forall a b. (a -> b) -> a -> b
$ [Char]
"not an object at " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Key] -> [Char]
forall a. Show a => a -> [Char]
show [Key]
section [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" in the configuration"

  applyPatch :: (Key, Maybe v) -> KeyMap v -> KeyMap v
applyPatch (Key
key, Maybe v
mbValue) =
    (KeyMap v -> KeyMap v)
-> (v -> KeyMap v -> KeyMap v) -> Maybe v -> KeyMap v -> KeyMap v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Key -> KeyMap v -> KeyMap v
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
key) (Key -> v -> KeyMap v -> KeyMap v
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
key) Maybe v
mbValue

-- | Resolve a configuration that is expected to be in the current format,
-- failing if @cardano-config@ had to migrate it from the legacy format. Every
-- test that resolves successfully goes through this, so none of them can drift
-- onto the legacy path unnoticed.
resolveNewFormat :: FilePath -> IO Cfg.NodeConfiguration
resolveNewFormat :: [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
file = do
  (nc, warns) <- [Char] -> IO (NodeConfiguration, [ConfigWarning])
resolveNodeConfiguration [Char]
file
  Cfg.MigratedToCurrentFormat `notElem` warns
    @? "the configuration is not in the current format: " <> show warns
  pure nc

-- | Select the LSM backend, with the given @LedgerDB.Backend.LSM@ options.
lsmBackend :: [(Aeson.Key, Aeson.Value)] -> (Aeson.Key, Maybe Aeson.Value)
lsmBackend :: [(Key, Value)] -> (Key, Maybe Value)
lsmBackend [(Key, Value)]
options =
  ( Key
"LedgerDB"
  , Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$
      [(Key, Value)] -> Value
Aeson.object
        [ Key
"Backend"
            Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [(Key, Value)] -> Value
Aeson.object [Key
"LSM" Key -> Value -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= KeyMap Value -> Value
Aeson.Object ([(Key, Value)] -> KeyMap Value
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList [(Key, Value)]
options)]
        ]
  )

{-------------------------------------------------------------------------------
  Tests
-------------------------------------------------------------------------------}

-- | The whole warning list is pinned, not spot-checked.
--
-- @UnrecognisedKeys@ is the failure mode that matters: a key @cardano-config@
-- does not know is one it silently defaults instead of honouring, which for
-- @Test\<era\>HardForkAtEpoch@ would mean replaying a different era than the
-- file asks for. The configuration carries nothing db-analyser does not read,
-- and is already in the current format, so neither that nor a migration warning
-- should appear.
--
-- The configuration names a @DijkstraGenesisFile@ without enabling the
-- experimental era, which is what lets the two Dijkstra cases below tell the
-- fallback from the file. @cardano-config@ does not open the file then, and
-- does not warn about it either.
test_resolvesWithExpectedWarnings :: Assertion
test_resolvesWithExpectedWarnings :: Assertion
test_resolvesWithExpectedWarnings = do
  (_nc, warns) <- [Char] -> IO (NodeConfiguration, [ConfigWarning])
resolveNodeConfiguration [Char]
configFile
  warns @?= []

-- | The epochs the configuration sets must survive into the triggers. A silent
-- fallback to 'CardanoTriggerHardForkAtDefaultVersion' would make db-analyser
-- replay a different era than the configuration asks for, so pin the whole list
-- down rather than just spot-checking one era.
test_hardForkTriggers :: Assertion
test_hardForkTriggers :: Assertion
test_hardForkTriggers = do
  nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
configFile
  case mkHardForkTriggers (Cfg.testingConfiguration nc) of
    Left [Char]
err -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"expected triggers, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err
    Right CardanoHardForkTriggers
triggers ->
      -- Shelley through Conway at epoch 0; Dijkstra is not configured, so it
      -- triggers at its default version.
      CardanoHardForkTriggers -> [Maybe EpochNo]
triggerEpochs CardanoHardForkTriggers
triggers
        [Maybe EpochNo] -> [Maybe EpochNo] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [ EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just (Word64 -> EpochNo
EpochNo Word64
0)
            , EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just (Word64 -> EpochNo
EpochNo Word64
0)
            , EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just (Word64 -> EpochNo
EpochNo Word64
0)
            , EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just (Word64 -> EpochNo
EpochNo Word64
0)
            , EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just (Word64 -> EpochNo
EpochNo Word64
0)
            , EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just (Word64 -> EpochNo
EpochNo Word64
0)
            , Maybe EpochNo
forall a. Maybe a
Nothing
            ]

-- | An era configured to hard-fork at an epoch while an earlier era is not is
-- rejected, and reported as a 'ConfigError' rather than as a crash.
test_hardForkTriggersGap :: Assertion
test_hardForkTriggersGap :: Assertion
test_hardForkTriggersGap =
  -- Leaves Shelley and Allegra set, and Alonzo through Conway set, with the gap
  -- at Mary.
  [Key] -> [(Key, Maybe Value)] -> ([Char] -> Assertion) -> Assertion
forall a. [Key] -> [(Key, Maybe Value)] -> ([Char] -> IO a) -> IO a
withPatchedConfig [Key]
testingSection [(Key
"TestMaryHardForkAtEpoch", Maybe Value
forall a. Maybe a
Nothing)] (([Char] -> Assertion) -> Assertion)
-> ([Char] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \[Char]
file -> do
    nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
file
    case mkHardForkTriggers (Cfg.testingConfiguration nc) of
      Right CardanoHardForkTriggers
triggers ->
        [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"expected a rejection, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Maybe EpochNo] -> [Char]
forall a. Show a => a -> [Char]
show (CardanoHardForkTriggers -> [Maybe EpochNo]
triggerEpochs CardanoHardForkTriggers
triggers)
      Left [Char]
err ->
        [Char]
"it must also set it for all previous eras" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
err
          Bool -> [Char] -> Assertion
forall t.
(AssertionPredicable t, HasCallStack) =>
t -> [Char] -> Assertion
@? [Char]
"unexpected message: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err

    try (mkProtocolInfoAndBackend (CardanoBlockArgs file Nothing)) >>= \case
      Left (ConfigError [Char]
_) -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Right (ProtocolInfo (CardanoBlock StandardCrypto), Maybe LedgerDBBackend)
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected mkProtocolInfoAndBackend to reject the configuration"

-- | The initial nonce is the Blake2b-256 hash of the Shelley genesis file. The
-- configuration states that hash itself, so this also checks that the stated
-- hash and the file on disk have not drifted apart.
test_initialNonce :: Assertion
test_initialNonce :: Assertion
test_initialNonce = do
  nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
configFile
  expected <-
    Nonce . CryptoClass.castHash . CryptoClass.hashWith id
      <$> BS.readFile (configDir </> "shelley-genesis.json")
  mkInitialNonce nc @?= expected

-- | The configuration does not set @ExperimentalHardForksEnabled@, so it takes
-- @cardano-config@'s default of @false@ and the version stops at the era before
-- the experimental one.
test_protocolVersion :: Assertion
test_protocolVersion :: Assertion
test_protocolVersion = do
  nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
configFile
  mkProtocolVersion nc @?= ProtVer (L.eraProtVerHigh @(L.PreviousEra L.LatestKnownEra)) 0

-- | The fixture names a @DijkstraGenesisFile@ without enabling the experimental
-- era, so the fallback is used and not the file. Its file sets
-- @maxRefScriptSizePerTx@ to a value the fallback does not have, which is what
-- tells the two apart.
test_dijkstraGenesisDefault :: Assertion
test_dijkstraGenesisDefault :: Assertion
test_dijkstraGenesisDefault = do
  nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
configFile
  maxRefScriptSizePerTxOf (mkDijkstraGenesis nc) @?= 204800

-- | With the experimental era enabled, the file is what is used.
test_dijkstraGenesisFromFile :: Assertion
test_dijkstraGenesisFromFile :: Assertion
test_dijkstraGenesisFromFile =
  [Key] -> [(Key, Maybe Value)] -> ([Char] -> Assertion) -> Assertion
forall a. [Key] -> [(Key, Maybe Value)] -> ([Char] -> IO a) -> IO a
withPatchedConfig [Key]
testingSection [(Key
"ExperimentalHardForksEnabled", Value -> Maybe Value
forall a. a -> Maybe a
Just (Bool -> Value
Aeson.Bool Bool
True))] (([Char] -> Assertion) -> Assertion)
-> ([Char] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$
    \[Char]
file -> do
      nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
file
      maxRefScriptSizePerTxOf (mkDijkstraGenesis nc) @?= 123456

-- | The field that tells the fixture's file apart from the fallback.
maxRefScriptSizePerTxOf :: DijkstraGenesis -> Word32
maxRefScriptSizePerTxOf :: DijkstraGenesis -> Word32
maxRefScriptSizePerTxOf = UpgradeDijkstraPParams Identity LatestKnownEra -> Word32
UpgradeDijkstraPParams Identity LatestKnownEra
-> HKD Identity Word32
forall (f :: * -> *) era.
UpgradeDijkstraPParams f era -> HKD f Word32
udppMaxRefScriptSizePerTx (UpgradeDijkstraPParams Identity LatestKnownEra -> Word32)
-> (DijkstraGenesis
    -> UpgradeDijkstraPParams Identity LatestKnownEra)
-> DijkstraGenesis
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DijkstraGenesis -> UpgradeDijkstraPParams Identity LatestKnownEra
dgUpgradePParams

-- | With the experimental era enabled, the protocol version reaches it.
test_protocolVersionExperimental :: Assertion
test_protocolVersionExperimental :: Assertion
test_protocolVersionExperimental =
  [Key] -> [(Key, Maybe Value)] -> ([Char] -> Assertion) -> Assertion
forall a. [Key] -> [(Key, Maybe Value)] -> ([Char] -> IO a) -> IO a
withPatchedConfig [Key]
testingSection [(Key
"ExperimentalHardForksEnabled", Value -> Maybe Value
forall a. a -> Maybe a
Just (Bool -> Value
Aeson.Bool Bool
True))] (([Char] -> Assertion) -> Assertion)
-> ([Char] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$
    \[Char]
file -> do
      nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
file
      mkProtocolVersion nc @?= ProtVer (L.eraProtVerHigh @L.LatestKnownEra) 0

-- | This configuration has no @LedgerDB@ section, and @cardano-config@ defaults
-- the backend to the in-memory one, so that is what db-analyser uses when the
-- command line selects no backend.
test_ledgerDBBackendDefault :: Assertion
test_ledgerDBBackendDefault :: Assertion
test_ledgerDBBackendDefault = do
  nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
configFile
  backendOf nc >>= \case
    Just LedgerDBBackend
V2InMem -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe LedgerDBBackend
other -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"expected the in-memory backend, but got " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe LedgerDBBackend -> [Char]
describe Maybe LedgerDBBackend
other

-- | The LSM paths are taken from the configuration as they are: they are
-- interpreted relative to the ChainDB, not to the configuration file, so unlike
-- the genesis paths they must not be adjusted.
test_ledgerDBBackendLSM :: Assertion
test_ledgerDBBackendLSM :: Assertion
test_ledgerDBBackendLSM =
  [Key] -> [(Key, Maybe Value)] -> ([Char] -> Assertion) -> Assertion
forall a. [Key] -> [(Key, Maybe Value)] -> ([Char] -> IO a) -> IO a
withPatchedConfig
    [Key]
storageSection
    [ [(Key, Value)] -> (Key, Maybe Value)
lsmBackend
        [ (Key
"DatabasePath", Value
"some-lsm-dir")
        , (Key
"ExportPath", Value
"some-export-dir")
        ]
    ]
    (([Char] -> Assertion) -> Assertion)
-> ([Char] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \[Char]
file -> do
      nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
file
      backendOf nc >>= \case
        Just (V2LSM LSMOptions
opts) -> do
          LSMOptions -> [Char]
lsmDatabasePath LSMOptions
opts [Char] -> [Char] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Char]
"some-lsm-dir"
          LSMOptions -> Maybe [Char]
lsmExportPath LSMOptions
opts Maybe [Char] -> Maybe [Char] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"some-export-dir"
          -- Not configurable via the node configuration file.
          LSMOptions -> Bool
lsmNoDiskCache LSMOptions
opts Bool -> Bool -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
False
        Maybe LedgerDBBackend
other -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"expected the LSM backend, but got " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe LedgerDBBackend -> [Char]
describe Maybe LedgerDBBackend
other

-- | @cardano-config@ happily accepts an absolute @DatabasePath@, but
-- db-analyser cannot honour one, because it mounts the path inside the ChainDB.
-- Rejecting it beats silently using a different directory than the one asked
-- for.
test_ledgerDBBackendLSMAbsolute :: Assertion
test_ledgerDBBackendLSMAbsolute :: Assertion
test_ledgerDBBackendLSMAbsolute =
  [Key] -> [(Key, Maybe Value)] -> ([Char] -> Assertion) -> Assertion
forall a. [Key] -> [(Key, Maybe Value)] -> ([Char] -> IO a) -> IO a
withPatchedConfig [Key]
storageSection [[(Key, Value)] -> (Key, Maybe Value)
lsmBackend [(Key
"DatabasePath", Value
"/absolute/lsm")]] (([Char] -> Assertion) -> Assertion)
-> ([Char] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \[Char]
file -> do
    nc <- [Char] -> IO NodeConfiguration
resolveNewFormat [Char]
file
    case mkLedgerDBBackend (Cfg.storageConfiguration nc) of
      Right Maybe LedgerDBBackend
backend ->
        [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"expected a rejection, but got " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe LedgerDBBackend -> [Char]
describe Maybe LedgerDBBackend
backend
      Left [Char]
err -> do
        [Char]
"DatabasePath" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
err Bool -> [Char] -> Assertion
forall t.
(AssertionPredicable t, HasCallStack) =>
t -> [Char] -> Assertion
@? [Char]
"unexpected message: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err
        [Char]
"must be relative" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
err Bool -> [Char] -> Assertion
forall t.
(AssertionPredicable t, HasCallStack) =>
t -> [Char] -> Assertion
@? [Char]
"unexpected message: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err

-- | The LSM settings of a configuration that selects LSM, for the
-- 'selectLedgerDBBackend' tests.
configuredLSM :: LSMOptions
configuredLSM :: LSMOptions
configuredLSM =
  LSMOptions
    { lsmDatabasePath :: [Char]
lsmDatabasePath = [Char]
"some-lsm-dir"
    , lsmExportPath :: Maybe [Char]
lsmExportPath = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"some-export-dir"
    , lsmNoDiskCache :: Bool
lsmNoDiskCache = Bool
False
    }

-- | A bare @--lsm@ must not drop what the configuration sets: in particular a
-- configured @ExportPath@ keeps exporting snapshots.
test_lsmFlagKeepsConfig :: Assertion
test_lsmFlagKeepsConfig :: Assertion
test_lsmFlagKeepsConfig =
  case Maybe LedgerDBBackendFlags
-> Maybe LedgerDBBackend -> Maybe LedgerDBBackend
selectLedgerDBBackend (LedgerDBBackendFlags -> Maybe LedgerDBBackendFlags
forall a. a -> Maybe a
Just (LSMFlags -> LedgerDBBackendFlags
LSMFlag (Bool -> Bool -> LSMFlags
LSMFlags Bool
False Bool
True))) (LedgerDBBackend -> Maybe LedgerDBBackend
forall a. a -> Maybe a
Just (LSMOptions -> LedgerDBBackend
V2LSM LSMOptions
configuredLSM)) of
    Just (V2LSM LSMOptions
opts) -> do
      LSMOptions -> [Char]
lsmDatabasePath LSMOptions
opts [Char] -> [Char] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Char]
"some-lsm-dir"
      LSMOptions -> Maybe [Char]
lsmExportPath LSMOptions
opts Maybe [Char] -> Maybe [Char] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"some-export-dir"
      LSMOptions -> Bool
lsmNoDiskCache LSMOptions
opts Bool -> Bool -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True
    Maybe LedgerDBBackend
other -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"expected the LSM backend, but got " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe LedgerDBBackend -> [Char]
describe Maybe LedgerDBBackend
other

-- | @--lsm-export@ exports into the configured directory, not the default one.
test_lsmExportFlagConfigured :: Assertion
test_lsmExportFlagConfigured :: Assertion
test_lsmExportFlagConfigured =
  case Maybe LedgerDBBackendFlags
-> Maybe LedgerDBBackend -> Maybe LedgerDBBackend
selectLedgerDBBackend (LedgerDBBackendFlags -> Maybe LedgerDBBackendFlags
forall a. a -> Maybe a
Just (LSMFlags -> LedgerDBBackendFlags
LSMFlag (Bool -> Bool -> LSMFlags
LSMFlags Bool
True Bool
False))) (LedgerDBBackend -> Maybe LedgerDBBackend
forall a. a -> Maybe a
Just (LSMOptions -> LedgerDBBackend
V2LSM LSMOptions
configuredLSM)) of
    Just (V2LSM LSMOptions
opts) -> LSMOptions -> Maybe [Char]
lsmExportPath LSMOptions
opts Maybe [Char] -> Maybe [Char] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"some-export-dir"
    Maybe LedgerDBBackend
other -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"expected the LSM backend, but got " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe LedgerDBBackend -> [Char]
describe Maybe LedgerDBBackend
other

-- | With no LSM settings to start from, @--lsm@ uses the defaults.
test_lsmFlagDefaults :: Assertion
test_lsmFlagDefaults :: Assertion
test_lsmFlagDefaults =
  case Maybe LedgerDBBackendFlags
-> Maybe LedgerDBBackend -> Maybe LedgerDBBackend
selectLedgerDBBackend (LedgerDBBackendFlags -> Maybe LedgerDBBackendFlags
forall a. a -> Maybe a
Just (LSMFlags -> LedgerDBBackendFlags
LSMFlag (Bool -> Bool -> LSMFlags
LSMFlags Bool
True Bool
False))) (LedgerDBBackend -> Maybe LedgerDBBackend
forall a. a -> Maybe a
Just LedgerDBBackend
V2InMem) of
    Just (V2LSM LSMOptions
opts) -> do
      LSMOptions -> [Char]
lsmDatabasePath LSMOptions
opts [Char] -> [Char] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Char]
"lsm"
      LSMOptions -> Maybe [Char]
lsmExportPath LSMOptions
opts Maybe [Char] -> Maybe [Char] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"lsm-exported"
      LSMOptions -> Bool
lsmNoDiskCache LSMOptions
opts Bool -> Bool -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
False
    Maybe LedgerDBBackend
other -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"expected the LSM backend, but got " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe LedgerDBBackend -> [Char]
describe Maybe LedgerDBBackend
other

-- | @cardano-config@ reports a missing mandatory key by throwing, not in its
-- result, so check that such a configuration still reaches the user as a plain
-- 'ConfigError' message rather than as a backtrace.
test_malformedIsConfigError :: Assertion
test_malformedIsConfigError :: Assertion
test_malformedIsConfigError =
  [Key] -> [(Key, Maybe Value)] -> ([Char] -> Assertion) -> Assertion
forall a. [Key] -> [(Key, Maybe Value)] -> ([Char] -> IO a) -> IO a
withPatchedConfig [Key]
protocolSection [(Key
"ByronGenesisHash", Maybe Value
forall a. Maybe a
Nothing)] (([Char] -> Assertion) -> Assertion)
-> ([Char] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \[Char]
file ->
    IO (NodeConfiguration, [ConfigWarning])
-> IO (Either ConfigError (NodeConfiguration, [ConfigWarning]))
forall e a. Exception e => IO a -> IO (Either e a)
try ([Char] -> IO (NodeConfiguration, [ConfigWarning])
resolveNodeConfiguration [Char]
file) IO (Either ConfigError (NodeConfiguration, [ConfigWarning]))
-> (Either ConfigError (NodeConfiguration, [ConfigWarning])
    -> Assertion)
-> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right (NodeConfiguration, [ConfigWarning])
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected the configuration to be rejected"
      Left (ConfigError [Char]
msg) ->
        [Char]
"ByronGenesisHash" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
msg Bool -> [Char] -> Assertion
forall t.
(AssertionPredicable t, HasCallStack) =>
t -> [Char] -> Assertion
@? [Char]
"unexpected message: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg

-- | The end-to-end path db-analyser actually takes, which additionally forces
-- every genesis file to be found and decoded.
test_mkProtocolInfoAndBackend :: Assertion
test_mkProtocolInfoAndBackend :: Assertion
test_mkProtocolInfoAndBackend = do
  (pInfo, backend) <- Args (CardanoBlock StandardCrypto)
-> IO
     (ProtocolInfo (CardanoBlock StandardCrypto), Maybe LedgerDBBackend)
forall blk.
HasProtocolInfo blk =>
Args blk -> IO (ProtocolInfo blk, Maybe LedgerDBBackend)
mkProtocolInfoAndBackend ([Char]
-> Maybe PBftSignatureThreshold
-> Args (CardanoBlock StandardCrypto)
CardanoBlockArgs [Char]
configFile Maybe PBftSignatureThreshold
forall a. Maybe a
Nothing)
  case backend of
    Just LedgerDBBackend
V2InMem -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe LedgerDBBackend
other -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"expected the in-memory backend, but got " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe LedgerDBBackend -> [Char]
describe Maybe LedgerDBBackend
other
  -- Forces the initial ledger state, and with it the transition config built
  -- from all the genesis files.
  pInfoInitLedger pInfo `seq` pure ()

{-------------------------------------------------------------------------------
  Helpers
-------------------------------------------------------------------------------}

backendOf :: Cfg.NodeConfiguration -> IO (Maybe LedgerDBBackend)
backendOf :: NodeConfiguration -> IO (Maybe LedgerDBBackend)
backendOf NodeConfiguration
nc =
  case StorageConfiguration Identity
-> Either [Char] (Maybe LedgerDBBackend)
mkLedgerDBBackend (NodeConfiguration -> StorageConfiguration Identity
Cfg.storageConfiguration NodeConfiguration
nc) of
    Left [Char]
err -> [Char] -> IO (Maybe LedgerDBBackend)
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> IO (Maybe LedgerDBBackend))
-> [Char] -> IO (Maybe LedgerDBBackend)
forall a b. (a -> b) -> a -> b
$ [Char]
"expected a backend, but got: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err
    Right Maybe LedgerDBBackend
backend -> Maybe LedgerDBBackend -> IO (Maybe LedgerDBBackend)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LedgerDBBackend
backend

-- | 'LedgerDBBackend' has no 'Show' instance, so name it for assertion messages.
describe :: Maybe LedgerDBBackend -> String
describe :: Maybe LedgerDBBackend -> [Char]
describe = \case
  Maybe LedgerDBBackend
Nothing -> [Char]
"no backend at all"
  Just LedgerDBBackend
V2InMem -> [Char]
"the in-memory backend"
  Just (V2LSM LSMOptions
opts) -> [Char]
"the LSM backend at " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show (LSMOptions -> [Char]
lsmDatabasePath LSMOptions
opts)

triggerEpochs :: CardanoHardForkTriggers -> [Maybe EpochNo]
triggerEpochs :: CardanoHardForkTriggers -> [Maybe EpochNo]
triggerEpochs = NP (K (Maybe EpochNo)) (CardanoShelleyEras StandardCrypto)
-> [Maybe EpochNo]
NP (K (Maybe EpochNo)) (CardanoShelleyEras StandardCrypto)
-> CollapseTo NP (Maybe EpochNo)
forall (xs :: [*]) a.
SListIN NP xs =>
NP (K a) xs -> CollapseTo NP a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K (Maybe EpochNo)) (CardanoShelleyEras StandardCrypto)
 -> [Maybe EpochNo])
-> (CardanoHardForkTriggers
    -> NP (K (Maybe EpochNo)) (CardanoShelleyEras StandardCrypto))
-> CardanoHardForkTriggers
-> [Maybe EpochNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. CardanoHardForkTrigger a -> K (Maybe EpochNo) a)
-> NP CardanoHardForkTrigger (CardanoShelleyEras StandardCrypto)
-> NP (K (Maybe EpochNo)) (CardanoShelleyEras StandardCrypto)
forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (Maybe EpochNo -> K (Maybe EpochNo) a
forall k a (b :: k). a -> K a b
K (Maybe EpochNo -> K (Maybe EpochNo) a)
-> (CardanoHardForkTrigger a -> Maybe EpochNo)
-> CardanoHardForkTrigger a
-> K (Maybe EpochNo) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoHardForkTrigger a -> Maybe EpochNo
forall blk. CardanoHardForkTrigger blk -> Maybe EpochNo
epochOf) (NP CardanoHardForkTrigger (CardanoShelleyEras StandardCrypto)
 -> NP (K (Maybe EpochNo)) (CardanoShelleyEras StandardCrypto))
-> (CardanoHardForkTriggers
    -> NP CardanoHardForkTrigger (CardanoShelleyEras StandardCrypto))
-> CardanoHardForkTriggers
-> NP (K (Maybe EpochNo)) (CardanoShelleyEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoHardForkTriggers
-> NP CardanoHardForkTrigger (CardanoShelleyEras StandardCrypto)
getCardanoHardForkTriggers
 where
  epochOf :: CardanoHardForkTrigger blk -> Maybe EpochNo
  epochOf :: forall blk. CardanoHardForkTrigger blk -> Maybe EpochNo
epochOf = \case
    CardanoHardForkTrigger blk
CardanoTriggerHardForkAtDefaultVersion -> Maybe EpochNo
forall a. Maybe a
Nothing
    CardanoTriggerHardForkAtEpoch EpochNo
epoch -> EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
epoch