{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}

-- | Support for multiple (Shelley-based) eras in the ledger.
module Cardano.Ledger.Era
  ( Era (..),
    getTxOutBootstrapAddress,
    PreviousEra,
    TranslationContext,
    TranslateEra (..),
    translateEra',
    translateEraMaybe,
    WellFormed,
    ValidateScript (..),
    -- $segWit
    SupportsSegWit (..),
  )
where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Address (Addr (..), BootstrapAddress)
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash)
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.CompactAddress (CompactAddr, compactAddr, decompactAddr, isBootstrapCompactAddr)
import Cardano.Ledger.Compactible (Compactible)
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Crypto as CryptoClass
import Cardano.Ledger.Hashes
  ( EraIndependentAuxiliaryData,
    EraIndependentBlockBody,
    EraIndependentTxBody,
    ScriptHash (..),
  )
import Cardano.Ledger.SafeHash
  ( HashAnnotated (..),
    SafeToHash (..),
  )
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.Val (Val)
import Control.Monad.Except (Except, runExcept)
import qualified Data.ByteString as BS
import Data.Coerce (Coercible, coerce)
import Data.Kind (Type)
import Data.Map (Map)
import Data.Maybe.Strict (StrictMaybe)
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import Data.Typeable (Typeable)
import Data.Void (Void, absurd)
import Data.Word (Word64)
import GHC.Records (HasField (..))

--------------------------------------------------------------------------------
-- Era
--------------------------------------------------------------------------------

class
  ( CryptoClass.Crypto (Crypto e),
    Typeable e,
    WellFormed e
  ) =>
  Era e
  where
  type Crypto e :: Type

  -- | Extract from TxOut either an address or its compact version by doing the
  -- least amount of work.
  --
  -- The utility of this function comes from the fact that TxOut usually stores
  -- the address in either one of two forms: compacted or unpacked. In order to
  -- avoid extroneous conversions in `getTxOutAddr` and `getTxOutCompactAddr` we
  -- can define just this functionality. Also sometimes it crutial to know at
  -- the callsite which form of address we have readily available without any
  -- conversions (eg. searching millions of TxOuts for a particular address)
  getTxOutEitherAddr ::
    Core.TxOut e ->
    Either (Addr (Crypto e)) (CompactAddr (Crypto e))

  getTxOutAddr :: Core.TxOut e -> Addr (Crypto e)
  getTxOutAddr TxOut e
t =
    case TxOut e -> Either (Addr (Crypto e)) (CompactAddr (Crypto e))
forall e.
Era e =>
TxOut e -> Either (Addr (Crypto e)) (CompactAddr (Crypto e))
getTxOutEitherAddr TxOut e
t of
      Left Addr (Crypto e)
a -> Addr (Crypto e)
a
      Right CompactAddr (Crypto e)
ca -> CompactAddr (Crypto e) -> Addr (Crypto e)
forall crypto. Crypto crypto => CompactAddr crypto -> Addr crypto
decompactAddr CompactAddr (Crypto e)
ca

  getTxOutCompactAddr :: Core.TxOut e -> CompactAddr (Crypto e)
  getTxOutCompactAddr TxOut e
t =
    case TxOut e -> Either (Addr (Crypto e)) (CompactAddr (Crypto e))
forall e.
Era e =>
TxOut e -> Either (Addr (Crypto e)) (CompactAddr (Crypto e))
getTxOutEitherAddr TxOut e
t of
      Left Addr (Crypto e)
a -> Addr (Crypto e) -> CompactAddr (Crypto e)
forall crypto. Addr crypto -> CompactAddr crypto
compactAddr Addr (Crypto e)
a
      Right CompactAddr (Crypto e)
ca -> CompactAddr (Crypto e)
ca

  -- | The validity of any individual block depends only on a subset
  -- of the UTxO stored in the ledger state. The consensus layer makes
  -- use of this fact, and uses the function below to to retrieve the
  -- needed UTxO from disk and present only those to the ledger.
  -- It is therefore neccessary that this function account for all the
  -- different types of inputs inside a transaction.
  getAllTxInputs :: Core.TxBody e -> Set (TxIn (Crypto e))

-- TODO - figure out a dedicated module for things that will create helper
-- functions from this module:

-- | Get the Bootsrap address from the TxOut. Returns `Nothing` if it is a
-- Shelley address or newer
getTxOutBootstrapAddress ::
  forall era.
  Era era =>
  Core.TxOut era ->
  Maybe (BootstrapAddress (Crypto era))
