{-# 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 = Natural -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Word16) -> Natural -> Word16
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 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* PParams -> Natural
Abstract._maxBkSz PParams
pps
    , ppMaxHeaderSize :: Natural
Concrete.ppMaxHeaderSize = Natural
95 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* PParams -> Natural
Abstract._maxHdrSz PParams
pps
    , ppMaxTxSize :: Natural
Concrete.ppMaxTxSize = Natural
4096 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* PParams -> Natural
Abstract._maxTxSz PParams
pps
    , ppMaxProposalSize :: Natural
Concrete.ppMaxProposalSize = Natural
4096 Natural -> Natural -> Natural
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
          (Word64 -> SlotNumber) -> Word64 -> SlotNumber
forall a b. (a -> b) -> a -> b
$ SlotCount -> Word64
unSlotCount
          (SlotCount -> Word64) -> SlotCount -> Word64
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
                (Rational -> LovelacePortion) -> Rational -> LovelacePortion
forall a b. (a -> b) -> a -> b
$ UpAdptThd -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac
                (UpAdptThd -> Rational) -> UpAdptThd -> Rational
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 Word64
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 (TxSizeLinear -> TxFeePolicy) -> TxSizeLinear -> TxFeePolicy
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 = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Word64 -> Integer
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 (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) of
        Left LovelaceError
err -> Text -> Lovelace
forall a. HasCallStack => Text -> a
panic (Text -> Lovelace) -> Text -> Lovelace
forall a b. (a -> b) -> a -> b
$ Text
"intToLovelace: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LovelaceError -> Text
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
    (Natural -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
major)
    (Natural -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
minor)
    (Natural -> Word8
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 (Text -> ApplicationName) -> Text -> ApplicationName
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
applicationName
    applicationVersion' :: NumSoftwareVersion
applicationVersion' = Natural -> NumSoftwareVersion
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 (VKey -> VerificationKey) -> VKey -> VerificationKey
forall a b. (a -> b) -> a -> b
$ UProp -> VKey
Abstract._upIssuer UProp
abstractProposal
    signer :: VKey
signer = Sig UpSD -> VKey
forall a. Sig a -> VKey
signatureVKey (Sig UpSD -> VKey) -> Sig UpSD -> VKey
forall a b. (a -> b) -> a -> b
$ UProp -> Sig UpSD
Abstract._upSig UProp
abstractProposal
    signedProposalBody :: ProposalBody
signedProposalBody =
      UpSD -> ProposalBody
elaborateUpSD
        (UpSD -> ProposalBody) -> UpSD -> ProposalBody
forall a b. (a -> b) -> a -> b
$ Sig UpSD -> UpSD
forall a. Sig a -> a
signatureData
        (Sig UpSD -> UpSD) -> Sig UpSD -> UpSD
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 (UpSD -> ProposalBody) -> (UProp -> UpSD) -> UProp -> ProposalBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (ProtocolParameters -> ProtocolParametersUpdate)
-> ProtocolParameters -> ProtocolParametersUpdate
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 =
          [(SystemTag, InstallerHash)] -> Map SystemTag InstallerHash
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SystemTag, InstallerHash)] -> Map SystemTag InstallerHash)
-> [(SystemTag, InstallerHash)] -> Map SystemTag InstallerHash
forall a b. (a -> b) -> a -> b
$ [SystemTag] -> [InstallerHash] -> [(SystemTag, InstallerHash)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SystemTag]
concreteSystemTags [InstallerHash]
concreteSystemHashes
      }
    where
      concreteSystemTags :: [SystemTag]
concreteSystemTags =
        (String -> SystemTag) -> [String] -> [SystemTag]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> SystemTag
elaborateSystemTag ([String] -> [SystemTag]) -> [String] -> [SystemTag]
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
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 =
        InstallerHash -> [InstallerHash]
forall a. a -> [a]
repeat (InstallerHash -> [InstallerHash])
-> InstallerHash -> [InstallerHash]
forall a b. (a -> b) -> a -> b
$ Hash Raw -> InstallerHash
Concrete.InstallerHash (Hash Raw -> InstallerHash) -> Hash Raw -> InstallerHash
forall a b. (a -> b) -> a -> b
$ Hash ByteString -> Hash Raw
forall a b. Coercible a b => a -> b
coerce (Hash ByteString -> Hash Raw) -> Hash ByteString -> Hash Raw
forall a b. (a -> b) -> a -> b
$ ByteString -> Hash ByteString
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 = Word16 -> Maybe Word16
forall a. a -> Maybe a
Just (Word16 -> Maybe Word16) -> Word16 -> Maybe Word16
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Word16
Concrete.ppScriptVersion ProtocolParameters
parameters
    , ppuSlotDuration :: Maybe Natural
Concrete.ppuSlotDuration = Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural) -> Natural -> Maybe Natural
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppSlotDuration ProtocolParameters
parameters
    , ppuMaxBlockSize :: Maybe Natural
Concrete.ppuMaxBlockSize = Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural) -> Natural -> Maybe Natural
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppMaxBlockSize ProtocolParameters
parameters
    , ppuMaxHeaderSize :: Maybe Natural
