{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.ThreadNet.Infra.Byron.ProtocolInfo (
    mkLeaderCredentials
  , mkProtocolByron
  , theProposedProtocolVersion
  , theProposedSoftwareVersion
  ) where

import qualified Cardano.Chain.Common as Common
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.Genesis as Genesis
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Crypto as Crypto
import           Data.Foldable (find)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe)
import           GHC.Stack (HasCallStack)
import           Ouroboros.Consensus.Block.Forging (BlockForging)
import           Ouroboros.Consensus.Byron.Crypto.DSIGN (ByronDSIGN,
                     SignKeyDSIGN (..))
import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
import           Ouroboros.Consensus.Byron.Node
import           Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..))
import           Ouroboros.Consensus.NodeId (CoreNodeId (..))
import           Ouroboros.Consensus.Protocol.PBFT

mkProtocolByron ::
     forall m. (Monad m, HasCallStack)
  => PBftParams
  -> CoreNodeId
  -> Genesis.Config
  -> Genesis.GeneratedSecrets
  -> (ProtocolInfo ByronBlock, [BlockForging m ByronBlock], SignKeyDSIGN ByronDSIGN)
     -- ^ We return the signing key which is needed in some tests, because it
     -- cannot easily be extracted from the 'ProtocolInfo'.
mkProtocolByron :: forall (m :: * -> *).
(Monad m, HasCallStack) =>
PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> (ProtocolInfo ByronBlock, [BlockForging m ByronBlock],
    SignKeyDSIGN ByronDSIGN)
mkProtocolByron PBftParams
params CoreNodeId
coreNodeId Config
genesisConfig GeneratedSecrets
genesisSecrets =
    (ProtocolInfo ByronBlock
protocolInfo, [BlockForging m ByronBlock]
blockForging, SignKeyDSIGN ByronDSIGN
signingKey)
  where
    leaderCredentials :: ByronLeaderCredentials
    leaderCredentials :: ByronLeaderCredentials
leaderCredentials =
        HasCallStack =>
Config -> GeneratedSecrets -> CoreNodeId -> ByronLeaderCredentials
Config -> GeneratedSecrets -> CoreNodeId -> ByronLeaderCredentials
mkLeaderCredentials
          Config
genesisConfig
          GeneratedSecrets
genesisSecrets
          CoreNodeId
coreNodeId

    signingKey :: SignKeyDSIGN ByronDSIGN
    signingKey :: SignKeyDSIGN ByronDSIGN
signingKey = SigningKey -> SignKeyDSIGN ByronDSIGN
SignKeyByronDSIGN (ByronLeaderCredentials -> SigningKey
blcSignKey ByronLeaderCredentials
leaderCredentials)

    PBftParams { PBftSignatureThreshold
pbftSignatureThreshold :: PBftSignatureThreshold
pbftSignatureThreshold :: PBftParams -> PBftSignatureThreshold
pbftSignatureThreshold } = PBftParams
params

    protocolInfo :: ProtocolInfo ByronBlock
    protocolInfo :: ProtocolInfo ByronBlock
protocolInfo = ProtocolParamsByron -> ProtocolInfo ByronBlock
protocolInfoByron ProtocolParamsByron
protocolParams

    blockForging :: [BlockForging m ByronBlock]
    blockForging :: [BlockForging m ByronBlock]
blockForging = ProtocolParamsByron -> [BlockForging m ByronBlock]
forall (m :: * -> *).
Monad m =>
ProtocolParamsByron -> [BlockForging m ByronBlock]
blockForgingByron ProtocolParamsByron
protocolParams

    protocolParams :: ProtocolParamsByron
    protocolParams :: ProtocolParamsByron
protocolParams = ProtocolParamsByron {
            $sel:byronGenesis:ProtocolParamsByron :: Config
byronGenesis                = Config
genesisConfig
          , $sel:byronPbftSignatureThreshold:ProtocolParamsByron :: Maybe PBftSignatureThreshold
byronPbftSignatureThreshold = PBftSignatureThreshold -> Maybe PBftSignatureThreshold
forall a. a -> Maybe a
Just (PBftSignatureThreshold -> Maybe PBftSignatureThreshold)
-> PBftSignatureThreshold -> Maybe PBftSignatureThreshold
forall a b. (a -> b) -> a -> b
$ PBftSignatureThreshold
pbftSignatureThreshold
          , $sel:byronProtocolVersion:ProtocolParamsByron :: ProtocolVersion
byronProtocolVersion        = ProtocolVersion
theProposedProtocolVersion
          , $sel:byronSoftwareVersion:ProtocolParamsByron :: SoftwareVersion
byronSoftwareVersion        = SoftwareVersion
theProposedSoftwareVersion
          , $sel:byronLeaderCredentials:ProtocolParamsByron :: Maybe ByronLeaderCredentials
byronLeaderCredentials      = ByronLeaderCredentials -> Maybe ByronLeaderCredentials
forall a. a -> Maybe a
Just ByronLeaderCredentials
leaderCredentials
          }

mkLeaderCredentials ::
     HasCallStack
  => Genesis.Config
  -> Genesis.GeneratedSecrets
  -> CoreNodeId
  -> ByronLeaderCredentials
