{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This is a module that contains functionality that is not necessary for ledger
-- operation, but is useful for testing as well as for downstream users of ledger
module Cardano.Ledger.Tools (
  -- * Tx
  setMinFeeTx,
  setMinFeeTxUtxo,
  calcMinFeeTx,
  calcMinFeeTxNativeScriptWits,
  estimateMinFeeTx,
  addDummyWitsTx,

  -- * TxOut
  setMinCoinTxOut,
  ensureMinCoinTxOut,
  setMinCoinTxOutWith,

  -- * General tools
  boom,
  integralToByteStringN,
  byteStringToNum,
) where

import qualified Cardano.Chain.Common as Byron
import Cardano.Crypto.DSIGN.Class (sizeSigDSIGN, sizeVerKeyDSIGN)
import Cardano.Ledger.Address (BootstrapAddress (..), bootstrapKeyHash)
import Cardano.Ledger.BaseTypes (ProtVer (..))
import Cardano.Ledger.Binary (byronProtVer, decodeFull', serialize')
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Core
import Cardano.Ledger.Keys (
  BootstrapWitness (..),
  ChainCode (..),
  DSIGN,
  VKey,
  WitVKey (..),
  asWitness,
 )
import Cardano.Ledger.State (EraCertState)
import Cardano.Ledger.State.UTxO (EraUTxO (..), UTxO (..))
import Data.Bits (Bits (..), shiftR)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Default (def)
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import Data.Proxy
import qualified Data.Set as Set
import GHC.Stack (HasCallStack)
import Lens.Micro

-- | Calculate and update the fee in the transaction until it has the smallest possible
-- value according to the settings in the protocol parameters.
--
-- This function potentially changes the `feeTxBodyL` field of the `TxBody`, as such it
-- affects the hash of the body, which consequently invalidates all of the signature in
-- the attached witnesses.
setMinFeeTx ::
  EraTx era =>
  PParams era ->
  Tx era ->
  -- | Size in bytes of reference scripts present in this transaction
  Int ->
  Tx era
setMinFeeTx :: forall era. EraTx era => PParams era -> Tx era -> Int -> Tx era
setMinFeeTx PParams era
pp Tx era
tx Int
refScriptsSize =
  (Tx era -> Coin) -> Tx era -> Tx era
forall era. EraTx era => (Tx era -> Coin) -> Tx era -> Tx era
setMinFeeTxInternal (\Tx era
t -> PParams era -> Tx era -> Int -> Coin
forall era. EraTx era => PParams era -> Tx era -> Int -> Coin
getMinFeeTx PParams era
pp Tx era
t Int
refScriptsSize) Tx era
tx

setMinFeeTxUtxo :: EraUTxO era => PParams era -> Tx era -> UTxO era -> Tx era
setMinFeeTxUtxo :: forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Tx era
setMinFeeTxUtxo PParams era
pp Tx era
tx UTxO era
utxo =
  (Tx era -> Coin) -> Tx era -> Tx era
forall era. EraTx era => (Tx era -> Coin) -> Tx era -> Tx era
setMinFeeTxInternal (\Tx era
t -> PParams era -> Tx era -> UTxO era -> Coin
forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
pp Tx era
t UTxO era
utxo) Tx era
tx

-- | Similar to `setMinCoinTxOut` it will guarantee that the minimum requirement for the
-- output amount is satisified, however it makes it possible to set a higher amount than
-- the minimaly required.
--
-- @
-- > ensureMinCoinTxOut pp (txOut & coinTxOutL .~ zero) == setMinCoinTxOut pp (txOut & coinTxOutL .~ zero)
-- > (ensureMinCoinTxOut pp txOut ^. coinTxOutL) >= (setMinCoinTxOut pp txOut ^. coinTxOutL)
-- @
ensureMinCoinTxOut :: EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut :: forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut = (Coin -> Coin -> Bool) -> PParams era -> TxOut era -> TxOut era
forall era.
EraTxOut era =>
(Coin -> Coin -> Bool) -> PParams era -> TxOut era -> TxOut era
setMinCoinTxOutWith Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
(>=)

setMinFeeTxInternal ::
  EraTx era =>
  (Tx era -> Coin) ->
  Tx era ->
  Tx era
setMinFeeTxInternal :: forall era. EraTx era => (Tx era -> Coin) -> Tx era -> Tx era
setMinFeeTxInternal Tx era -> Coin
f Tx era
tx =
  let curMinFee :: Coin
curMinFee = Tx era -> Coin
f Tx era
tx
      curFee :: Coin
curFee = Tx era
tx Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL
      modifiedTx :: Tx era
modifiedTx = Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> (Coin -> Identity Coin)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> Tx era -> Identity (Tx era))
-> Coin -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
curMinFee
   in if Coin
