{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Protocol.Praos.Translate () where

import           Cardano.Crypto.DSIGN (VerKeyDSIGN)
import           Cardano.Crypto.VRF (VerKeyVRF)
import qualified Cardano.Ledger.Chain as SL
import           Cardano.Ledger.Crypto (ADDRHASH, HASH)
import qualified Cardano.Ledger.PoolDistr as SL
import qualified Cardano.Protocol.TPraos.API as SL
import qualified Cardano.Protocol.TPraos.Rules.Prtcl as SL
import qualified Cardano.Protocol.TPraos.Rules.Tickn as SL
import           Data.Coerce (coerce)
import qualified Data.Map.Strict as Map
import           Ouroboros.Consensus.Protocol.Praos (ConsensusConfig (..),
                     Praos, PraosParams (..), PraosState (..),
                     Ticked (TickedPraosLedgerView))
import           Ouroboros.Consensus.Protocol.Praos.Views
                     (LedgerView (lvMaxBodySize, lvMaxHeaderSize, lvProtocolVersion))
import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views
import           Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosParams (..),
                     TPraosState (tpraosStateChainDepState, tpraosStateLastSlot))
import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos
import           Ouroboros.Consensus.Protocol.Translate (TranslateProto (..))

{-------------------------------------------------------------------------------
  Translation from transitional Praos
-------------------------------------------------------------------------------}

-- | We can translate between TPraos and Praos, provided:
--
-- - They share the same HASH algorithm
-- - They share the same ADDRHASH algorithm
-- - They share the same DSIGN verification keys
-- - They share the same VRF verification keys
instance
  ( HASH c1 ~ HASH c2,
    ADDRHASH c1 ~ ADDRHASH c2,
    VerKeyDSIGN c1 ~ VerKeyDSIGN c2,
    VerKeyVRF c1 ~ VerKeyVRF c2
  ) =>
  TranslateProto (TPraos c1) (Praos c2)
  where
  translateConsensusConfig :: ConsensusConfig (TPraos c1) -> ConsensusConfig (Praos c2)
translateConsensusConfig TPraosConfig {tpraosParams, tpraosEpochInfo} =
    PraosConfig :: forall c.
PraosParams
-> EpochInfo (Except PastHorizonException)
-> ConsensusConfig (Praos c)
PraosConfig
      { praosParams :: PraosParams
praosParams =
          PraosParams :: Word64
-> ActiveSlotCoeff
-> SecurityParam
-> Word64
-> Word64
-> MaxMajorProtVer
-> Word64
-> Network
-> SystemStart
-> PraosParams
PraosParams
            { praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod = TPraosParams -> Word64
tpraosSlotsPerKESPeriod TPraosParams
tpraosParams,
              praosLeaderF :: ActiveSlotCoeff
praosLeaderF = TPraosParams -> ActiveSlotCoeff
tpraosLeaderF TPraosParams
tpraosParams,
              praosSecurityParam :: SecurityParam
praosSecurityParam = TPraosParams -> SecurityParam
tpraosSecurityParam TPraosParams
tpraosParams,
              praosMaxKESEvo :: Word64
praosMaxKESEvo = TPraosParams -> Word64
tpraosMaxKESEvo TPraosParams
tpraosParams,
              praosQuorum :: Word64
praosQuorum = TPraosParams -> Word64
tpraosQuorum TPraosParams
tpraosParams,
              praosMaxMajorPV :: MaxMajorProtVer
praosMaxMajorPV = TPraosParams -> MaxMajorProtVer
tpraosMaxMajorPV TPraosParams
tpraosParams,
              praosMaxLovelaceSupply :: Word64
praosMaxLovelaceSupply = TPraosParams -> Word64
tpraosMaxLovelaceSupply TPraosParams
tpraosParams,
              praosNetworkId :: Network
praosNetworkId = TPraosParams -> Network
tpraosNetworkId TPraosParams
tpraosParams,
              praosSystemStart :: SystemStart
praosSystemStart = TPraosParams -> SystemStart
tpraosSystemStart TPraosParams
tpraosParams
            },
        praosEpochInfo :: EpochInfo (Except PastHorizonException)
praosEpochInfo = EpochInfo (Except PastHorizonException)
tpraosEpochInfo
      }

  translateTickedLedgerView :: Ticked (LedgerView (TPraos c1)) -> Ticked (LedgerView (Praos c2))