getTxOutBootstrapAddress :: TxOut era -> Maybe (BootstrapAddress (Crypto era))
getTxOutBootstrapAddress TxOut era
txOut =
  case TxOut era -> Either (Addr (Crypto era)) (CompactAddr (Crypto era))
forall e.
Era e =>
TxOut e -> Either (Addr (Crypto e)) (CompactAddr (Crypto e))
getTxOutEitherAddr TxOut era
txOut of
    Left (AddrBootstrap BootstrapAddress (Crypto era)
bootstrapAddr) -> BootstrapAddress (Crypto era)
-> Maybe (BootstrapAddress (Crypto era))
forall a. a -> Maybe a
Just BootstrapAddress (Crypto era)
bootstrapAddr
    Right CompactAddr (Crypto era)
cAddr
      | CompactAddr (Crypto era) -> Bool
forall crypto. CompactAddr crypto -> Bool
isBootstrapCompactAddr CompactAddr (Crypto era)
cAddr -> do
          AddrBootstrap BootstrapAddress (Crypto era)
bootstrapAddr <- Addr (Crypto era) -> Maybe (Addr (Crypto era))
forall a. a -> Maybe a
Just (CompactAddr (Crypto era) -> Addr (Crypto era)
forall crypto. Crypto crypto => CompactAddr crypto -> Addr crypto
decompactAddr CompactAddr (Crypto era)
cAddr)
          BootstrapAddress (Crypto era)
-> Maybe (BootstrapAddress (Crypto era))
forall a. a -> Maybe a
Just BootstrapAddress (Crypto era)
bootstrapAddr
    Either (Addr (Crypto era)) (CompactAddr (Crypto era))
_ -> Maybe (BootstrapAddress (Crypto era))
forall a. Maybe a
Nothing

-----------------------------------------------------------------------------
-- Script Validation
-----------------------------------------------------------------------------

-- HasField "scriptWits" (ValidatedTx era) (Map.Map (ScriptHash c) script)

-- | Typeclass for script data types. Allows for script validation and hashing.
--   You must understand the role of SafeToHash and scriptPrefixTag to make new
--   instances. 'scriptPrefixTag' is a magic number representing the tag of the
--   script language. For each new script language defined, a new tag is chosen
--   and the tag is included in the script hash for a script. The safeToHash
--   constraint ensures that Scripts are never reserialised.
class
  ( Era era,
    SafeToHash (Core.Script era),
    HasField "body" (Core.Tx era) (Core.TxBody era)
  ) =>
  ValidateScript era
  where
  scriptPrefixTag :: Core.Script era -> BS.ByteString
  validateScript :: Core.Script era -> Core.Tx era -> Bool
  hashScript :: Core.Script era -> ScriptHash (Crypto era)
  -- ONE SHOULD NOT OVERIDE THE hashScript DEFAULT METHOD
  -- UNLESS YOU UNDERSTAND THE SafeToHash class, AND THE ROLE OF THE scriptPrefixTag
  hashScript =
    Hash (ADDRHASH (Crypto era)) EraIndependentScript
-> ScriptHash (Crypto era)
forall crypto.
Hash (ADDRHASH crypto) EraIndependentScript -> ScriptHash crypto
ScriptHash (Hash (ADDRHASH (Crypto era)) EraIndependentScript
 -> ScriptHash (Crypto era))
-> (Script era
    -> Hash (ADDRHASH (Crypto era)) EraIndependentScript)
-> Script era
-> ScriptHash (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash (ADDRHASH (Crypto era)) (Script era)
-> Hash (ADDRHASH (Crypto era)) EraIndependentScript
forall h a b. Hash h a -> Hash h b
Hash.castHash
      (Hash (ADDRHASH (Crypto era)) (Script era)
 -> Hash (ADDRHASH (Crypto era)) EraIndependentScript)
-> (Script era -> Hash (ADDRHASH (Crypto era)) (Script era))
-> Script era
-> Hash (ADDRHASH (Crypto era)) EraIndependentScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Script era -> ByteString)
-> Script era -> Hash (ADDRHASH (Crypto era)) (Script era)
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith
        (\Script era
x -> Script era -> ByteString
forall era. ValidateScript era => Script era -> ByteString
scriptPrefixTag @era Script era
x ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Script era -> ByteString
forall t. SafeToHash t => t -> ByteString
originalBytes Script era
x)
  isNativeScript :: Core.Script era -> Bool
  isNativeScript Script era
_ = Bool
True

--------------------------------------------------------------------------------
-- Segregated Witness
--------------------------------------------------------------------------------

