{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Chain.Elaboration.Update (
  elaboratePParams,
  elaborateProtocolVersion,
  elaborateSoftwareVersion,
  elaborateUpdateProposal,
  elaborateVote,
)
where

import Byron.Spec.Ledger.Core (unSlotCount)
import Byron.Spec.Ledger.Core.Omniscient (signatureData, signatureVKey)
import qualified Byron.Spec.Ledger.GlobalParams as GP
import qualified Byron.Spec.Ledger.Update as Abstract
import qualified Cardano.Chain.Common as Concrete
import qualified Cardano.Chain.Slotting as Concrete
import qualified Cardano.Chain.Update as Concrete
import qualified Cardano.Chain.Update.Proposal as Proposal
import Cardano.Crypto (ProtocolMagicId)
import qualified Cardano.Crypto.Hashing as H
import Cardano.Prelude
import Data.Coerce (coerce)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import Test.Cardano.Chain.Elaboration.Keys (elaborateVKey, vKeyToSafeSigner)
import Test.Cardano.Chain.Genesis.Dummy (dummyProtocolParameters)

elaboratePParams :: Abstract.PParams -> Concrete.ProtocolParameters
elaboratePParams :: PParams -> ProtocolParameters
elaboratePParams PParams
pps =
  Concrete.ProtocolParameters
    { ppScriptVersion :: Word16
Concrete.ppScriptVersion = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ PParams -> Natural
Abstract._scriptVersion PParams
pps
    , ppSlotDuration :: Natural
Concrete.ppSlotDuration = ProtocolParameters -> Natural
Concrete.ppSlotDuration ProtocolParameters
dummyProtocolParameters
    , ppMaxBlockSize :: Natural
Concrete.ppMaxBlockSize = Natural
4096 forall a. Num a => a -> a -> a
* PParams -> Natural
Abstract._maxBkSz PParams
pps
    , ppMaxHeaderSize :: Natural
Concrete.ppMaxHeaderSize = Natural
95 forall a. Num a => a -> a -> a
* PParams -> Natural
Abstract._maxHdrSz PParams
pps
    , ppMaxTxSize :: Natural
Concrete.ppMaxTxSize = Natural
4096 forall a. Num a => a -> a -> a
* PParams -> Natural
Abstract._maxTxSz PParams
pps
    , ppMaxProposalSize :: Natural
Concrete.ppMaxProposalSize = Natural
4096 forall a. Num a => a -> a -> a
* PParams -> Natural
Abstract._maxPropSz PParams
pps
    , ppMpcThd :: LovelacePortion
Concrete.ppMpcThd = Rational -> LovelacePortion
Concrete.rationalToLovelacePortion Rational
0
    , ppHeavyDelThd :: LovelacePortion
Concrete.ppHeavyDelThd = Rational -> LovelacePortion
Concrete.rationalToLovelacePortion Rational
0
    , ppUpdateVoteThd :: LovelacePortion
Concrete.ppUpdateVoteThd = Rational -> LovelacePortion
Concrete.rationalToLovelacePortion Rational
0
    , ppUpdateProposalThd :: LovelacePortion
Concrete.ppUpdateProposalThd = Rational -> LovelacePortion
Concrete.rationalToLovelacePortion Rational
0
    , ppUpdateProposalTTL :: SlotNumber
Concrete.ppUpdateProposalTTL =
        Word64 -> SlotNumber
Concrete.SlotNumber
          forall a b. (a -> b) -> a -> b
$ SlotCount -> Word64
unSlotCount
          forall a b. (a -> b) -> a -> b
$ PParams -> SlotCount
Abstract._upTtl PParams
pps
    , ppSoftforkRule :: SoftforkRule
Concrete.ppSoftforkRule =
        Concrete.SoftforkRule
          { srInitThd :: LovelacePortion
Concrete.srInitThd = Rational -> LovelacePortion
Concrete.rationalToLovelacePortion Rational
0
          , -- See 'upAdptThd' in 'module Cardano.Chain.Update.ProtocolParameters'
            srMinThd :: LovelacePortion
Concrete.srMinThd =
              Rational -> LovelacePortion
Concrete.rationalToLovelacePortion
                forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac
                forall a b. (a -> b) -> a -> b
$ PParams -> UpAdptThd
Abstract._upAdptThd PParams
pps
          , srThdDecrement :: LovelacePortion
Concrete.srThdDecrement = Rational -> LovelacePortion
Concrete.rationalToLovelacePortion Rational
0
          }
    , ppTxFeePolicy :: TxFeePolicy
Concrete.ppTxFeePolicy =
        FactorA -> FactorB -> TxFeePolicy
elaborateFeePolicy
          (PParams -> FactorA
Abstract._factorA PParams
pps)
          (PParams -> FactorB
Abstract._factorB PParams
pps)
    , ppUnlockStakeEpoch :: EpochNumber
Concrete.ppUnlockStakeEpoch = Word64 -> EpochNumber
Concrete.EpochNumber forall a. Bounded a => a
maxBound
    }

elaborateFeePolicy ::
  Abstract.FactorA ->
  Abstract.FactorB ->
  Concrete.TxFeePolicy
elaborateFeePolicy :: FactorA -> FactorB -> TxFeePolicy
elaborateFeePolicy (Abstract.FactorA Int
a) (Abstract.FactorB Int
b) =
  TxSizeLinear -> TxFeePolicy
Concrete.TxFeePolicyTxSizeLinear forall a b. (a -> b) -> a -> b
$ Lovelace -> Rational -> TxSizeLinear
Concrete.TxSizeLinear Lovelace
aC Rational
bC
  where
    aC :: Lovelace
aC = Int -> Lovelace
intToLovelace Int
a
    bC :: Rational
bC = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b forall a. Integral a => a -> a -> Ratio a
% forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
GP.c :: Rational

    intToLovelace :: Int -> Concrete.Lovelace
    intToLovelace :: Int -> Lovelace
intToLovelace Int
x =
      case Word64 -> Either LovelaceError Lovelace
Concrete.mkLovelace (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) of
        Left LovelaceError
err -> forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ Text
"intToLovelace: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show LovelaceError
err
        Right Lovelace
l -> Lovelace
l

elaborateProtocolVersion ::
  Abstract.ProtVer ->
  Concrete.ProtocolVersion
elaborateProtocolVersion :: ProtVer -> ProtocolVersion
elaborateProtocolVersion (Abstract.ProtVer Natural
major Natural
minor Natural
alternative) =
  -- TODO: the abstract version numbers should have the same type as the
  -- concrete ones!
  Word16 -> Word16 -> Word8 -> ProtocolVersion
Concrete.ProtocolVersion
    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
major)
    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