translateTickedLedgerView (TPraos.TickedPraosLedgerView lv) =
      LedgerView c2 -> Ticked (LedgerView c2)
forall c. LedgerView c -> Ticked (LedgerView c)
TickedPraosLedgerView (LedgerView c2 -> Ticked (LedgerView c2))
-> LedgerView c2 -> Ticked (LedgerView c2)
forall a b. (a -> b) -> a -> b
$ LedgerView c1 -> LedgerView c2
translateLedgerView LedgerView c1
lv
    where
      translateLedgerView :: LedgerView c1 -> LedgerView c2
translateLedgerView SL.LedgerView {PoolDistr c1
lvPoolDistr :: forall crypto. LedgerView crypto -> PoolDistr crypto
lvPoolDistr :: PoolDistr c1
SL.lvPoolDistr, ChainChecksPParams
lvChainChecks :: forall crypto. LedgerView crypto -> ChainChecksPParams
lvChainChecks :: ChainChecksPParams
SL.lvChainChecks} =
        LedgerView :: forall crypto.
PoolDistr crypto
-> Natural -> Natural -> ProtVer -> LedgerView crypto
Views.LedgerView
          { lvPoolDistr :: PoolDistr c2
Views.lvPoolDistr = PoolDistr c1 -> PoolDistr c2
coercePoolDistr PoolDistr c1
lvPoolDistr,
            lvMaxHeaderSize :: Natural
lvMaxHeaderSize = ChainChecksPParams -> Natural
SL.ccMaxBHSize ChainChecksPParams
lvChainChecks,
            lvMaxBodySize :: Natural
lvMaxBodySize = ChainChecksPParams -> Natural
SL.ccMaxBBSize ChainChecksPParams
lvChainChecks,
            lvProtocolVersion :: ProtVer
lvProtocolVersion = ChainChecksPParams -> ProtVer
SL.ccProtocolVersion ChainChecksPParams
lvChainChecks
          }
        where
          coercePoolDistr :: SL.PoolDistr c1 -> SL.PoolDistr c2
          coercePoolDistr :: PoolDistr c1 -> PoolDistr c2
