{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Shelley.Spec.Ledger.API.ByronTranslation
  ( mkInitialShelleyLedgerView,
    translateToShelleyLedgerState,

    -- * Exported for testing purposes
    translateCompactTxOutByronToShelley,
    translateTxIdByronToShelley,
  )
where

import qualified Cardano.Chain.Block as Byron
import qualified Cardano.Chain.Common as Byron
import qualified Cardano.Chain.UTxO as Byron
import qualified Cardano.Crypto.Hash as Crypto
import qualified Cardano.Crypto.Hashing as Hashing
import qualified Cardano.Ledger.Crypto as CC
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Val ((<->))
import qualified Data.ByteString.Short as SBS
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import GHC.Stack (HasCallStack)
import Shelley.Spec.Ledger.API.Protocol
import Shelley.Spec.Ledger.API.Types
import Shelley.Spec.Ledger.Coin (CompactForm (CompactCoin))
import Shelley.Spec.Ledger.CompactAddr (CompactAddr (UnsafeCompactAddr))
import Shelley.Spec.Ledger.EpochBoundary
import Shelley.Spec.Ledger.LedgerState
import Shelley.Spec.Ledger.Rewards
import Shelley.Spec.Ledger.STS.Chain (pparamsToChainChecksData)
import Shelley.Spec.Ledger.Slot

-- | We use the same hashing algorithm so we can unwrap and rewrap the bytes.
-- We don't care about the type that is hashed, which will differ going from
-- Byron to Shelley, we just use the hashes as IDs.
translateTxIdByronToShelley ::
  (CC.Crypto c, CC.ADDRHASH c ~ Crypto.Blake2b_224) =>
  Byron.TxId ->
  TxId (ShelleyEra c)
translateTxIdByronToShelley :: TxId -> TxId (ShelleyEra c)
translateTxIdByronToShelley =
  Hash (HASH c) EraIndependentTxBody -> TxId (ShelleyEra c)
forall era. Hash (Crypto era) EraIndependentTxBody -> TxId era
TxId (Hash (HASH c) EraIndependentTxBody -> TxId (ShelleyEra c))
-> (TxId -> Hash (HASH c) EraIndependentTxBody)
-> TxId
-> TxId (ShelleyEra c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> Hash (HASH c) EraIndependentTxBody
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
hashFromShortBytesE (ShortByteString -> Hash (HASH c) EraIndependentTxBody)
-> (TxId -> ShortByteString)
-> TxId
-> Hash (HASH c) EraIndependentTxBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId -> ShortByteString
forall algo a. AbstractHash algo a -> ShortByteString
Hashing.abstractHashToShort

hashFromShortBytesE ::
  forall h a.
  (Crypto.HashAlgorithm h, HasCallStack) =>
  SBS.ShortByteString ->
  Crypto.Hash h a
hashFromShortBytesE :: ShortByteString -> Hash h a
hashFromShortBytesE ShortByteString
sbs = Hash h a -> Maybe (Hash h a) -> Hash h a
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Hash h a
forall a. HasCallStack => [Char] -> a
error [Char]
msg) (Maybe (Hash h a) -> Hash h a) -> Maybe (Hash h a) -> Hash h a
forall a b. (a -> b) -> a -> b
$ ShortByteString -> Maybe (Hash h a)
forall h a. HashAlgorithm h => ShortByteString -> Maybe (Hash h a)
Crypto.hashFromBytesShort ShortByteString
sbs
  where
    msg :: [Char]
msg =
      [Char]
"hashFromBytesShort called with ShortByteString of the wrong length: "
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> [Char]
forall a. Show a => a -> [Char]
show ShortByteString
sbs

translateCompactTxOutByronToShelley :: Byron.CompactTxOut -> TxOut (ShelleyEra c)
translateCompactTxOutByronToShelley :: CompactTxOut -> TxOut (ShelleyEra c)
translateCompactTxOutByronToShelley (Byron.CompactTxOut CompactAddress
compactAddr Lovelace
amount) =
  CompactAddr (ShelleyEra c)
-> CompactForm (Value (ShelleyEra c)) -> TxOut (ShelleyEra c)
forall era. CompactAddr era -> CompactForm (Value era) -> TxOut era
TxOutCompact
    (ShortByteString -> CompactAddr (ShelleyEra c)
forall era. ShortByteString -> CompactAddr era
UnsafeCompactAddr (CompactAddress -> ShortByteString
Byron.unsafeGetCompactAddress CompactAddress
compactAddr))
    (Word64 -> CompactForm Coin
CompactCoin (Lovelace -> Word64
Byron.unsafeGetLovelace Lovelace
amount))

translateCompactTxInByronToShelley ::
  (CC.Crypto c, CC.ADDRHASH c ~ Crypto.Blake2b_224) =>
  Byron.CompactTxIn ->
  TxIn (ShelleyEra c)
translateCompactTxInByronToShelley :: CompactTxIn -> TxIn (ShelleyEra c)
translateCompactTxInByronToShelley (Byron.CompactTxInUtxo CompactTxId
compactTxId Word32
idx) =
  TxId (ShelleyEra c) -> Word64 -> TxIn (ShelleyEra c)
forall era. TxId era -> Word64 -> TxIn era
TxInCompact
    (TxId -> TxId (ShelleyEra c)
forall c.
(Crypto c, ADDRHASH c ~ Blake2b_224) =>
TxId -> TxId (ShelleyEra c)
translateTxIdByronToShelley (CompactTxId -> TxId
Byron.fromCompactTxId CompactTxId
compactTxId))
    (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
idx)

translateUTxOByronToShelley ::
  forall c.
  (CC.Crypto c, CC.ADDRHASH c ~ Crypto.Blake2b_224) =>
  Byron.UTxO ->
  UTxO (ShelleyEra c)
translateUTxOByronToShelley :: UTxO -> UTxO (ShelleyEra c)
translateUTxOByronToShelley (Byron.UTxO Map CompactTxIn CompactTxOut
utxoByron) =
  Map (TxIn (ShelleyEra c)) (TxOut (ShelleyEra c))
-> UTxO (ShelleyEra c)
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO (Map (TxIn (ShelleyEra c)) (TxOut (ShelleyEra c))
 -> UTxO (ShelleyEra c))
-> Map (TxIn (ShelleyEra c)) (TxOut (ShelleyEra c))
-> UTxO (ShelleyEra c)
forall a b. (a -> b) -> a -> b
$
    [(TxIn (ShelleyEra c), TxOut (ShelleyEra c))]
-> Map (TxIn (ShelleyEra c)) (TxOut (ShelleyEra c))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TxIn (ShelleyEra c)
txInShelley, TxOut (ShelleyEra c)
txOutShelley)
        | (CompactTxIn
txInByron, CompactTxOut
txOutByron) <- Map CompactTxIn CompactTxOut -> [(CompactTxIn, CompactTxOut)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CompactTxIn CompactTxOut
utxoByron,
          let txInShelley :: TxIn (ShelleyEra c)
txInShelley = CompactTxIn -> TxIn (ShelleyEra c)
forall c.
(Crypto c, ADDRHASH c ~ Blake2b_224) =>
CompactTxIn -> TxIn (ShelleyEra c)
translateCompactTxInByronToShelley CompactTxIn
txInByron
              txOutShelley :: TxOut (ShelleyEra c)
txOutShelley = CompactTxOut -> TxOut (ShelleyEra c)
forall c. CompactTxOut -> TxOut (ShelleyEra c)
translateCompactTxOutByronToShelley CompactTxOut
txOutByron
      ]

