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

module Cardano.Ledger.Shelley.API.ByronTranslation (
  translateToShelleyLedgerState,
  translateToShelleyLedgerStateFromUtxo,

  -- * 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 Cardano.Ledger.Address (fromBoostrapCompactAddress, isBootstrapRedeemer)
import Cardano.Ledger.BaseTypes (BlocksMade (..), EpochNo, TxIx (..))
import Cardano.Ledger.Coin (CompactForm (CompactCoin))
import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API.Types
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState.Types (curPParamsEpochStateL, prevPParamsEpochStateL)
import Cardano.Ledger.Shelley.Rules ()
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.Translation (FromByronTranslationContext (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val (zero, (<->))
import qualified Data.ByteString.Short as SBS
import Data.Default (def)
import qualified Data.Map.Strict as Map
import GHC.Stack (HasCallStack)
import Lens.Micro ((&), (.~), (^.))
import Lens.Micro.Extras (view)

-- | 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 ::
  Byron.TxId ->
  TxId
translateTxIdByronToShelley :: TxId -> TxId
translateTxIdByronToShelley =
  SafeHash EraIndependentTxBody -> TxId
TxId (SafeHash EraIndependentTxBody -> TxId)
-> (TxId -> SafeHash EraIndependentTxBody) -> TxId -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash HASH EraIndependentTxBody -> SafeHash EraIndependentTxBody
forall i. Hash HASH i -> SafeHash i
unsafeMakeSafeHash (Hash HASH EraIndependentTxBody -> SafeHash EraIndependentTxBody)
-> (TxId -> Hash HASH EraIndependentTxBody)
-> TxId
-> SafeHash EraIndependentTxBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> Hash HASH EraIndependentTxBody
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
hashFromShortBytesE (ShortByteString -> Hash HASH EraIndependentTxBody)
-> (TxId -> ShortByteString)
-> TxId
-> Hash HASH 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 :: forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
hashFromShortBytesE ShortByteString
sbs =
  case ShortByteString -> Maybe (Hash h a)
forall h a. HashAlgorithm h => ShortByteString -> Maybe (Hash h a)
Crypto.hashFromBytesShort ShortByteString
sbs of
    Just !Hash h a
h -> Hash h a
h
    Maybe (Hash h a)
Nothing ->
      [Char] -> Hash h a
forall a. HasCallStack => [Char] -> a
error ([Char] -> Hash h a) -> [Char] -> Hash h a
forall a b. (a -> b) -> a -> b
$ [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 -> ShelleyTxOut ShelleyEra
translateCompactTxOutByronToShelley :: CompactTxOut -> ShelleyTxOut ShelleyEra
translateCompactTxOutByronToShelley (Byron.CompactTxOut CompactAddress
compactAddr Lovelace
amount) =
  CompactAddr
-> CompactForm (Value ShelleyEra) -> ShelleyTxOut ShelleyEra
forall era.
CompactAddr -> CompactForm (Value era) -> ShelleyTxOut era
TxOutCompact
    (CompactAddress -> CompactAddr
fromBoostrapCompactAddress CompactAddress
compactAddr)
    (Word64 -> CompactForm Coin
CompactCoin (Lovelace -> Word64
Byron.unsafeGetLovelace Lovelace
amount))

translateCompactTxInByronToShelley ::
  Byron.CompactTxIn ->
  TxIn
translateCompactTxInByronToShelley :: CompactTxIn -> TxIn
translateCompactTxInByronToShelley (Byron.CompactTxInUtxo CompactTxId
compactTxId Word16
idx) =
  TxId -> TxIx -> TxIn
TxIn
    (TxId -> TxId
translateTxIdByronToShelley (CompactTxId -> TxId
Byron.fromCompactTxId CompactTxId
compactTxId))
    (Word16 -> TxIx
TxIx Word16
idx)

translateUTxOByronToShelley ::
  Byron.UTxO ->
  UTxO ShelleyEra
translateUTxOByronToShelley :: UTxO -> UTxO ShelleyEra
translateUTxOByronToShelley (Byron.UTxO Map CompactTxIn CompactTxOut
utxoByron) =
  Map TxIn (TxOut ShelleyEra) -> UTxO ShelleyEra
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut ShelleyEra) -> UTxO ShelleyEra)
-> Map TxIn (TxOut ShelleyEra) -> UTxO ShelleyEra
forall a b. (a -> b) -> a -> b
$
    [(TxIn, ShelleyTxOut ShelleyEra)]
-> Map TxIn (ShelleyTxOut ShelleyEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TxIn
txInShelley, ShelleyTxOut ShelleyEra
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
txInShelley = CompactTxIn -> TxIn
translateCompactTxInByronToShelley CompactTxIn
txInByron
            txOutShelley :: ShelleyTxOut ShelleyEra
txOutShelley = CompactTxOut -> ShelleyTxOut ShelleyEra
translateCompactTxOutByronToShelley CompactTxOut
txOutByron
      , -- In some testnets there are a few TxOuts with zero values injected at
      -- initialization of Byron. We do not allow zero values in TxOuts in Shelley
      -- onwards.
      ShelleyTxOut ShelleyEra
txOutShelley ShelleyTxOut ShelleyEra
-> Getting Coin (ShelleyTxOut ShelleyEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (Coin -> Const Coin Coin)
-> TxOut ShelleyEra -> Const Coin (TxOut ShelleyEra)
Getting Coin (ShelleyTxOut ShelleyEra) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ShelleyEra) Coin
coinTxOutL Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= Coin
forall t. Val t => t
zero
      ]

translateToShelleyLedgerState ::
  FromByronTranslationContext ->
  EpochNo ->
  Byron.ChainValidationState ->
  NewEpochState ShelleyEra
translateToShelleyLedgerState :: FromByronTranslationContext
-> EpochNo -> ChainValidationState -> NewEpochState ShelleyEra
translateToShelleyLedgerState FromByronTranslationContext
transContext EpochNo
epochNo ChainValidationState
cvs =
  FromByronTranslationContext
-> EpochNo -> UTxO -> NewEpochState ShelleyEra
translateToShelleyLedgerStateFromUtxo FromByronTranslationContext
transContext EpochNo
epochNo (ChainValidationState -> UTxO
Byron.cvsUtxo ChainValidationState
cvs)

translateToShelleyLedgerStateFromUtxo ::
  FromByronTranslationContext ->
  EpochNo ->
  Byron.UTxO ->
  NewEpochState ShelleyEra
translateToShelleyLedgerStateFromUtxo :: FromByronTranslationContext
-> EpochNo -> UTxO -> NewEpochState ShelleyEra
translateToShelleyLedgerStateFromUtxo FromByronTranslationContext
transCtxt EpochNo
epochNo UTxO
utxoByron =
  NewEpochState
    { nesEL :: EpochNo
nesEL = EpochNo
epochNo
    , nesBprev :: BlocksMade
nesBprev = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade Map (KeyHash 'StakePool) Natural
forall k a. Map k a
Map.empty
    , nesBcur :: BlocksMade
nesBcur = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade Map (KeyHash 'StakePool) Natural
forall k a. Map k a
Map.empty
    , nesEs :: EpochState ShelleyEra
nesEs = EpochState ShelleyEra
epochState
    , nesRu :: StrictMaybe PulsingRewUpdate
nesRu = StrictMaybe PulsingRewUpdate
forall a. StrictMaybe a
SNothing
    , nesPd :: PoolDistr
nesPd = Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr Map (KeyHash 'StakePool) IndividualPoolStake
forall k a. Map k a
Map.empty CompactForm Coin
forall a. Monoid a => a
mempty
    , -- At this point, we compute the stashed AVVM addresses, while we are able
      -- to do a linear scan of the UTxO, and stash them away for use at the
      -- Shelley/Allegra boundary.
      stashedAVVMAddresses :: StashedAVVMAddresses ShelleyEra
stashedAVVMAddresses =
        let UTxO Map TxIn (TxOut ShelleyEra)
utxo = UTxOState ShelleyEra -> UTxO ShelleyEra
forall era. UTxOState era -> UTxO era
utxosUtxo (UTxOState ShelleyEra -> UTxO ShelleyEra)
-> (EpochState ShelleyEra -> UTxOState ShelleyEra)
-> EpochState ShelleyEra
-> UTxO ShelleyEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState ShelleyEra -> UTxOState ShelleyEra
forall era. LedgerState era -> UTxOState era
lsUTxOState (LedgerState ShelleyEra -> UTxOState ShelleyEra)
-> (EpochState ShelleyEra -> LedgerState ShelleyEra)
-> EpochState ShelleyEra
-> UTxOState ShelleyEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState ShelleyEra -> LedgerState ShelleyEra
forall era. EpochState era -> LedgerState era
esLState (EpochState ShelleyEra -> UTxO ShelleyEra)
-> EpochState ShelleyEra -> UTxO ShelleyEra
forall a b. (a -> b) -> a -> b
$ EpochState ShelleyEra
epochState
            redeemers :: Map TxIn (ShelleyTxOut ShelleyEra)
redeemers =
              (ShelleyTxOut ShelleyEra -> Bool)
-> Map TxIn (ShelleyTxOut ShelleyEra)
-> Map TxIn (ShelleyTxOut ShelleyEra)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool
-> (BootstrapAddress -> Bool) -> Maybe BootstrapAddress -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False BootstrapAddress -> Bool
isBootstrapRedeemer (Maybe BootstrapAddress -> Bool)
-> (ShelleyTxOut ShelleyEra -> Maybe BootstrapAddress)
-> ShelleyTxOut ShelleyEra
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Maybe BootstrapAddress)
  (ShelleyTxOut ShelleyEra)
  (Maybe BootstrapAddress)
-> ShelleyTxOut ShelleyEra -> Maybe BootstrapAddress
forall a s. Getting a s a -> s -> a
view Getting
  (Maybe BootstrapAddress)
  (TxOut ShelleyEra)
  (Maybe BootstrapAddress)
Getting
  (Maybe BootstrapAddress)
  (ShelleyTxOut ShelleyEra)
  (Maybe BootstrapAddress)
forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
SimpleGetter (TxOut ShelleyEra) (Maybe BootstrapAddress)
bootAddrTxOutF) Map TxIn (ShelleyTxOut ShelleyEra)
utxo
         in Map TxIn (TxOut ShelleyEra) -> UTxO ShelleyEra
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut ShelleyEra)
Map TxIn (ShelleyTxOut ShelleyEra)
redeemers
    }
  where
    pparams :: PParams ShelleyEra
    pparams :: PParams ShelleyEra
pparams = FromByronTranslationContext -> PParams ShelleyEra
fbtcProtocolParams FromByronTranslationContext
transCtxt

    -- 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
    genDelegs :: GenDelegs
genDelegs = Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs (Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs)
-> Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
forall a b. (a -> b) -> a -> b
$ FromByronTranslationContext -> Map (KeyHash 'Genesis) GenDelegPair
fbtcGenDelegs FromByronTranslationContext
transCtxt

    reserves :: Coin
    reserves :: Coin
reserves =
      Word64 -> Coin
word64ToCoin (FromByronTranslationContext -> Word64
fbtcMaxLovelaceSupply FromByronTranslationContext
transCtxt) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> UTxO ShelleyEra -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO UTxO ShelleyEra
utxoShelley

    epochState :: EpochState ShelleyEra
    epochState :: EpochState ShelleyEra
epochState =
      EpochState
        { esChainAccountState :: ChainAccountState
esChainAccountState =
            ChainAccountState
              { casTreasury :: Coin
casTreasury = Integer -> Coin
Coin Integer
0
              , casReserves :: Coin
casReserves = Coin
reserves
              }
        , esSnapshots :: SnapShots
esSnapshots = SnapShots
emptySnapShots
        , esLState :: LedgerState ShelleyEra
esLState = LedgerState ShelleyEra
ledgerState
        , esNonMyopic :: NonMyopic
esNonMyopic = NonMyopic
forall a. Default a => a
def
        }
        EpochState ShelleyEra
-> (EpochState ShelleyEra -> EpochState ShelleyEra)
-> EpochState ShelleyEra
forall a b. a -> (a -> b) -> b
& (PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> EpochState ShelleyEra -> Identity (EpochState ShelleyEra)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState ShelleyEra) (PParams ShelleyEra)
prevPParamsEpochStateL ((PParams ShelleyEra -> Identity (PParams ShelleyEra))
 -> EpochState ShelleyEra -> Identity (EpochState ShelleyEra))
-> PParams ShelleyEra
-> EpochState ShelleyEra
-> EpochState ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams ShelleyEra
pparams
        EpochState ShelleyEra
-> (EpochState ShelleyEra -> EpochState ShelleyEra)
-> EpochState ShelleyEra
forall a b. a -> (a -> b) -> b
& (PParams ShelleyEra -> Identity (PParams ShelleyEra))
-> EpochState ShelleyEra -> Identity (EpochState ShelleyEra)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState ShelleyEra) (PParams ShelleyEra)
curPParamsEpochStateL ((PParams ShelleyEra -> Identity (PParams ShelleyEra))
 -> EpochState ShelleyEra -> Identity (EpochState ShelleyEra))
-> PParams ShelleyEra
-> EpochState ShelleyEra
-> EpochState ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams ShelleyEra
pparams

    utxoShelley :: UTxO ShelleyEra
    utxoShelley :: UTxO ShelleyEra
utxoShelley = UTxO -> UTxO ShelleyEra
translateUTxOByronToShelley UTxO
utxoByron

    ledgerState :: LedgerState ShelleyEra
    ledgerState :: LedgerState ShelleyEra
ledgerState =
      LedgerState
        { lsUTxOState :: UTxOState ShelleyEra
lsUTxOState =
            UTxOState
              { utxosUtxo :: UTxO ShelleyEra
utxosUtxo = UTxO ShelleyEra
utxoShelley
              , utxosDeposited :: Coin
utxosDeposited = Integer -> Coin
Coin Integer
0
              , utxosFees :: Coin
utxosFees = Integer -> Coin
Coin Integer
0
              , utxosGovState :: GovState ShelleyEra
utxosGovState = GovState ShelleyEra
forall era. EraGov era => GovState era
emptyGovState
              , utxosInstantStake :: InstantStake ShelleyEra
utxosInstantStake = InstantStake ShelleyEra
ShelleyInstantStake ShelleyEra
forall a. Monoid a => a
mempty
              , utxosDonation :: Coin
utxosDonation = Coin
forall a. Monoid a => a
mempty
              }
        , lsCertState :: CertState ShelleyEra
lsCertState = PState ShelleyEra -> DState ShelleyEra -> CertState ShelleyEra
forall era.
EraCertState era =>
PState era -> DState era -> CertState era
mkShelleyCertState PState ShelleyEra
forall a. Default a => a
def DState ShelleyEra
dState
        }

    dState :: DState ShelleyEra
    dState :: DState ShelleyEra
dState =
      DState
        { dsUnified :: UMap
dsUnified = UMap
UM.empty
        , dsFutureGenDelegs :: Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs = Map FutureGenDeleg GenDelegPair
forall k a. Map k a
Map.empty
        , dsGenDelegs :: GenDelegs
dsGenDelegs = GenDelegs
genDelegs
        , dsIRewards :: InstantaneousRewards
dsIRewards = InstantaneousRewards
forall a. Default a => a
def
        }