-- $segWit
-- * Segregated Witness
--
-- The idea of segretated witnessing is to alter the encoding of transactions in
-- a block such that the witnesses (the information needed to verify the
-- validity of the transactions) can be stored separately from the body (the
-- information needed to update the ledger state). In this way, a node which
-- only cares about replaying transactions need not even decode the witness
-- information.
--
-- In order to do this, we introduce two concepts:
-- - A 'TxSeq`, which represents the decoded structure of a sequence of
--   transactions as represented in the encoded block; that is, with witnessing,
--   metadata and other non-body parts split separately.

-- | Indicates that an era supports segregated witnessing.
--
--   This class is embodies an isomorphism between 'TxSeq era' and 'StrictSeq
--   (Tx era)', witnessed by 'fromTxSeq' and 'toTxSeq'.
class SupportsSegWit era where
  type TxSeq era = (r :: Type) | r -> era

  fromTxSeq :: TxSeq era -> StrictSeq (Core.Tx era)
  toTxSeq :: StrictSeq (Core.Tx era) -> TxSeq era

  -- | Get the block body hash from the TxSeq. Note that this is not a regular
  -- "hash the stored bytes" function since the block body hash forms a small
  -- Merkle tree.
  hashTxSeq ::
    TxSeq era ->
    Hash.Hash (CryptoClass.HASH (Crypto era)) EraIndependentBlockBody

  -- | The number of segregated components
  numSegComponents :: Word64

--------------------------------------------------------------------------------
-- Era translation
--------------------------------------------------------------------------------

-- | Map an era to its predecessor.
--
-- For example:
--
-- > type instance PreviousEra (AllegraEra c) = ShelleyEra c
type family PreviousEra era :: Type

-- | Per-era context used for 'TranslateEra'.
--
-- This context will be passed to the translation instances of /all/ types of
-- that particular era. In practice, most instances won't need the context, but
-- this approach makes the translation composable (as opposed to having a
-- separate context per type).
type family TranslationContext era :: Type

-- | Translation of types between eras, e.g., from Shelley to Allegra.
--
-- When @era@ is just a phantom type parameter, an empty standalone deriving can be used:
--
-- > newtype Foo era = Foo Int
-- >
-- > instance TranslateEra (Allegra c) Foo
--
-- Note that one could use @DerivingAnyClass@ (@deriving (TranslateEra (Allegra
-- c))@), but this would introduce an undesired coupling between the
-- era-parametric type and (a) particular era(s). The intention is to have a
-- module with orphan instances per era.
--
-- In most cases, the @era@ parameter won't be phantom, and a manual instance
-- will have to be written:
--
-- > newtype Bar era = Bar (TxBody era)
-- >
-- > instance CryptoClass.Crypto c => TranslateEra (Allegra c) Bar where
-- >     translateEra ctxt = Bar <$> translateEra ctxt
-- >
-- > -- With the following instance being in scope:
-- > instance CryptoClass.Crypto c => TranslatEra (Allegra c) TxBody
--
-- Note: we use 'PreviousEra' instead of @NextEra@ as an era definitely knows
-- its predecessor, but not necessarily its successor. Moreover, one could argue
-- that it makes more sense to define the translation from era A to era B where
-- era B is defined, than where era A is defined.
class (Era era, Era (PreviousEra era)) => TranslateEra era f where
  -- | Most translations should be infallible (default instance), but we leave
  -- the door open for partial translations.
  --
  -- For a partial translation, override the default type to be '()' or a
  -- concrete error type.
  type TranslationError era f :: Type

  type TranslationError era f = Void

  -- | Translate a type @f@ parameterised by the era from an era to the era
  -- after it.
  --
  -- The translation is a given the translation context of @era@.
  --
  -- A default instance is provided for when the two types are 'Coercible'.
  translateEra :: TranslationContext era -> f (PreviousEra era) -> Except (TranslationError era f) (f era)
  default translateEra ::
    Coercible (f (PreviousEra era)) (f era) =>
    TranslationContext era ->
    f (PreviousEra era) ->
    Except (TranslationError era f) (f era)
  translateEra TranslationContext era