translateToShelleyLedgerState ::
  forall c.
  (CC.Crypto c, CC.ADDRHASH c ~ Crypto.Blake2b_224) =>
  ShelleyGenesis (ShelleyEra c) ->
  EpochNo ->
  Byron.ChainValidationState ->
  NewEpochState (ShelleyEra c)
translateToShelleyLedgerState :: ShelleyGenesis (ShelleyEra c)
-> EpochNo -> ChainValidationState -> NewEpochState (ShelleyEra c)
translateToShelleyLedgerState ShelleyGenesis (ShelleyEra c)
genesisShelley EpochNo
epochNo ChainValidationState
cvs =
  NewEpochState :: forall era.
EpochNo
-> BlocksMade era
-> BlocksMade era
-> EpochState era
-> StrictMaybe (RewardUpdate era)
-> PoolDistr (Crypto era)
-> NewEpochState era
NewEpochState
    { nesEL :: EpochNo
nesEL = EpochNo
epochNo,
      nesBprev :: BlocksMade (ShelleyEra c)
nesBprev = Map (KeyHash 'StakePool (Crypto (ShelleyEra c))) Natural
-> BlocksMade (ShelleyEra c)
forall era.
Map (KeyHash 'StakePool (Crypto era)) Natural -> BlocksMade era
BlocksMade Map (KeyHash 'StakePool (Crypto (ShelleyEra c))) Natural
forall k a. Map k a
Map.empty,
      nesBcur :: BlocksMade (ShelleyEra c)
nesBcur = Map (KeyHash 'StakePool (Crypto (ShelleyEra c))) Natural
-> BlocksMade (ShelleyEra c)
forall era.
Map (KeyHash 'StakePool (Crypto era)) Natural -> BlocksMade era
BlocksMade Map (KeyHash 'StakePool (Crypto (ShelleyEra c))) Natural
forall k a. Map k a
Map.empty,
      nesEs :: EpochState (ShelleyEra c)
nesEs = EpochState (ShelleyEra c)
epochState,
      nesRu :: StrictMaybe (RewardUpdate (ShelleyEra c))
nesRu = StrictMaybe (RewardUpdate (ShelleyEra c))
forall a. StrictMaybe a
SNothing,
      nesPd :: PoolDistr (Crypto (ShelleyEra c))
nesPd = Map (KeyHash 'StakePool c) (IndividualPoolStake c) -> PoolDistr c
forall crypto.
Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
-> PoolDistr crypto
PoolDistr Map (KeyHash 'StakePool c) (IndividualPoolStake c)
forall k a. Map k a
Map.empty
    }
  where
    pparams :: PParams (ShelleyEra c)
    pparams :: PParams (ShelleyEra c)
pparams = ShelleyGenesis (ShelleyEra c) -> PParams (ShelleyEra c)
forall era. ShelleyGenesis era -> PParams era
sgProtocolParams ShelleyGenesis (ShelleyEra c)
genesisShelley

    -- NOTE: we ignore the Byron delegation map because the genesis and
    -- delegation verification keys are hashed using a different hashing
    -- scheme. This means we can't simply convert them, as Byron nowhere stores
    -- the original verification keys.
    --
    -- Fortunately, no Byron genesis delegations have happened yet, and if
    -- they did, we would be aware of them before the hard fork, as we
    -- instigate the hard fork. We just have to make sure that the hard-coded
    -- Shelley genesis contains the same genesis and delegation verification
    -- keys, but hashed with the right algorithm.
    genDelegs :: GenDelegs c
    genDelegs :: GenDelegs c
genDelegs = Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
forall crypto.
Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
GenDelegs (Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c)
-> Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra c)
-> Map
     (KeyHash 'Genesis (Crypto (ShelleyEra c)))
     (GenDelegPair (Crypto (ShelleyEra c)))
forall era.
ShelleyGenesis era
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
sgGenDelegs ShelleyGenesis (ShelleyEra c)
genesisShelley

    reserves :: Coin
    reserves :: Coin
reserves =
      Word64 -> Coin
word64ToCoin (ShelleyGenesis (ShelleyEra c) -> Word64
forall era. ShelleyGenesis era -> Word64
sgMaxLovelaceSupply ShelleyGenesis (ShelleyEra c)
genesisShelley) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> UTxO (ShelleyEra c) -> Value (ShelleyEra c)
forall era. ShelleyBased era => UTxO era -> Value era
balance UTxO (ShelleyEra c)
utxoShelley

    epochState :: EpochState (ShelleyEra c)
    epochState :: EpochState (ShelleyEra c)
epochState =
      EpochState :: forall era.
AccountState
-> SnapShots era
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic era
-> EpochState era
EpochState
        { esAccountState :: AccountState
esAccountState = Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) Coin
reserves,
          esSnapshots :: SnapShots (ShelleyEra c)
esSnapshots = SnapShots (ShelleyEra c)
forall era. SnapShots era
emptySnapShots,
          esLState :: LedgerState (ShelleyEra c)
esLState = LedgerState (ShelleyEra c)
ledgerState,
          esPrevPp :: PParams (ShelleyEra c)
esPrevPp = PParams (ShelleyEra c)
pparams,
          esPp :: PParams (ShelleyEra c)
esPp = PParams (ShelleyEra c)
pparams,
          esNonMyopic :: NonMyopic (ShelleyEra c)
esNonMyopic = NonMyopic (ShelleyEra c)
forall era. NonMyopic era
emptyNonMyopic
        }

    utxoByron :: Byron.UTxO
    utxoByron :: UTxO
utxoByron = ChainValidationState -> UTxO
Byron.cvsUtxo ChainValidationState
cvs

    utxoShelley :: UTxO (ShelleyEra c)
    utxoShelley :: UTxO (ShelleyEra c)
utxoShelley = UTxO -> UTxO (ShelleyEra c)
forall c.
(Crypto c, ADDRHASH c ~ Blake2b_224) =>
UTxO -> UTxO (ShelleyEra c)
translateUTxOByronToShelley UTxO
utxoByron

    ledgerState :: LedgerState (ShelleyEra c)
    ledgerState :: LedgerState (ShelleyEra c)
ledgerState =
      LedgerState :: forall era. UTxOState era -> DPState era -> LedgerState era
LedgerState
        { _utxoState :: UTxOState (ShelleyEra c)
_utxoState =
            UTxOState :: forall era.
UTxO era -> Coin -> Coin -> PPUPState era -> UTxOState era
UTxOState
              { _utxo :: UTxO (ShelleyEra c)
_utxo = UTxO (ShelleyEra c)
utxoShelley,
                _deposited :: Coin
_deposited = Integer -> Coin
Coin Integer
0,
                _fees :: Coin
_fees = Integer -> Coin
Coin Integer
0,
                _ppups :: PPUPState (ShelleyEra c)
_ppups = PPUPState (ShelleyEra c)
forall era. PPUPState era
emptyPPUPState
              },
          _delegationState :: DPState (ShelleyEra c)
_delegationState =
            DPState :: forall era. DState era -> PState era -> DPState era
DPState
              { _dstate :: DState (ShelleyEra c)
_dstate = DState (ShelleyEra c)
forall era. DState era
emptyDState {_genDelegs :: GenDelegs (Crypto (ShelleyEra c))
_genDelegs = GenDelegs c
GenDelegs (Crypto (ShelleyEra c))
genDelegs},
                _pstate :: PState (ShelleyEra c)
_pstate = PState (ShelleyEra c)
forall era. PState era
emptyPState
              }
        }

-- | We construct a 'LedgerView' using the Shelley genesis config in the same
-- way as 'translateToShelleyLedgerState'.
mkInitialShelleyLedgerView ::
  forall c.
  ShelleyGenesis (ShelleyEra c) ->
  LedgerView c
mkInitialShelleyLedgerView :: ShelleyGenesis (ShelleyEra c) -> LedgerView c
mkInitialShelleyLedgerView ShelleyGenesis (ShelleyEra c)
genesisShelley =
  LedgerView :: forall crypto.
UnitInterval
-> Nonce
-> PoolDistr crypto
-> GenDelegs crypto
-> ChainChecksData
-> LedgerView crypto
LedgerView
    { lvD :: UnitInterval
lvD = PParams' Identity (ShelleyEra c) -> UnitInterval
forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval
_d (PParams' Identity (ShelleyEra c) -> UnitInterval)
-> (ShelleyGenesis (ShelleyEra c)
    -> PParams' Identity (ShelleyEra c))
-> ShelleyGenesis (ShelleyEra c)
-> UnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis (ShelleyEra c) -> PParams' Identity (ShelleyEra c)
forall era. ShelleyGenesis era -> PParams era
sgProtocolParams (ShelleyGenesis (ShelleyEra c) -> UnitInterval)
-> ShelleyGenesis (ShelleyEra c) -> UnitInterval
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra c)
genesisShelley,
      lvExtraEntropy :: Nonce
lvExtraEntropy = PParams' Identity (ShelleyEra c) -> Nonce
forall (f :: * -> *) era. PParams' f era -> HKD f Nonce
_extraEntropy (PParams' Identity (ShelleyEra c) -> Nonce)
-> (ShelleyGenesis (ShelleyEra c)
    -> PParams' Identity (ShelleyEra c))
-> ShelleyGenesis (ShelleyEra c)
-> Nonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis (ShelleyEra c) -> PParams' Identity (ShelleyEra c)
forall era. ShelleyGenesis era -> PParams era
sgProtocolParams (ShelleyGenesis (ShelleyEra c) -> Nonce)
-> ShelleyGenesis (ShelleyEra c) -> Nonce
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra c)
genesisShelley,
      lvPoolDistr :: PoolDistr c
lvPoolDistr = Map (KeyHash 'StakePool c) (IndividualPoolStake c) -> PoolDistr c
forall crypto.
Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
-> PoolDistr crypto
PoolDistr Map (KeyHash 'StakePool c) (IndividualPoolStake c)
forall k a. Map k a
Map.empty,
      lvGenDelegs :: GenDelegs c
lvGenDelegs = Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
forall crypto.
Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
GenDelegs (Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c)
-> Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra c)
-> Map
     (KeyHash 'Genesis (Crypto (ShelleyEra c)))
     (GenDelegPair (Crypto (ShelleyEra c)))
forall era.
ShelleyGenesis era
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
sgGenDelegs ShelleyGenesis (ShelleyEra c)
genesisShelley,
      lvChainChecks :: ChainChecksData
lvChainChecks = PParams' Identity (ShelleyEra c) -> ChainChecksData
forall era. PParams era -> ChainChecksData
pparamsToChainChecksData (PParams' Identity (ShelleyEra c) -> ChainChecksData)
-> (ShelleyGenesis (ShelleyEra c)
    -> PParams' Identity (ShelleyEra c))
-> ShelleyGenesis (ShelleyEra c)
-> ChainChecksData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis (ShelleyEra c) -> PParams' Identity (ShelleyEra c)
forall era. ShelleyGenesis era -> PParams era
sgProtocolParams (ShelleyGenesis (ShelleyEra c) -> ChainChecksData)
-> ShelleyGenesis (ShelleyEra c) -> ChainChecksData
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra c)
genesisShelley
    }