mkLeaderCredentials :: HasCallStack =>
Config -> GeneratedSecrets -> CoreNodeId -> ByronLeaderCredentials
mkLeaderCredentials Config
genesisConfig GeneratedSecrets
genesisSecrets (CoreNodeId Word64
i) =
    (ByronLeaderCredentialsError -> ByronLeaderCredentials)
-> (ByronLeaderCredentials -> ByronLeaderCredentials)
-> Either ByronLeaderCredentialsError ByronLeaderCredentials
-> ByronLeaderCredentials
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> ByronLeaderCredentials
forall a. HasCallStack => [Char] -> a
error ([Char] -> ByronLeaderCredentials)
-> (ByronLeaderCredentialsError -> [Char])
-> ByronLeaderCredentialsError
-> ByronLeaderCredentials
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByronLeaderCredentialsError -> [Char]
forall a. Show a => a -> [Char]
show) ByronLeaderCredentials -> ByronLeaderCredentials
forall a. a -> a
id (Either ByronLeaderCredentialsError ByronLeaderCredentials
 -> ByronLeaderCredentials)
-> Either ByronLeaderCredentialsError ByronLeaderCredentials
-> ByronLeaderCredentials
forall a b. (a -> b) -> a -> b
$
      Config
-> SigningKey
-> Certificate
-> Text
-> Either ByronLeaderCredentialsError ByronLeaderCredentials
mkByronLeaderCredentials
        Config
genesisConfig
        SigningKey
dlgKey
        Certificate
dlgCert
        Text
"ThreadNet"
  where
    dlgKey :: Crypto.SigningKey
    dlgKey :: SigningKey
dlgKey = SigningKey -> Maybe SigningKey -> SigningKey
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> SigningKey
forall a. HasCallStack => [Char] -> a
error [Char]
"dlgKey") (Maybe SigningKey -> SigningKey) -> Maybe SigningKey -> SigningKey
forall a b. (a -> b) -> a -> b
$
       (SigningKey -> Bool) -> [SigningKey] -> Maybe SigningKey
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\SigningKey
sec -> Certificate -> VerificationKey
forall a. ACertificate a -> VerificationKey
Delegation.delegateVK Certificate
dlgCert VerificationKey -> VerificationKey -> Bool
forall a. Eq a => a -> a -> Bool
== SigningKey -> VerificationKey
Crypto.toVerification SigningKey
sec)
            ([SigningKey] -> Maybe SigningKey)
-> [SigningKey] -> Maybe SigningKey
forall a b. (a -> b) -> a -> b
$ GeneratedSecrets -> [SigningKey]
Genesis.gsRichSecrets GeneratedSecrets
genesisSecrets

    dlgCert :: Delegation.Certificate
    dlgCert :: Certificate
dlgCert = (KeyHash, Certificate) -> Certificate
forall a b. (a, b) -> b
snd ((KeyHash, Certificate) -> Certificate)
-> (KeyHash, Certificate) -> Certificate
forall a b. (a -> b) -> a -> b
$ Map KeyHash Certificate -> [(KeyHash, Certificate)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map KeyHash Certificate
dlgMap [(KeyHash, Certificate)] -> Int -> (KeyHash, Certificate)
forall a. HasCallStack => [a] -> Int -> a
!! (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)

    dlgMap :: Map Common.KeyHash Delegation.Certificate
    dlgMap :: Map KeyHash Certificate
dlgMap = GenesisDelegation -> Map KeyHash Certificate
Genesis.unGenesisDelegation
           (GenesisDelegation -> Map KeyHash Certificate)
-> GenesisDelegation -> Map KeyHash Certificate
forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisDelegation
Genesis.gdHeavyDelegation
           (GenesisData -> GenesisDelegation)
-> GenesisData -> GenesisDelegation
forall a b. (a -> b) -> a -> b
$ Config -> GenesisData
Genesis.configGenesisData Config
genesisConfig

-- | The protocol version proposed as part of the hard-fork smoke test
--
-- The initial Byron ledger state begins with protocol version @0.0.0@. In the
-- smoke test, if the proposal and votes are enabled, then we will be proposing
-- an update to @1.0.0@.
--
-- This value occurs in two crucial places: the proposal and also the
-- 'Byron.byronProtocolVersion' field of the static node config. See the
-- Haddock comment on 'mkProtocolByronAndHardForkTxs'.
--
theProposedProtocolVersion :: Update.ProtocolVersion
theProposedProtocolVersion :: ProtocolVersion
theProposedProtocolVersion = Word16 -> Word16 -> Word8 -> ProtocolVersion
Update.ProtocolVersion Word16
1 Word16
0 Word8
0

-- | The software version proposed as part of the hard-fork smoke test
--
-- We don't actually care about this for the smoke test, but we have to set it
-- both as part of the proposal and also as part of the node's static
-- configuration. Its use in the static configuration is legacy and does not
-- seem to affect anything; see Issue #1732.
--
-- The initial Byron ledger state begins with no recorded software versions.
-- For the addition of a new software version, the Byron ledger rules require
-- that it starts at 0 or 1.
--
theProposedSoftwareVersion :: Update.SoftwareVersion
theProposedSoftwareVersion :: SoftwareVersion
theProposedSoftwareVersion = ApplicationName -> NumSoftwareVersion -> SoftwareVersion
Update.SoftwareVersion
  -- appnames must be ASCII and <= 12 characters
  (Text -> ApplicationName
Update.ApplicationName Text
"Dummy")
  NumSoftwareVersion
0