_ = f era -> Except (TranslationError era f) (f era)
forall (m :: * -> *) a. Monad m => a -> m a
return (f era -> Except (TranslationError era f) (f era))
-> (f (PreviousEra era) -> f era)
-> f (PreviousEra era)
-> Except (TranslationError era f) (f era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (PreviousEra era) -> f era
coerce

-- | Variant of 'translateEra' for when 'TranslationError' is 'Void' and the
-- translation thus cannot fail.
translateEra' ::
  (TranslateEra era f, TranslationError era f ~ Void) =>
  TranslationContext era ->
  f (PreviousEra era) ->
  f era
translateEra' :: TranslationContext era -> f (PreviousEra era) -> f era
translateEra' TranslationContext era
ctxt = (Void -> f era) -> (f era -> f era) -> Either Void (f era) -> f era
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> f era
forall a. Void -> a
absurd f era -> f era
forall a. a -> a
id (Either Void (f era) -> f era)
-> (f (PreviousEra era) -> Either Void (f era))
-> f (PreviousEra era)
-> f era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except Void (f era) -> Either Void (f era)
forall e a. Except e a -> Either e a
runExcept (Except Void (f era) -> Either Void (f era))
-> (f (PreviousEra era) -> Except Void (f era))
-> f (PreviousEra era)
-> Either Void (f era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
translateEra TranslationContext era
ctxt

-- | Variant of 'translateEra' for when 'TranslationError' is '()', converting
-- the result to a 'Maybe'.
translateEraMaybe ::
  (TranslateEra era f, TranslationError era f ~ ()) =>
  TranslationContext era ->
  f (PreviousEra era) ->
  Maybe (f era)
translateEraMaybe :: TranslationContext era -> f (PreviousEra era) -> Maybe (f era)
translateEraMaybe TranslationContext era
ctxt =
  (() -> Maybe (f era))
-> (f era -> Maybe (f era)) -> Either () (f era) -> Maybe (f era)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (f era) -> () -> Maybe (f era)
forall a b. a -> b -> a
const Maybe (f era)
forall a. Maybe a
Nothing) f era -> Maybe (f era)
forall a. a -> Maybe a
Just (Either () (f era) -> Maybe (f era))
-> (f (PreviousEra era) -> Either () (f era))
-> f (PreviousEra era)
-> Maybe (f era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except () (f era) -> Either () (f era)
forall e a. Except e a -> Either e a
runExcept (Except () (f era) -> Either () (f era))
-> (f (PreviousEra era) -> Except () (f era))
-> f (PreviousEra era)
-> Either () (f era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
translateEra TranslationContext era
ctxt

-- ==========================================================
-- WellFormed-ness
-- ==========================================================

-- | All Well Formed Eras have this minimal structure.
type WellFormed era =
  ( -- TxBody
    HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era)),
    HasField "txfee" (Core.TxBody era) Coin,
    HasField "minted" (Core.TxBody era) (Set (ScriptHash (Crypto era))),
    HasField "adHash" (Core.TxBody era) (StrictMaybe (AuxiliaryDataHash (Crypto era))),
    -- Tx
    HasField "body" (Core.Tx era) (Core.TxBody era),
    HasField "wits" (Core.Tx era) (Core.Witnesses era),
    HasField "auxiliaryData" (Core.Tx era) (StrictMaybe (Core.AuxiliaryData era)),
    HasField "txsize" (Core.Tx era) Integer,
    HasField "scriptWits" (Core.Tx era) (Map (ScriptHash (Crypto era)) (Core.Script era)),
    -- TxOut
    HasField "value" (Core.TxOut era) (Core.Value era),
    -- HashAnnotated
    HashAnnotated (Core.AuxiliaryData era) EraIndependentAuxiliaryData (Crypto era),
    HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era),
    SupportsSegWit era,
    Val (Core.Value era),
    Compactible (Core.Value era) -- TxOut stores a CompactForm(Core.Value)
  )

{-  TODO, there are a few other constraints which are WellFormed and we should add
them when time permits. Some are not added because the types they mentions reside
in files that cause circular import dependencies.
   -- import Cardano.Ledger.Shelley.TxBody(DCert,Wdrl,WitVKey)
   -- import Cardano.Ledger.Shelley.Tx(TxIn)
These would have to be moved into a module such as Cardano.Ledger.TxBase(TxIn,DCert,Wdrl)
   -- HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),       -- all possible inputs
   -- HasField "txinputs_fee" (Core.TxBody era) (Set (TxIn (Crypto era)))  -- inputs that can be used to pay fees
   -- HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
   -- HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
   -- HasField "addrWits" (Core.Tx era) (Set (WitVKey 'Witness (Crypto era)))
others where the concrete type (Update and WitnessSet) will have to be made into a type family
   -- import Cardano.Ledger.Shelley.PParams (Update)
   -- import Cardano.Ledger.Shelley.Tx(WitnessSet)
   -- import Cardano.Ledger.Alonzo.Scripts (ExUnits)
   -- HasField "update" (Core.TxBody era) (StrictMaybe (Update era)),
   -- HasField "wits" (Core.Tx era) (WitnessSet era),
   -- HasField "exUnits" (Core.Tx era) ExUnits,
-}