minor)
    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
alternative)

elaborateSoftwareVersion ::
  Abstract.SwVer ->
  Concrete.SoftwareVersion
elaborateSoftwareVersion :: SwVer -> SoftwareVersion
elaborateSoftwareVersion SwVer
abstractVersion =
  ApplicationName -> NumSoftwareVersion -> SoftwareVersion
Concrete.SoftwareVersion ApplicationName
applicationName' NumSoftwareVersion
applicationVersion'
  where
    Abstract.SwVer
      (Abstract.ApName String
applicationName)
      (Abstract.ApVer Natural
applicationVersion) = SwVer
abstractVersion
    applicationName' :: ApplicationName
applicationName' = Text -> ApplicationName
Concrete.ApplicationName forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
applicationName
    applicationVersion' :: NumSoftwareVersion
applicationVersion' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
applicationVersion :: Concrete.NumSoftwareVersion

elaborateUpdateProposal ::
  ProtocolMagicId ->
  Abstract.UProp ->
  Concrete.AProposal ()
elaborateUpdateProposal :: ProtocolMagicId -> UProp -> AProposal ()
elaborateUpdateProposal ProtocolMagicId
protocolMagicId UProp
abstractProposal =
  ProposalBody
-> VerificationKey -> Signature ProposalBody -> AProposal ()
Concrete.unsafeProposal
    ProposalBody
body
    VerificationKey
issuer
    Signature ProposalBody
proposalSignature
  where
    body :: ProposalBody
body = UProp -> ProposalBody
elaborateProposalBody UProp
abstractProposal
    issuer :: VerificationKey
issuer = VKey -> VerificationKey
elaborateVKey forall a b. (a -> b) -> a -> b
$ UProp -> VKey
Abstract._upIssuer UProp
abstractProposal
    signer :: VKey
signer = forall a. Sig a -> VKey
signatureVKey forall a b. (a -> b) -> a -> b
$ UProp -> Sig UpSD
Abstract._upSig UProp
abstractProposal
    signedProposalBody :: ProposalBody
signedProposalBody =
      UpSD -> ProposalBody
elaborateUpSD
        forall a b. (a -> b) -> a -> b
$ forall a. Sig a -> a
signatureData
        forall a b. (a -> b) -> a -> b
$ UProp -> Sig UpSD
Abstract._upSig UProp
abstractProposal
    -- To elaborate the signature, we extract the signer and the (abstract)
    -- data that was signed from the signature of the abstract proposal. We
    -- cannot simply sign the concrete proposal data, since the abstract signed
    -- data might differ from the data in the certificate (for instance due to
    -- invalid data generation).
    --
    proposalSignature :: Signature ProposalBody
proposalSignature =
      ProtocolMagicId
