{-# 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.EpochBoundary (emptySnapShots)
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.Translation (FromByronTranslationContext (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (coinBalance)
import Cardano.Ledger.Val (zero, (<->))
import qualified Data.ByteString.Short as SBS
import Data.Default (def)
import qualified Data.Map.Strict as Map
import Data.Word
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Hash HASH i -> SafeHash i
unsafeMakeSafeHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
hashFromShortBytesE forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 ->
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"hashFromBytesShort called with ShortByteString of the wrong length: " forall a. Semigroup a => a -> a -> a
<> 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) =
  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))
    (Word64 -> TxIx
TxIx ((forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word16 -> Word64) Word16
idx))

translateUTxOByronToShelley ::
  Byron.UTxO ->
  UTxO ShelleyEra
translateUTxOByronToShelley :: UTxO -> UTxO ShelleyEra
translateUTxOByronToShelley (Byron.UTxO Map CompactTxIn CompactTxOut
utxoByron) =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TxIn
txInShelley, ShelleyTxOut ShelleyEra
txOutShelley)
      | (CompactTxIn
txInByron, CompactTxOut
txOutByron) <- 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 forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall a. Eq a => a -> a -> Bool
/= 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 forall k a. Map k a
Map.empty
    , nesBcur :: BlocksMade
nesBcur = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall k a. Map k a
Map.empty
    , nesEs :: EpochState ShelleyEra
nesEs = EpochState ShelleyEra
epochState
    , nesRu :: StrictMaybe PulsingRewUpdate
nesRu = forall a. StrictMaybe a
SNothing
    , nesPd :: PoolDistr
nesPd = Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr forall k a. Map k a
Map.empty 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 = forall era. UTxOState era -> UTxO era
utxosUtxo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> UTxOState era
lsUTxOState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall a b. (a -> b) -> a -> b
$ EpochState ShelleyEra
epochState
            redeemers :: Map TxIn (ShelleyTxOut ShelleyEra)
redeemers =
              forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False BootstrapAddress -> Bool
isBootstrapRedeemer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
bootAddrTxOutF) Map TxIn (ShelleyTxOut ShelleyEra)
utxo
         in forall era. Map TxIn (TxOut era) -> UTxO era
UTxO 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 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) forall t. Val t => t -> t -> t
<-> forall era. EraTxOut era => UTxO era -> Coin
coinBalance UTxO ShelleyEra
utxoShelley

    epochState :: EpochState ShelleyEra
    epochState :: EpochState ShelleyEra
epochState =
      EpochState
        { esAccountState :: AccountState
esAccountState = Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) Coin
reserves
        , esSnapshots :: SnapShots
esSnapshots = SnapShots
emptySnapShots
        , esLState :: LedgerState ShelleyEra
esLState = LedgerState ShelleyEra
ledgerState
        , esNonMyopic :: NonMyopic
esNonMyopic = forall a. Default a => a
def
        }
        forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams ShelleyEra
pparams
        forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL 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 = forall era. EraGov era => GovState era
emptyGovState
              , utxosStakeDistr :: IncrementalStake
utxosStakeDistr = Map (Credential 'Staking) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake
IStake forall a. Monoid a => a
mempty forall k a. Map k a
Map.empty
              , utxosDonation :: Coin
utxosDonation = forall a. Monoid a => a
mempty
              }
        , lsCertState :: CertState ShelleyEra
lsCertState =
            CertState
              { certDState :: DState ShelleyEra
certDState = DState ShelleyEra
dState
              , certPState :: PState ShelleyEra
certPState = forall a. Default a => a
def
              , certVState :: VState ShelleyEra
certVState = forall a. Default a => a
def
              }
        }

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