curFee Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
curMinFee
        then Tx era
tx
        else (Tx era -> Coin) -> Tx era -> Tx era
forall era. EraTx era => (Tx era -> Coin) -> Tx era -> Tx era
setMinFeeTxInternal Tx era -> Coin
f Tx era
modifiedTx

-- | Same as `calcMinFeeTx`, except this function allows to specify hashes of key witnesses
-- that will be supplied, instead of their count. That is only useful whenever there is a
-- chance of some of the required witnesses being the same as the witnesses that will be
-- supplied for native scripts.
calcMinFeeTxNativeScriptWits ::
  forall era.
  (EraUTxO era, EraCertState era) =>
  -- | All TxOuts available for this transaction. In other words `TxIn`s produced by
  -- `allInputsTxBodyF` should be present in this `UTxO` map, however this is not checked.
  UTxO era ->
  -- | The current protocol parameters.
  PParams era ->
  -- | The transaction.
  Tx era ->
  -- | KeyHash witnesses that will be supplied for satisfying native scripts. It is
  -- impossible to know how many of these is required without knowing the actual witnesses
  -- supplied and the time when the transaction will be submitted. Therefore we put this
  -- burden on the user.
  Set.Set (KeyHash 'Witness) ->
  -- | The required minimum fee.
  Coin
calcMinFeeTxNativeScriptWits :: forall era.
(EraUTxO era, EraCertState era) =>
UTxO era -> PParams era -> Tx era -> Set (KeyHash 'Witness) -> Coin
calcMinFeeTxNativeScriptWits UTxO era
utxo PParams era
pp Tx era
tx Set (KeyHash 'Witness)
nativeScriptsKeyWitsHashes =
  UTxO era
-> PParams era -> Tx era -> Int -> Set (KeyHash 'Witness) -> Coin
forall era.
(EraUTxO era, EraCertState era) =>
UTxO era
-> PParams era -> Tx era -> Int -> Set (KeyHash 'Witness) -> Coin
calcMinFeeTxInternal UTxO era
utxo PParams era
pp Tx era
tx (Set (KeyHash 'Witness) -> Int
forall a. Set a -> Int
Set.size Set (KeyHash 'Witness)
nativeScriptsKeyWitsHashes) Set (KeyHash 'Witness)
nativeScriptsKeyWitsHashes

-- | This is a more accurate version `estimateMinFeeTx` that looks into transaction and
-- figures out how many and what kind of key witnesses this transaction needs. It requires
-- access to the portion of the `UTxO` that is relevant for this transaction. The only
-- type of witnesses that it cannot figure out reliably is the witnesses needed for
-- satisfying native scripts included in the transaction. For this reason number of
-- witnesses needed for native scripts must be supplied as an extra argument.
--
-- ====__Example__
--
-- > let relevantUtxo = txInsFilter utxo (tx ^. bodyTxL . allInputsTxBodyF)
-- > calcMinFeeTx relevantUtxo pp tx 5
calcMinFeeTx ::
  forall era.
  (EraUTxO era, EraCertState era) =>
  -- | All TxOuts available for this transaction. In other words `TxIn`s produced by
  -- `allInputsTxBodyF` should be present in this `UTxO` map, however this is not checked.
  UTxO era ->
  -- | The current protocol parameters.
  PParams era ->
  -- | The transaction.
  Tx era ->
  -- | Number of extra KeyHash witnesses that will be supplied for satisfying native
  -- scripts. It is impossible to know how many of these is required without knowing the
  -- actual witnesses supplied and the time when the transaction will be
  -- submitted. Therefore we put this burden on the user.
  --
  -- This number can also be used to specify all of the redundant extra key witnesses that
  -- will be supplied.
  Int ->
  -- | The required minimum fee.
  Coin
calcMinFeeTx :: forall era.
(EraUTxO era, EraCertState era) =>
UTxO era -> PParams era -> Tx era -> Int -> Coin
calcMinFeeTx UTxO era
utxo PParams era
pp Tx era
tx Int
extraKeyWitsCount =
  UTxO era
-> PParams era -> Tx era -> Int -> Set (KeyHash 'Witness) -> Coin
forall era.
(EraUTxO era, EraCertState era) =>
UTxO era
-> PParams era -> Tx era -> Int -> Set (KeyHash 'Witness) -> Coin
calcMinFeeTxInternal UTxO era
utxo PParams era
pp Tx era
tx Int
extraKeyWitsCount Set (KeyHash 'Witness)
forall a. Set a
Set.empty

calcMinFeeTxInternal ::
  forall era.
  (EraUTxO era, EraCertState era) =>
  -- | All TxOuts available for this transaction. In other words `TxIn`s produced by
  -- `allInputsTxBodyF` should be present in this `UTxO` map, however this is not checked.
  UTxO era ->
  -- | The current protocol parameters.
  PParams era ->
  -- | The transaction.
  Tx era ->
  -- | Number of KeyHash witnesses that will be supplied for native scripts
  Int ->
  -- | KeyHash witnesses that will be supplied for native scripts
  Set.Set (KeyHash 'Witness) ->
  Coin
calcMinFeeTxInternal :: forall era.
(EraUTxO era, EraCertState era) =>
UTxO era
-> PParams era -> Tx era -> Int -> Set (KeyHash 'Witness) -> Coin
calcMinFeeTxInternal UTxO era
utxo PParams era
pp Tx era
tx Int
extraKeyWitsCount Set (KeyHash 'Witness)
nativeScriptsKeyWitsHashes =
  PParams era -> Tx era -> UTxO era -> Tx era
forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Tx era
setMinFeeTxUtxo PParams era
pp Tx era
tx' UTxO era
utxo Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL
  where
    txBody :: TxBody era
txBody = Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
    tx' :: Tx era
tx' = PParams era
-> Tx era -> Int -> [Attributes AddrAttributes] -> Tx era
forall era.
EraTx era =>
PParams era
-> Tx era -> Int -> [Attributes AddrAttributes] -> Tx era
addDummyWitsTx PParams era
pp Tx era
tx Int
numKeyWitsRequired ([Attributes AddrAttributes] -> Tx era)
-> [Attributes AddrAttributes] -> Tx era
forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Witness) (Attributes AddrAttributes)
-> [Attributes AddrAttributes]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Witness) (Attributes AddrAttributes)
byronAttributes
    inputs :: [TxIn]
inputs = Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (Set TxIn -> [TxIn]) -> Set TxIn -> [TxIn]
forall a b. (a -> b) -> a -> b
$ TxBody era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => SimpleGetter (TxBody era) (Set TxIn)
SimpleGetter (TxBody era) (Set TxIn)
spendableInputsTxBodyF
    getByronAttrs :: TxIn -> Maybe (KeyHash 'Witness, Attributes AddrAttributes)
getByronAttrs TxIn
txIn = do
      TxOut era
txOut <- TxIn -> Map TxIn (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
txIn (Map TxIn (TxOut era) -> Maybe (TxOut era))
-> Map TxIn (TxOut era) -> Maybe (TxOut era)
forall a b. (a -> b) -> a -> b
$ UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxo
      ba :: BootstrapAddress
ba@(BootstrapAddress Address
bootAddr) <- TxOut era
txOut TxOut era
-> Getting
     (Maybe BootstrapAddress) (TxOut era) (Maybe BootstrapAddress)
-> Maybe BootstrapAddress
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe BootstrapAddress) (TxOut era) (Maybe BootstrapAddress)
forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
bootAddrTxOutF
      (KeyHash 'Witness, Attributes AddrAttributes)
-> Maybe (KeyHash 'Witness, Attributes AddrAttributes)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyHash 'Payment -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (BootstrapAddress -> KeyHash 'Payment
bootstrapKeyHash BootstrapAddress
ba), Address -> Attributes AddrAttributes
Byron.addrAttributes Address
bootAddr)
    byronAttributes :: Map (KeyHash 'Witness) (Attributes AddrAttributes)
byronAttributes = [(KeyHash 'Witness, Attributes AddrAttributes)]
-> Map (KeyHash 'Witness) (Attributes AddrAttributes)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(KeyHash 'Witness, Attributes AddrAttributes)]
 -> Map (KeyHash 'Witness) (Attributes AddrAttributes))
-> [(KeyHash 'Witness, Attributes AddrAttributes)]
-> Map (KeyHash 'Witness) (Attributes AddrAttributes)
forall a b. (a -> b) -> a -> b
$ (TxIn -> Maybe (KeyHash 'Witness, Attributes AddrAttributes))
-> [TxIn] -> [(KeyHash 'Witness, Attributes AddrAttributes)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxIn -> Maybe (KeyHash 'Witness, Attributes AddrAttributes)
getByronAttrs [TxIn]
inputs
    requiredKeyHashes :: Set (KeyHash 'Witness)
requiredKeyHashes =
      CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness)
forall era.
EraUTxO era =>
CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getWitsVKeyNeeded CertState era
forall a. Default a => a
def UTxO era
utxo TxBody era
txBody Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (KeyHash 'Witness)
nativeScriptsKeyWitsHashes
    numKeyWitsRequired :: Int
numKeyWitsRequired =
      TxBody era -> Int
forall era. EraTxBody era => TxBody era -> Int
getGenesisKeyHashCountTxBody TxBody era
txBody
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
extraKeyWitsCount
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set (KeyHash 'Witness) -> Int
forall a. Set a -> Int
Set.size (Set (KeyHash 'Witness)
requiredKeyHashes Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Map (KeyHash 'Witness) (Attributes AddrAttributes)
-> Set (KeyHash 'Witness)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Witness) (Attributes AddrAttributes)
byronAttributes)

-- | Estimate a minimum transaction fee for a transaction that does not yet have all of
-- the `VKey` witnesses. This calculation is not very accurate in estimating Byron
-- witnesses, but it should work for the most part. If you have access to UTxO necessary
-- for the transaction that it is better and easier to use `calcMinFeeTx` instead.
--
-- @since 1.8.0
estimateMinFeeTx ::
  forall era.
  EraTx era =>
  -- | The current protocol parameters.
  PParams era ->
  -- | The transaction.
  Tx era ->
  -- | The number of key witnesses still to be added to the transaction.
  Int ->
  -- | The number of Byron key witnesses still to be added to the transaction.
  Int ->
  -- | The total size in bytes of reference scripts
  Int ->
  -- | The required minimum fee.
  Coin
estimateMinFeeTx :: forall era.
EraTx era =>
PParams era -> Tx era -> Int -> Int -> Int -> Coin
estimateMinFeeTx PParams era
pp Tx era
tx Int
numKeyWits Int
numByronKeyWits Int
refScriptsSize =
  PParams era -> Tx era -> Int -> Tx era
forall era. EraTx era => PParams era -> Tx era -> Int -> Tx era
setMinFeeTx PParams era
pp Tx era
tx' Int
refScriptsSize Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL
  where
    tx' :: Tx era
tx' = PParams era
-> Tx era -> Int -> [Attributes AddrAttributes] -> Tx era
forall era.
EraTx era =>
PParams era
-> Tx era -> Int -> [Attributes AddrAttributes] -> Tx era
addDummyWitsTx PParams era
pp Tx era
tx Int
numKeyWits ([Attributes AddrAttributes] -> Tx era)
-> [Attributes AddrAttributes] -> Tx era
forall a b. (a -> b) -> a -> b
$ Int -> Attributes AddrAttributes -> [Attributes AddrAttributes]
forall a. Int -> a -> [a]
replicate Int
numByronKeyWits Attributes AddrAttributes
dummyByronAttributes
    -- We assume testnet network magic here to avoid having to thread the actual network
    -- ID into this function merely to calculate the fees of byron witnesses more
    -- accurately. This will over-estimate min fees for byron witnesses in mainnet
    -- transaction by 7 bytes per witness.
    dummyByronAttributes :: Attributes AddrAttributes
dummyByronAttributes =
      AddrAttributes -> Attributes AddrAttributes
forall h. h -> Attributes h
Byron.mkAttributes
        Byron.AddrAttributes
          { aaVKDerivationPath :: Maybe HDAddressPayload
Byron.aaVKDerivationPath = Maybe HDAddressPayload
forall a. Maybe a
Nothing
          , aaNetworkMagic :: NetworkMagic
Byron.aaNetworkMagic = Word32 -> NetworkMagic
Byron.NetworkTestnet Word32
forall a. Bounded a => a
maxBound
          }

integralToByteStringN :: (Integral i, Bits i) => Int -> i -> ByteString
integralToByteStringN :: forall i. (Integral i, Bits i) => Int -> i -> ByteString
integralToByteStringN Int
len = (ByteString, Maybe i) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, Maybe i) -> ByteString)
-> (i -> (ByteString, Maybe i)) -> i -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (i -> Maybe (Word8, i)) -> i -> (ByteString, Maybe i)
forall a.
Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a)
BS.unfoldrN Int
len (\i
n -> (Word8, i) -> Maybe (Word8, i)
forall a. a -> Maybe a
Just (i -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral i
n, i
n i -> Int -> i
forall a. Bits a => a -> Int -> a
`shiftR` Int
8))

byteStringToNum :: (Bits i, Num i) => ByteString -> i
byteStringToNum :: forall i. (Bits i, Num i) => ByteString -> i
byteStringToNum = (Word8 -> i -> i) -> i -> ByteString -> i
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
BS.foldr (\Word8
w i
i -> i
i i -> Int -> i
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 i -> i -> i
forall a. Num a => a -> a -> a
+ Word8 -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w) i
0

-- | Create dummy witnesses and add them to the transaction
addDummyWitsTx ::
  forall era.
  EraTx era =>
  -- | The current protocol parameters.
  PParams era ->
  -- | The transaction.
  Tx era ->
  -- | The number of key witnesses still to be added to the transaction.
  Int ->
  -- | List of attributes from TxOuts with Byron addresses that are being spent
  [Byron.Attributes Byron.AddrAttributes] ->
  -- | The required minimum fee.
  Tx era
addDummyWitsTx :: forall era.
EraTx era =>
PParams era
-> Tx era -> Int -> [Attributes AddrAttributes] -> Tx era
addDummyWitsTx PParams era
pp Tx era
tx Int
numKeyWits [Attributes AddrAttributes]
byronAttrs =
  Tx era
tx
    Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
    -> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> Tx era -> Identity (Tx era))
-> Set (WitVKey 'Witness) -> Tx era -> Tx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set (WitVKey 'Witness)
dummyKeyWits)
    Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Set BootstrapWitness -> Identity (Set BootstrapWitness))
    -> TxWits era -> Identity (TxWits era))
-> (Set BootstrapWitness -> Identity (Set BootstrapWitness))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set BootstrapWitness -> Identity (Set BootstrapWitness))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set BootstrapWitness)
Lens' (TxWits era) (Set BootstrapWitness)
bootAddrTxWitsL ((Set BootstrapWitness -> Identity (Set BootstrapWitness))
 -> Tx era -> Identity (Tx era))
-> Set BootstrapWitness -> Tx era -> Tx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set BootstrapWitness
dummyByronKeyWits)
  where
    dsign :: Proxy DSIGN
    dsign :: Proxy DSIGN
dsign = Proxy DSIGN
forall {k} (t :: k). Proxy t
Proxy
    version :: Version
version = ProtVer -> Version
pvMajor (PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL)
    -- We need to make sure that dummies are unique, since they'll be placed into a Set
    mkDummy :: [Char] -> Int -> a -> c
mkDummy [Char]
name Int
n =
      (DecoderError -> c) -> (c -> c) -> Either DecoderError c -> c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        (\DecoderError
err -> [Char] -> c
forall a. HasCallStack => [Char] -> a
error ([Char]
"Corrupt Dummy " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DecoderError -> [Char]
forall a. Show a => a -> [Char]
show DecoderError
err))
        c -> c
forall a. a -> a
id
        (Either DecoderError c -> c)
-> (a -> Either DecoderError c) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> ByteString -> Either DecoderError c
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull' Version
version
        (ByteString -> Either DecoderError c)
-> (a -> ByteString) -> a -> Either DecoderError c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> ByteString -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
version
        (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ByteString
forall i. (Integral i, Bits i) => Int -> i -> ByteString
integralToByteStringN Int
n
    vKeySize :: Int
vKeySize = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ Proxy DSIGN -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeVerKeyDSIGN Proxy DSIGN
dsign
    dummyKeys :: [VKey 'Witness]
dummyKeys = (Int -> VKey 'Witness) -> [Int] -> [VKey 'Witness]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Int -> Int -> VKey 'Witness
forall {c} {a}.
(DecCBOR c, Integral a, Bits a) =>
[Char] -> Int -> a -> c
mkDummy [Char]
"VKey" Int
vKeySize) [Int
0 :: Int ..]

    sigSize :: Int
sigSize = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ Proxy DSIGN -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeSigDSIGN Proxy DSIGN
dsign
    dummySig :: SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
dummySig = [Char]
-> Int -> Int -> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
forall {c} {a}.
(DecCBOR c, Integral a, Bits a) =>
[Char] -> Int -> a -> c
mkDummy [Char]
"Signature" Int
sigSize (Int
0 :: Int)
    dummyKeyWits :: Set (WitVKey 'Witness)
dummyKeyWits =
      [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a. Ord a => [a] -> Set a
Set.fromList [VKey 'Witness
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
-> WitVKey 'Witness
forall (kr :: KeyRole).
VKey kr
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody) -> WitVKey kr
WitVKey VKey 'Witness
key SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
dummySig | VKey 'Witness
key <- Int -> [VKey 'Witness] -> [VKey 'Witness]
forall a. Int -> [a] -> [a]
take Int
numKeyWits [VKey 'Witness]
dummyKeys]

    -- ChainCode is always 32 bytes long.
    chainCode :: ChainCode
chainCode = ByteString -> ChainCode
ChainCode (ByteString -> ChainCode) -> ByteString -> ChainCode
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
0

    mkDummyByronKeyWit ::
      VKey 'Witness ->
      Byron.Attributes Byron.AddrAttributes ->
      BootstrapWitness
    mkDummyByronKeyWit :: VKey 'Witness -> Attributes AddrAttributes -> BootstrapWitness
mkDummyByronKeyWit VKey 'Witness
key =
      VKey 'Witness
-> SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
-> ChainCode
-> ByteString
-> BootstrapWitness
BootstrapWitness VKey 'Witness
key SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
dummySig ChainCode
chainCode (ByteString -> BootstrapWitness)
-> (Attributes AddrAttributes -> ByteString)
-> Attributes AddrAttributes
-> BootstrapWitness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Attributes AddrAttributes -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer
    dummyByronKeyWits :: Set BootstrapWitness
dummyByronKeyWits =
      [BootstrapWitness] -> Set BootstrapWitness
forall a. Ord a => [a] -> Set a
Set.fromList ([BootstrapWitness] -> Set BootstrapWitness)
-> [BootstrapWitness] -> Set BootstrapWitness
forall a b. (a -> b) -> a -> b
$ (VKey 'Witness -> Attributes AddrAttributes -> BootstrapWitness)
-> [VKey 'Witness]
-> [Attributes AddrAttributes]
-> [BootstrapWitness]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VKey 'Witness -> Attributes AddrAttributes -> BootstrapWitness
mkDummyByronKeyWit [VKey 'Witness]
dummyKeys [Attributes AddrAttributes]
byronAttrs

-- | Same as `setMinCoinSizedTxOut`, except it doesn't require the size of the
-- TxOut and will recompute it if needed. Initial amount is not important.
setMinCoinTxOut :: EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut :: forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut = (Coin -> Coin -> Bool) -> PParams era -> TxOut era -> TxOut era
forall era.
EraTxOut era =>
(Coin -> Coin -> Bool) -> PParams era -> TxOut era -> TxOut era
setMinCoinTxOutWith Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
(==)

setMinCoinTxOutWith ::
  EraTxOut era =>
  (Coin -> Coin -> Bool) ->
  PParams era ->
  TxOut era ->
  TxOut era
setMinCoinTxOutWith :: forall era.
EraTxOut era =>
(Coin -> Coin -> Bool) -> PParams era -> TxOut era -> TxOut era
setMinCoinTxOutWith Coin -> Coin -> Bool
f PParams era
pp = TxOut era -> TxOut era
go
  where
    go :: TxOut era -> TxOut era
go !TxOut era
txOut =
      let curMinCoin :: Coin
curMinCoin = PParams era -> TxOut era -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pp TxOut era
txOut
          curCoin :: Coin
curCoin = TxOut era
txOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL
       in if Coin
curCoin Coin -> Coin -> Bool
`f` Coin
curMinCoin
            then TxOut era
txOut
            else TxOut era -> TxOut era
go (TxOut era
txOut TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL ((Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era))
-> Coin -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
curMinCoin)

-- | A helpful placeholder to use during development.
boom :: HasCallStack => a
boom :: forall a. HasCallStack => a
boom = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Unimplemented"
{-# WARNING boom "BOOM!" #-}