-> ProposalBody -> SafeSigner -> Signature ProposalBody
Concrete.signatureForProposal
        ProtocolMagicId
protocolMagicId
        ProposalBody
signedProposalBody
        SafeSigner
safeSigner
    safeSigner :: SafeSigner
safeSigner = VKey -> SafeSigner
vKeyToSafeSigner VKey
signer

elaborateProposalBody ::
  Abstract.UProp ->
  Concrete.ProposalBody
elaborateProposalBody :: UProp -> ProposalBody
elaborateProposalBody = UpSD -> ProposalBody
elaborateUpSD forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UProp -> UpSD
Abstract.getUpSigData

elaborateUpSD :: Abstract.UpSD -> Concrete.ProposalBody
elaborateUpSD :: UpSD -> ProposalBody
elaborateUpSD
  ( ProtVer
protocolVersion
    , PParams
protocolParameters
    , SwVer
softwareVersion
    , Set String
systemTags
    , Metadata
_metadata
    ) =
    Proposal.ProposalBody
      { $sel:protocolVersion:ProposalBody :: ProtocolVersion
Proposal.protocolVersion =
          ProtVer -> ProtocolVersion
elaborateProtocolVersion ProtVer
protocolVersion
      , $sel:protocolParametersUpdate:ProposalBody :: ProtocolParametersUpdate
Proposal.protocolParametersUpdate =
          ProtocolParameters -> ProtocolParametersUpdate
justifyProtocolParameters forall a b. (a -> b) -> a -> b
$ PParams -> ProtocolParameters
elaboratePParams PParams
protocolParameters
      , $sel:softwareVersion:ProposalBody :: SoftwareVersion
Proposal.softwareVersion =
          SwVer -> SoftwareVersion
elaborateSoftwareVersion SwVer
softwareVersion
      , $sel:metadata:ProposalBody :: Map SystemTag InstallerHash
Proposal.metadata =
          forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [SystemTag]
concreteSystemTags [InstallerHash]
concreteSystemHashes
      }
    where
      concreteSystemTags :: [SystemTag]
concreteSystemTags =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> SystemTag
elaborateSystemTag forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set String
systemTags
      -- TODO: we might need different hashes here, which means that either the
      -- elaborators should be able to generate random data, or the abstract
      -- update payload should include (an abstract version of) these hashes.
      concreteSystemHashes :: [InstallerHash]
concreteSystemHashes =
        forall a. a -> [a]
repeat forall a b. (a -> b) -> a -> b
$ Hash Raw -> InstallerHash
Concrete.InstallerHash forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => a -> Hash a
H.serializeCborHash (ByteString
"" :: ByteString)

-- | Convert a 'ProtocolParameters' value to a 'ProtocolParametersUpdate'
justifyProtocolParameters ::
  Concrete.ProtocolParameters ->
  Concrete.ProtocolParametersUpdate
justifyProtocolParameters :: ProtocolParameters -> ProtocolParametersUpdate
justifyProtocolParameters ProtocolParameters
parameters =
  Concrete.ProtocolParametersUpdate
    { ppuScriptVersion :: Maybe Word16
Concrete.ppuScriptVersion = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Word16
Concrete.ppScriptVersion ProtocolParameters
parameters
    , ppuSlotDuration :: Maybe Natural
Concrete.ppuSlotDuration = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppSlotDuration ProtocolParameters
parameters
    , ppuMaxBlockSize :: Maybe Natural
Concrete.ppuMaxBlockSize = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppMaxBlockSize ProtocolParameters
parameters
    , ppuMaxHeaderSize :: Maybe Natural
Concrete.ppuMaxHeaderSize = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppMaxHeaderSize ProtocolParameters
parameters
    , ppuMaxTxSize :: Maybe Natural
Concrete.ppuMaxTxSize = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppMaxTxSize ProtocolParameters
parameters
    , ppuMaxProposalSize :: Maybe Natural
Concrete.ppuMaxProposalSize = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppMaxProposalSize ProtocolParameters
parameters
    , ppuMpcThd :: Maybe LovelacePortion
Concrete.ppuMpcThd = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> LovelacePortion
Concrete.ppMpcThd ProtocolParameters
parameters
    , ppuHeavyDelThd :: Maybe LovelacePortion
Concrete.ppuHeavyDelThd = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> LovelacePortion
Concrete.ppHeavyDelThd ProtocolParameters
parameters
    , ppuUpdateVoteThd :: Maybe LovelacePortion
Concrete.ppuUpdateVoteThd = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> LovelacePortion
Concrete.ppUpdateVoteThd ProtocolParameters
parameters
    , ppuUpdateProposalThd :: Maybe LovelacePortion
Concrete.ppuUpdateProposalThd = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> LovelacePortion
Concrete.ppUpdateProposalThd ProtocolParameters
parameters
    , ppuUpdateProposalTTL :: Maybe SlotNumber
Concrete.ppuUpdateProposalTTL = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> SlotNumber
Concrete.ppUpdateProposalTTL ProtocolParameters
parameters
    , ppuSoftforkRule :: Maybe SoftforkRule
Concrete.ppuSoftforkRule = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> SoftforkRule
Concrete.ppSoftforkRule ProtocolParameters
parameters
    , ppuTxFeePolicy :: Maybe TxFeePolicy
Concrete.ppuTxFeePolicy = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> TxFeePolicy
Concrete.ppTxFeePolicy ProtocolParameters
parameters
    , ppuUnlockStakeEpoch :: Maybe EpochNumber
Concrete.ppuUnlockStakeEpoch = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> EpochNumber
Concrete.ppUnlockStakeEpoch ProtocolParameters
parameters
    }