coercePoolDistr (SL.PoolDistr Map (KeyHash 'StakePool c1) (IndividualPoolStake c1)
m) =
            Map (KeyHash 'StakePool c2) (IndividualPoolStake c2)
-> PoolDistr c2
forall crypto.
Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
-> PoolDistr crypto
SL.PoolDistr
              (Map (KeyHash 'StakePool c2) (IndividualPoolStake c2)
 -> PoolDistr c2)
-> (Map (KeyHash 'StakePool c1) (IndividualPoolStake c1)
    -> Map (KeyHash 'StakePool c2) (IndividualPoolStake c2))
-> Map (KeyHash 'StakePool c1) (IndividualPoolStake c1)
-> PoolDistr c2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyHash 'StakePool c1 -> KeyHash 'StakePool c2)
-> Map (KeyHash 'StakePool c1) (IndividualPoolStake c2)
-> Map (KeyHash 'StakePool c2) (IndividualPoolStake c2)
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic KeyHash 'StakePool c1 -> KeyHash 'StakePool c2
coerce
              (Map (KeyHash 'StakePool c1) (IndividualPoolStake c2)
 -> Map (KeyHash 'StakePool c2) (IndividualPoolStake c2))
-> (Map (KeyHash 'StakePool c1) (IndividualPoolStake c1)
    -> Map (KeyHash 'StakePool c1) (IndividualPoolStake c2))
-> Map (KeyHash 'StakePool c1) (IndividualPoolStake c1)
-> Map (KeyHash 'StakePool c2) (IndividualPoolStake c2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndividualPoolStake c1 -> IndividualPoolStake c2)
-> Map (KeyHash 'StakePool c1) (IndividualPoolStake c1)
-> Map (KeyHash 'StakePool c1) (IndividualPoolStake c2)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map IndividualPoolStake c1 -> IndividualPoolStake c2
coerceIndividualPoolStake
              (Map (KeyHash 'StakePool c1) (IndividualPoolStake c1)
 -> PoolDistr c2)
-> Map (KeyHash 'StakePool c1) (IndividualPoolStake c1)
-> PoolDistr c2
forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'StakePool c1) (IndividualPoolStake c1)
m
          coerceIndividualPoolStake :: SL.IndividualPoolStake c1 -> SL.IndividualPoolStake c2
          coerceIndividualPoolStake :: IndividualPoolStake c1 -> IndividualPoolStake c2
coerceIndividualPoolStake (SL.IndividualPoolStake Rational
stake Hash c1 (VerKeyVRF c1)
vrf) =
            Rational -> Hash c2 (VerKeyVRF c2) -> IndividualPoolStake c2
forall crypto.
Rational
-> Hash crypto (VerKeyVRF crypto) -> IndividualPoolStake crypto
SL.IndividualPoolStake Rational
stake (Hash c2 (VerKeyVRF c2) -> IndividualPoolStake c2)
-> Hash c2 (VerKeyVRF c2) -> IndividualPoolStake c2
forall a b. (a -> b) -> a -> b
$ Hash (HASH c1) (VerKeyVRF c2) -> Hash (HASH c1) (VerKeyVRF c2)
coerce Hash c1 (VerKeyVRF c1)
Hash (HASH c1) (VerKeyVRF c2)
vrf

  translateChainDepState :: ChainDepState (TPraos c1) -> ChainDepState (Praos c2)
translateChainDepState ChainDepState (TPraos c1)
tpState =
    PraosState :: forall c.
WithOrigin SlotNo
-> Map (KeyHash 'BlockIssuer c) Word64
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> PraosState c
PraosState
      { praosStateLastSlot :: WithOrigin SlotNo
praosStateLastSlot = TPraosState c2 -> WithOrigin SlotNo
forall c. TPraosState c -> WithOrigin SlotNo
tpraosStateLastSlot ChainDepState (TPraos c1)
TPraosState c2
tpState,
        praosStateOCertCounters :: Map (KeyHash 'BlockIssuer c2) Word64
praosStateOCertCounters = (KeyHash 'BlockIssuer c2 -> KeyHash 'BlockIssuer c2)
-> Map (KeyHash 'BlockIssuer c2) Word64
-> Map (KeyHash 'BlockIssuer c2) Word64
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic KeyHash 'BlockIssuer c2 -> KeyHash 'BlockIssuer c2
coerce Map (KeyHash 'BlockIssuer c2) Word64
certCounters,
        praosStateEvolvingNonce :: Nonce
praosStateEvolvingNonce = Nonce
evolvingNonce,
        praosStateCandidateNonce :: Nonce
praosStateCandidateNonce = Nonce
candidateNonce,
        praosStateEpochNonce :: Nonce
praosStateEpochNonce = TicknState -> Nonce
SL.ticknStateEpochNonce TicknState
csTickn,
        praosStateLabNonce :: Nonce
praosStateLabNonce = Nonce
csLabNonce,
        praosStateLastEpochBlockNonce :: Nonce
praosStateLastEpochBlockNonce = TicknState -> Nonce
SL.ticknStatePrevHashNonce TicknState
csTickn
      }
    where
      SL.ChainDepState {PrtclState c2
csProtocol :: forall crypto. ChainDepState crypto -> PrtclState crypto
csProtocol :: PrtclState c2
SL.csProtocol, TicknState
csTickn :: forall crypto. ChainDepState crypto -> TicknState
csTickn :: TicknState
SL.csTickn, Nonce
csLabNonce :: forall crypto. ChainDepState crypto -> Nonce
csLabNonce :: Nonce
SL.csLabNonce} =
        TPraosState c2 -> ChainDepState c2
forall c. TPraosState c -> ChainDepState c
tpraosStateChainDepState ChainDepState (TPraos c1)
TPraosState c2
tpState
      SL.PrtclState Map (KeyHash 'BlockIssuer c2) Word64
certCounters Nonce
evolvingNonce Nonce
candidateNonce =
        PrtclState c2
csProtocol