{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- Necessary to give the 'HasPointScheduleTestParams' instance for 'TestBlockWith'.
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.PeerSimulator.Config (defaultCfg) where

import Cardano.Crypto.DSIGN (SignKeyDSIGN (..), VerKeyDSIGN (..))
import Cardano.Slotting.Time (SlotLength, slotLengthFromSec)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Ouroboros.Consensus.Config
  ( SecurityParam
  , TopLevelConfig (..)
  , emptyCheckpointsMap
  )
import Ouroboros.Consensus.HardFork.History
  ( EraParams (eraGenesisWin)
  )
import qualified Ouroboros.Consensus.HardFork.History.EraParams as HardFork
import Ouroboros.Consensus.Ledger.SupportsProtocol (GenesisWindow)
import Ouroboros.Consensus.Node.ProtocolInfo
  ( NumCoreNodes (NumCoreNodes)
  , ProtocolInfo (..)
  )
import Ouroboros.Consensus.NodeId
  ( CoreNodeId (CoreNodeId)
  , NodeId (CoreId)
  )
import Ouroboros.Consensus.Protocol.BFT
  ( BftParams (BftParams, bftNumNodes, bftSecurityParam)
  , ConsensusConfig (BftConfig, bftParams, bftSignKey, bftVerKeys)
  )
import Test.Consensus.PointSchedule
  ( ForecastRange (ForecastRange)
  , HasPointScheduleTestParams (..)
  )
import Test.Util.ChainDB (mkTestChunkInfo)
import Test.Util.Orphans.IOLike ()
import Test.Util.TestBlock
  ( BlockConfig (TestBlockConfig)
  , CodecConfig (TestBlockCodecConfig)
  , StorageConfig (TestBlockStorageConfig)
  , TestBlock
  , TestBlockLedgerConfig (..)
  , TestBlockWith (..)
  , testInitExtLedger
  )

-- REVIEW: this has not been deliberately chosen
defaultCfg :: SecurityParam -> ForecastRange -> GenesisWindow -> TopLevelConfig TestBlock
defaultCfg :: SecurityParam
-> ForecastRange -> GenesisWindow -> TopLevelConfig TestBlock
defaultCfg SecurityParam
secParam (ForecastRange Word64
sfor) GenesisWindow
sgen =
  TopLevelConfig
    { topLevelConfigProtocol :: ConsensusConfig (BlockProtocol TestBlock)
topLevelConfigProtocol =
        BftConfig
          { bftParams :: BftParams
bftParams =
              BftParams
                { bftSecurityParam :: SecurityParam
bftSecurityParam = SecurityParam
secParam
                , bftNumNodes :: NumCoreNodes
bftNumNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
2
                }
          , bftSignKey :: SignKeyDSIGN (BftDSIGN BftMockCrypto)
bftSignKey = Word64 -> SignKeyDSIGN MockDSIGN
SignKeyMockDSIGN Word64
0
          , bftVerKeys :: Map NodeId (VerKeyDSIGN (BftDSIGN BftMockCrypto))
bftVerKeys =
              [(NodeId, VerKeyDSIGN MockDSIGN)]
-> Map NodeId (VerKeyDSIGN MockDSIGN)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ (CoreNodeId -> NodeId
CoreId (Word64 -> CoreNodeId
CoreNodeId Word64
0), Word64 -> VerKeyDSIGN MockDSIGN
VerKeyMockDSIGN Word64
0)
                , (CoreNodeId -> NodeId
CoreId (Word64 -> CoreNodeId
CoreNodeId Word64
1), Word64 -> VerKeyDSIGN MockDSIGN
VerKeyMockDSIGN Word64
1)
                ]
          }
    , topLevelConfigLedger :: LedgerConfig TestBlock
topLevelConfigLedger = EraParams -> StrictMaybe SlotNo -> TestBlockLedgerConfig
TestBlockLedgerConfig EraParams
eraParams (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sfor))
    , topLevelConfigBlock :: BlockConfig TestBlock
topLevelConfigBlock = NumCoreNodes -> BlockConfig TestBlock
forall ptype. NumCoreNodes -> BlockConfig (TestBlockWith ptype)
TestBlockConfig NumCoreNodes
numCoreNodes
    , topLevelConfigCodec :: CodecConfig TestBlock
topLevelConfigCodec = CodecConfig TestBlock
TestBlockCodecConfig
    , topLevelConfigStorage :: StorageConfig TestBlock
topLevelConfigStorage = StorageConfig TestBlock
TestBlockStorageConfig
    , topLevelConfigCheckpoints :: CheckpointsMap TestBlock
topLevelConfigCheckpoints = CheckpointsMap TestBlock
forall blk. CheckpointsMap blk
emptyCheckpointsMap
    }
 where
  -- REVIEW: Make it 1s or a parameter?
  slotLength :: SlotLength
  slotLength :: SlotLength
slotLength = Integer -> SlotLength
slotLengthFromSec Integer
20

  eraParams :: HardFork.EraParams
  eraParams :: EraParams
eraParams = (SecurityParam -> SlotLength -> EraParams
HardFork.defaultEraParams SecurityParam
secParam SlotLength
slotLength){eraGenesisWin = sgen}

  numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
2

-- | If you are here because you tried to implement `HasPointScheduleTestParams` for
-- some type `TestBlockWith Foo` and got an overlapping instance warning, the `a ~ ()`
-- constraint is only here to get your attention. The tests should remain as block
-- polymorphic as possible, so /maybe/ there should be a class for the types `a` that
-- can appear in `TestBlockWith a`. But we in the past do not know what that class
-- should look like! So the choice is yours: if what you need from this class can be
-- made polymorphic in `a`, consider adding a class. If not, specialize this instance.
instance a ~ () => HasPointScheduleTestParams (TestBlockWith a) where
  data ProtocolInfoArgs (TestBlockWith a) = TestBlockProtocolInfoArgs
  getProtocolInfoArgs :: IO (ProtocolInfoArgs (TestBlockWith a))
getProtocolInfoArgs = ProtocolInfoArgs (TestBlockWith a)
-> IO (ProtocolInfoArgs (TestBlockWith a))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtocolInfoArgs (TestBlockWith a)
forall a. ProtocolInfoArgs (TestBlockWith a)
TestBlockProtocolInfoArgs
  mkProtocolInfo :: SecurityParam
-> ForecastRange
-> GenesisWindow
-> ProtocolInfoArgs (TestBlockWith a)
-> ProtocolInfo (TestBlockWith a)
mkProtocolInfo SecurityParam
k ForecastRange
forecast GenesisWindow
window ProtocolInfoArgs (TestBlockWith a)
_ =
    ProtocolInfo
      { pInfoConfig :: TopLevelConfig TestBlock
pInfoConfig = SecurityParam
-> ForecastRange -> GenesisWindow -> TopLevelConfig TestBlock
defaultCfg SecurityParam
k ForecastRange
forecast GenesisWindow
window
      , pInfoInitLedger :: ExtLedgerState TestBlock ValuesMK
pInfoInitLedger = ExtLedgerState TestBlock ValuesMK
testInitExtLedger
      }
  getChunkInfoFromTopLevelConfig :: TopLevelConfig (TestBlockWith a) -> ChunkInfo
getChunkInfoFromTopLevelConfig = TopLevelConfig (TestBlockWith a) -> ChunkInfo
TopLevelConfig TestBlock -> ChunkInfo
mkTestChunkInfo