Concrete.ppuMaxHeaderSize = Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural) -> Natural -> Maybe Natural
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppMaxHeaderSize ProtocolParameters
parameters
    , ppuMaxTxSize :: Maybe Natural
Concrete.ppuMaxTxSize = Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural) -> Natural -> Maybe Natural
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppMaxTxSize ProtocolParameters
parameters
    , ppuMaxProposalSize :: Maybe Natural
Concrete.ppuMaxProposalSize = Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural) -> Natural -> Maybe Natural
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Concrete.ppMaxProposalSize ProtocolParameters
parameters
    , ppuMpcThd :: Maybe LovelacePortion
Concrete.ppuMpcThd = LovelacePortion -> Maybe LovelacePortion
forall a. a -> Maybe a
Just (LovelacePortion -> Maybe LovelacePortion)
-> LovelacePortion -> Maybe LovelacePortion
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> LovelacePortion
Concrete.ppMpcThd ProtocolParameters
parameters
    , ppuHeavyDelThd :: Maybe LovelacePortion
Concrete.ppuHeavyDelThd = LovelacePortion -> Maybe LovelacePortion
forall a. a -> Maybe a
Just (LovelacePortion -> Maybe LovelacePortion)
-> LovelacePortion -> Maybe LovelacePortion
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> LovelacePortion
Concrete.ppHeavyDelThd ProtocolParameters
parameters
    , ppuUpdateVoteThd :: Maybe LovelacePortion
Concrete.ppuUpdateVoteThd = LovelacePortion -> Maybe LovelacePortion
forall a. a -> Maybe a
Just (LovelacePortion -> Maybe LovelacePortion)
-> LovelacePortion -> Maybe LovelacePortion
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> LovelacePortion
Concrete.ppUpdateVoteThd ProtocolParameters
parameters
    , ppuUpdateProposalThd :: Maybe LovelacePortion
Concrete.ppuUpdateProposalThd = LovelacePortion -> Maybe LovelacePortion
forall a. a -> Maybe a
Just (LovelacePortion -> Maybe LovelacePortion)
-> LovelacePortion -> Maybe LovelacePortion
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> LovelacePortion
Concrete.ppUpdateProposalThd ProtocolParameters
parameters
    , ppuUpdateProposalTTL :: Maybe SlotNumber
Concrete.ppuUpdateProposalTTL = SlotNumber -> Maybe SlotNumber
forall a. a -> Maybe a
Just (SlotNumber -> Maybe SlotNumber) -> SlotNumber -> Maybe SlotNumber
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> SlotNumber
Concrete.ppUpdateProposalTTL ProtocolParameters
parameters
    , ppuSoftforkRule :: Maybe SoftforkRule
Concrete.ppuSoftforkRule = SoftforkRule -> Maybe SoftforkRule
forall a. a -> Maybe a
Just (SoftforkRule -> Maybe SoftforkRule)
-> SoftforkRule -> Maybe SoftforkRule
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> SoftforkRule
Concrete.ppSoftforkRule ProtocolParameters
parameters
    , ppuTxFeePolicy :: Maybe TxFeePolicy
Concrete.ppuTxFeePolicy = TxFeePolicy -> Maybe TxFeePolicy
forall a. a -> Maybe a
Just (TxFeePolicy -> Maybe TxFeePolicy)
-> TxFeePolicy -> Maybe TxFeePolicy
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> TxFeePolicy
Concrete.ppTxFeePolicy ProtocolParameters
parameters
    , ppuUnlockStakeEpoch :: Maybe EpochNumber
Concrete.ppuUnlockStakeEpoch = EpochNumber -> Maybe EpochNumber
forall a. a -> Maybe a
Just (EpochNumber -> Maybe EpochNumber)
-> EpochNumber -> Maybe EpochNumber
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 (Text -> SystemTag) -> (String -> Text) -> String -> SystemTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
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 (VKey -> VerificationKey) -> VKey -> VerificationKey
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
        (UpId -> UpId) -> UpId -> UpId
forall a b. (a -> b) -> a -> b
$ Sig UpId -> UpId
forall a. Sig a -> a
signatureData
        (Sig UpId -> UpId) -> Sig UpId -> UpId
forall a b. (a -> b) -> a -> b
$ Vote -> Sig UpId
Abstract._vSig Vote
abstractVote
    safeSigner :: SafeSigner
safeSigner =
      VKey -> SafeSigner
vKeyToSafeSigner (VKey -> SafeSigner) -> VKey -> SafeSigner
forall a b. (a -> b) -> a -> b
$ Sig UpId -> VKey
forall a. Sig a -> VKey
signatureVKey (Sig UpId -> VKey) -> Sig UpId -> VKey
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 =
  UpId -> Maybe UpId -> UpId
forall a. a -> Maybe a -> a
fromMaybe
    UpId
abstractIdHash
    (UpId -> Map UpId UpId -> Maybe UpId
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 = Hash Int -> UpId
forall a b. Coercible a b => a -> b
coerce (Hash Int -> UpId) -> Hash Int -> UpId
forall a b. (a -> b) -> a -> b
$ Int -> Hash Int
forall a. EncCBOR a => a -> Hash a
H.serializeCborHash Int
id
      where
        Abstract.UpId Int
id = UpId
abstractProposalId