elaborateSystemTag :: Abstract.STag -> Concrete.SystemTag
elaborateSystemTag :: String -> SystemTag
elaborateSystemTag = Text -> SystemTag
Concrete.SystemTag forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
Text.pack

elaborateVote ::
  ProtocolMagicId ->
  Map Abstract.UpId Concrete.UpId ->
  Abstract.Vote ->
  Concrete.AVote ()
elaborateVote :: ProtocolMagicId -> Map UpId UpId -> Vote -> AVote ()
elaborateVote ProtocolMagicId
protocolMagicId Map UpId UpId
proposalsIdMap Vote
abstractVote =
  VerificationKey -> UpId -> Signature (UpId, Bool) -> AVote ()
Concrete.unsafeVote
    VerificationKey
issuer
    (Map UpId UpId -> UpId -> UpId
elaborateProposalId Map UpId UpId
proposalsIdMap UpId
abstractProposalId)
    Signature (UpId, Bool)
voteSignature
  where
    abstractProposalId :: UpId
abstractProposalId = Vote -> UpId
Abstract._vPropId Vote
abstractVote
    issuer :: VerificationKey
issuer = VKey -> VerificationKey
elaborateVKey forall a b. (a -> b) -> a -> b
$ Vote -> VKey
Abstract._vCaster Vote
abstractVote
    voteSignature :: Signature (UpId, Bool)
voteSignature =
      ProtocolMagicId
-> UpId -> Bool -> SafeSigner -> Signature (UpId, Bool)
Concrete.signatureForVote
        ProtocolMagicId
protocolMagicId
        UpId
signedUpId
        Bool
True -- We assume the decision to be always constant
        SafeSigner
safeSigner
    signedUpId :: UpId
signedUpId =
      Map UpId UpId -> UpId -> UpId
elaborateProposalId Map UpId UpId
proposalsIdMap
        forall a b. (a -> b) -> a -> b
$ forall a. Sig a -> a
signatureData
        forall a b. (a -> b) -> a -> b
$ Vote -> Sig UpId
Abstract._vSig Vote
abstractVote
    safeSigner :: SafeSigner
safeSigner =
      VKey -> SafeSigner
vKeyToSafeSigner forall a b. (a -> b) -> a -> b
$ forall a. Sig a -> VKey
signatureVKey forall a b. (a -> b) -> a -> b
$ Vote -> Sig UpId
Abstract._vSig Vote
abstractVote

-- | Lookup the proposal id in the map. If the proposal id is not in the map
-- then return the hash of the abstract proposal id.
--
-- The reason why we return the hash of the abstract proposal id if the
-- proposal id is not in the given map is that when producing invalid abstract
-- votes, we need to elaborate a non-existing abstract proposal id into a
-- concrete one. Since we don't return a 'Gen' monad, the only source of
-- variability we have is the abstract proposal id.
elaborateProposalId ::
  Map Abstract.UpId Concrete.UpId ->
  Abstract.UpId ->
  Concrete.UpId
elaborateProposalId :: Map UpId UpId -> UpId -> UpId
elaborateProposalId Map UpId UpId
proposalsIdMap UpId
abstractProposalId =
  forall a. a -> Maybe a -> a
fromMaybe
    UpId
abstractIdHash
    (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpId
abstractProposalId Map UpId UpId
proposalsIdMap)
  where
    -- If we cannot find a concrete proposal id that corresponds with the
    -- given abstract proposal id, then we return the (coerced) hash of the
    -- abstract proposal id.
    --
    -- NOTE: if the elaborators returned a `Gen a` value, then we could
    -- return random hashes here.
    abstractIdHash :: Concrete.UpId -- Keeps GHC happy ...
    abstractIdHash :: UpId
abstractIdHash = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => a -> Hash a
H.serializeCborHash Int
id
      where
        Abstract.UpId Int
id = UpId
abstractProposalId