-----------------------------------------------------------------------------
--
-- Module      :  $Headers
-- Copyright   :  (c) 2021 Brian W Bush
-- License     :  MIT
--
-- Maintainer  :  Brian W Bush <code@functionally.io>
-- Stability   :  Experimental
-- Portability :  Portable
--
-- | Handling transactions.
--
-----------------------------------------------------------------------------


{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}


module Mantra.Transaction (
-- * Transactions
  makeTransaction
, includeFee
-- * Metadata
, readMetadata
-- * Printing
, printUTxO
, printValue
, printValueIO
, summarizeValues
-- * Minting
, makeMinting
, readMinting
) where


import Cardano.Api (AssetId(..), AssetName(..), BuildTx, BuildTxWith(..), Hash, IsCardanoEra(..), IsShelleyBasedEra, KeyWitnessInCtx(..), Lovelace, NetworkId, PaymentKey, PolicyId(..), Quantity(..), ScriptLanguage(..), SimpleScript(..), SimpleScriptV2, SimpleScriptVersion(..), ScriptWitness(..), SlotNo(..), TxAuxScripts(..), TxCertificates(..), TxExtraScriptData(..), TxExtraKeyWitnesses(..), TxFee(..), TxInsCollateral(..), TxMetadata, TxMetadataInEra(..), TxMetadataJsonSchema(..), TxMintValue(..), TxOutDatumHash(..), TxScriptValidity(..), TxUpdateProposal(..), TxValidityLowerBound(..), TxValidityUpperBound(..), TxWithdrawals(..), Value, Witness(..), estimateTransactionFee, filterValue, lovelaceToValue, makeSignedTransaction, makeTransactionBody, metadataFromJson, multiAssetSupportedInEra, negateValue, scriptLanguageSupportedInEra, selectLovelace, serialiseToRawBytesHex, txFeesExplicitInEra, txMetadataSupportedInEra, validityNoUpperBoundSupportedInEra, validityUpperBoundSupportedInEra, valueFromList, valueToList)
import Cardano.Api.Shelley (ProtocolParameters, TxBodyContent(..), TxId(..), TxIn(..), TxOut(..), TxOutValue(..), UTxO(..), protocolParamTxFeeFixed, protocolParamTxFeePerByte)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Mantra.Script (mintingScript)
import Mantra.Types (MantraM, foistMantraEither, foistMantraMaybeIO)

import qualified Data.Aeson            as A  (Value(..), decodeFileStrict)
import qualified Data.ByteString.Char8 as BS (pack, unpack)
import qualified Data.HashMap.Strict   as H  (keys, singleton)
import qualified Data.Map.Strict       as M  (assocs, singleton)
import qualified Data.Text             as T  (pack, unpack)


-- | Make a valid fee.
validFee :: IsCardanoEra era
         => Lovelace  -- ^ The amount of lovelace.
         -> TxFee era -- ^ The fee for the era.
validFee :: Lovelace -> TxFee era
validFee Lovelace
fee =
  (TxFeesImplicitInEra era -> TxFee era)
-> (TxFeesExplicitInEra era -> TxFee era)
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
-> TxFee era
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    TxFeesImplicitInEra era -> TxFee era
forall era. TxFeesImplicitInEra era -> TxFee era
TxFeeImplicit
    (TxFeesExplicitInEra era -> Lovelace -> TxFee era
forall era. TxFeesExplicitInEra era -> Lovelace -> TxFee era
`TxFeeExplicit` Lovelace
fee)
    (Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
 -> TxFee era)
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
-> TxFee era
forall a b. (a -> b) -> a -> b
$ CardanoEra era
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
forall era.
CardanoEra era
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
txFeesExplicitInEra CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra


-- | Make a valid range of slots.
validRange :: IsCardanoEra era
           => Maybe SlotNo                                         -- ^ The upper bound, if any.
           -> (TxValidityLowerBound era, TxValidityUpperBound era) -- ^ The range for the era.
validRange :: Maybe SlotNo
-> (TxValidityLowerBound era, TxValidityUpperBound era)
validRange Maybe SlotNo
Nothing =
  let
    Just ValidityNoUpperBoundSupportedInEra era
supported = CardanoEra era -> Maybe (ValidityNoUpperBoundSupportedInEra era)
forall era.
CardanoEra era -> Maybe (ValidityNoUpperBoundSupportedInEra era)
validityNoUpperBoundSupportedInEra CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra
  in
    (
      TxValidityLowerBound era
forall era. TxValidityLowerBound era
TxValidityNoLowerBound
    , ValidityNoUpperBoundSupportedInEra era -> TxValidityUpperBound era
forall era.
ValidityNoUpperBoundSupportedInEra era -> TxValidityUpperBound era
TxValidityNoUpperBound ValidityNoUpperBoundSupportedInEra era
supported
    )
validRange (Just SlotNo
before) =
  let
    Just ValidityNoUpperBoundSupportedInEra era
notSupported = CardanoEra era -> Maybe (ValidityNoUpperBoundSupportedInEra era)
forall era.
CardanoEra era -> Maybe (ValidityNoUpperBoundSupportedInEra era)
validityNoUpperBoundSupportedInEra CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra
    supported :: Maybe (ValidityUpperBoundSupportedInEra era)
supported = CardanoEra era -> Maybe (ValidityUpperBoundSupportedInEra era)
forall era.
CardanoEra era -> Maybe (ValidityUpperBoundSupportedInEra era)
validityUpperBoundSupportedInEra CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra
  in
    (
      TxValidityLowerBound era
forall era. TxValidityLowerBound era
TxValidityNoLowerBound
    , TxValidityUpperBound era
-> (ValidityUpperBoundSupportedInEra era
    -> TxValidityUpperBound era)
-> Maybe (ValidityUpperBoundSupportedInEra era)
-> TxValidityUpperBound era
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (ValidityNoUpperBoundSupportedInEra era -> TxValidityUpperBound era
forall era.
ValidityNoUpperBoundSupportedInEra era -> TxValidityUpperBound era
TxValidityNoUpperBound ValidityNoUpperBoundSupportedInEra era
notSupported)
        (ValidityUpperBoundSupportedInEra era
-> SlotNo -> TxValidityUpperBound era
forall era.
ValidityUpperBoundSupportedInEra era
-> SlotNo -> TxValidityUpperBound era
`TxValidityUpperBound` SlotNo
before)
        Maybe (ValidityUpperBoundSupportedInEra era)
supported
    )


-- | Make valid metadata.
validMetadata :: IsCardanoEra era
              => Maybe TxMetadata    -- ^ The metadata, if any.
              -> TxMetadataInEra era -- ^ The metadata for the era.
validMetadata :: Maybe TxMetadata -> TxMetadataInEra era
validMetadata Maybe TxMetadata
Nothing = TxMetadataInEra era
forall era. TxMetadataInEra era
TxMetadataNone
validMetadata (Just TxMetadata
metadata) =
  TxMetadataInEra era
-> (TxMetadataSupportedInEra era -> TxMetadataInEra era)
-> Maybe (TxMetadataSupportedInEra era)
-> TxMetadataInEra era
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    TxMetadataInEra era
forall era. TxMetadataInEra era
TxMetadataNone
    (TxMetadataSupportedInEra era -> TxMetadata -> TxMetadataInEra era
forall era.
TxMetadataSupportedInEra era -> TxMetadata -> TxMetadataInEra era
`TxMetadataInEra` TxMetadata
metadata)
    (Maybe (TxMetadataSupportedInEra era) -> TxMetadataInEra era)
-> Maybe (TxMetadataSupportedInEra era) -> TxMetadataInEra era
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> Maybe (TxMetadataSupportedInEra era)
forall era. CardanoEra era -> Maybe (TxMetadataSupportedInEra era)
txMetadataSupportedInEra CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra


validMint :: IsCardanoEra era
          => Maybe (PolicyId, SimpleScript SimpleScriptV2, Value) -- ^ The policy, script, and value, if any.
          -> TxMintValue BuildTx era                              -- ^ The minting for the era.
validMint :: Maybe (PolicyId, SimpleScript SimpleScriptV2, Value)
-> TxMintValue BuildTx era
validMint Maybe (PolicyId, SimpleScript SimpleScriptV2, Value)
Nothing = TxMintValue BuildTx era
forall build era. TxMintValue build era
TxMintNone
validMint (Just (PolicyId
policy, SimpleScript SimpleScriptV2
script, Value
value)) =
  case (CardanoEra era
-> Either
     (OnlyAdaSupportedInEra era) (MultiAssetSupportedInEra era)
forall era.
CardanoEra era
-> Either
     (OnlyAdaSupportedInEra era) (MultiAssetSupportedInEra era)
multiAssetSupportedInEra CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra, CardanoEra era
-> ScriptLanguage SimpleScriptV2
-> Maybe (ScriptLanguageInEra SimpleScriptV2 era)
forall era lang.
CardanoEra era
-> ScriptLanguage lang -> Maybe (ScriptLanguageInEra lang era)
scriptLanguageSupportedInEra CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra (SimpleScriptVersion SimpleScriptV2 -> ScriptLanguage SimpleScriptV2
forall lang. SimpleScriptVersion lang -> ScriptLanguage lang
SimpleScriptLanguage SimpleScriptVersion SimpleScriptV2
SimpleScriptV2)) of
    (Right MultiAssetSupportedInEra era
supportedMultiAsset, Just ScriptLanguageInEra SimpleScriptV2 era
supportedScript) -> MultiAssetSupportedInEra era
-> Value
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint era))
-> TxMintValue BuildTx era
forall era build.
MultiAssetSupportedInEra era
-> Value
-> BuildTxWith build (Map PolicyId (ScriptWitness WitCtxMint era))
-> TxMintValue build era
TxMintValue MultiAssetSupportedInEra era
supportedMultiAsset Value
value
                                                           (BuildTxWith BuildTx (Map PolicyId (ScriptWitness WitCtxMint era))
 -> TxMintValue BuildTx era)
-> (ScriptWitness WitCtxMint era
    -> BuildTxWith
         BuildTx (Map PolicyId (ScriptWitness WitCtxMint era)))
-> ScriptWitness WitCtxMint era
-> TxMintValue BuildTx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PolicyId (ScriptWitness WitCtxMint era)
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint era))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith
                                                           (Map PolicyId (ScriptWitness WitCtxMint era)
 -> BuildTxWith
      BuildTx (Map PolicyId (ScriptWitness WitCtxMint era)))
-> (ScriptWitness WitCtxMint era
    -> Map PolicyId (ScriptWitness WitCtxMint era))
-> ScriptWitness WitCtxMint era
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolicyId
-> ScriptWitness WitCtxMint era
-> Map PolicyId (ScriptWitness WitCtxMint era)
forall k a. k -> a -> Map k a
M.singleton PolicyId
policy
                                                           (ScriptWitness WitCtxMint era -> TxMintValue BuildTx era)
-> ScriptWitness WitCtxMint era -> TxMintValue BuildTx era
forall a b. (a -> b) -> a -> b
$ ScriptLanguageInEra SimpleScriptV2 era
-> SimpleScriptVersion SimpleScriptV2
-> SimpleScript SimpleScriptV2
-> ScriptWitness WitCtxMint era
forall lang era witctx.
ScriptLanguageInEra lang era
-> SimpleScriptVersion lang
-> SimpleScript lang
-> ScriptWitness witctx era
SimpleScriptWitness ScriptLanguageInEra SimpleScriptV2 era
supportedScript SimpleScriptVersion SimpleScriptV2
SimpleScriptV2 SimpleScript SimpleScriptV2
script
    (Either (OnlyAdaSupportedInEra era) (MultiAssetSupportedInEra era),
 Maybe (ScriptLanguageInEra SimpleScriptV2 era))
_                                                 -> TxMintValue BuildTx era
forall build era. TxMintValue build era
TxMintNone


-- | Build a transaction.
makeTransaction :: IsCardanoEra era
                => [TxIn]                                               -- ^ The UTxOs to be spent.
                -> [TxOut era]                                          -- ^ The output UTxOs.
                -> Maybe SlotNo                                         -- ^ The latest slot for the transaction.
                -> Maybe TxMetadata                                     -- ^ The metadata.
                -> Maybe (PolicyId, SimpleScript SimpleScriptV2, Value) -- ^ The value to be minted.
                -> TxBodyContent BuildTx era                            -- ^ Action for building the transaction.
makeTransaction :: [TxIn]
-> [TxOut era]
-> Maybe SlotNo
-> Maybe TxMetadata
-> Maybe (PolicyId, SimpleScript SimpleScriptV2, Value)
-> TxBodyContent BuildTx era
makeTransaction [TxIn]
txIns' [TxOut era]
txOuts Maybe SlotNo
before Maybe TxMetadata
metadata Maybe (PolicyId, SimpleScript SimpleScriptV2, Value)
minting =
  let
    txIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
txIns             = (, Witness WitCtxTxIn era
-> BuildTxWith BuildTx (Witness WitCtxTxIn era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn era))
-> Witness WitCtxTxIn era
-> BuildTxWith BuildTx (Witness WitCtxTxIn era)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn era
forall witctx era. KeyWitnessInCtx witctx -> Witness witctx era
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending) (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)))
-> [TxIn] -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxIn]
txIns'
    txInsCollateral :: TxInsCollateral era
txInsCollateral   = TxInsCollateral era
forall era. TxInsCollateral era
TxInsCollateralNone
    txFee :: TxFee era
txFee             = Lovelace -> TxFee era
forall era. IsCardanoEra era => Lovelace -> TxFee era
validFee Lovelace
0
    txValidityRange :: (TxValidityLowerBound era, TxValidityUpperBound era)
txValidityRange   = Maybe SlotNo
-> (TxValidityLowerBound era, TxValidityUpperBound era)
forall era.
IsCardanoEra era =>
Maybe SlotNo
-> (TxValidityLowerBound era, TxValidityUpperBound era)
validRange Maybe SlotNo
before
    txMetadata :: TxMetadataInEra era
txMetadata        = Maybe TxMetadata -> TxMetadataInEra era
forall era.
IsCardanoEra era =>
Maybe TxMetadata -> TxMetadataInEra era
validMetadata Maybe TxMetadata
metadata
    txAuxScripts :: TxAuxScripts era
txAuxScripts      = TxAuxScripts era
forall era. TxAuxScripts era
TxAuxScriptsNone
    txExtraScriptData :: BuildTxWith BuildTx (TxExtraScriptData era)
txExtraScriptData = TxExtraScriptData era
-> BuildTxWith BuildTx (TxExtraScriptData era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith TxExtraScriptData era
forall era. TxExtraScriptData era
TxExtraScriptDataNone
    txExtraKeyWits :: TxExtraKeyWitnesses era
txExtraKeyWits    = TxExtraKeyWitnesses era
forall era. TxExtraKeyWitnesses era
TxExtraKeyWitnessesNone
    txProtocolParams :: BuildTxWith BuildTx (Maybe a)
txProtocolParams  = Maybe a -> BuildTxWith BuildTx (Maybe a)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith Maybe a
forall a. Maybe a
Nothing
    txWithdrawals :: TxWithdrawals build era
txWithdrawals     = TxWithdrawals build era
forall build era. TxWithdrawals build era
TxWithdrawalsNone
    txCertificates :: TxCertificates build era
txCertificates    = TxCertificates build era
forall build era. TxCertificates build era
TxCertificatesNone
    txUpdateProposal :: TxUpdateProposal era
txUpdateProposal  = TxUpdateProposal era
forall era. TxUpdateProposal era
TxUpdateProposalNone
    txMintValue :: TxMintValue BuildTx era
txMintValue       = Maybe (PolicyId, SimpleScript SimpleScriptV2, Value)
-> TxMintValue BuildTx era
forall era.
IsCardanoEra era =>
Maybe (PolicyId, SimpleScript SimpleScriptV2, Value)
-> TxMintValue BuildTx era
validMint Maybe (PolicyId, SimpleScript SimpleScriptV2, Value)
minting
    txScriptValidity :: TxScriptValidity era
txScriptValidity  = TxScriptValidity era
forall era. TxScriptValidity era
TxScriptValidityNone
  in
    TxBodyContent :: forall build era.
TxIns build era
-> TxInsCollateral era
-> [TxOut era]
-> TxFee era
-> (TxValidityLowerBound era, TxValidityUpperBound era)
-> TxMetadataInEra era
-> TxAuxScripts era
-> BuildTxWith build (TxExtraScriptData era)
-> TxExtraKeyWitnesses era
-> BuildTxWith build (Maybe ProtocolParameters)
-> TxWithdrawals build era
-> TxCertificates build era
-> TxUpdateProposal era
-> TxMintValue build era
-> TxScriptValidity era
-> TxBodyContent build era
TxBodyContent{[(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
[TxOut era]
(TxValidityLowerBound era, TxValidityUpperBound era)
BuildTxWith BuildTx (Maybe ProtocolParameters)
BuildTxWith BuildTx (TxExtraScriptData era)
TxAuxScripts era
TxCertificates BuildTx era
TxExtraKeyWitnesses era
TxFee era
TxInsCollateral era
TxMetadataInEra era
TxMintValue BuildTx era
TxScriptValidity era
TxUpdateProposal era
TxWithdrawals BuildTx era
forall a. BuildTxWith BuildTx (Maybe a)
forall era. BuildTxWith BuildTx (TxExtraScriptData era)
forall era. TxAuxScripts era
forall era. TxExtraKeyWitnesses era
forall era. TxInsCollateral era
forall era. TxScriptValidity era
forall era. TxUpdateProposal era
forall build era. TxCertificates build era
forall build era. TxWithdrawals build era
txWithdrawals :: TxWithdrawals BuildTx era
txValidityRange :: (TxValidityLowerBound era, TxValidityUpperBound era)
txUpdateProposal :: TxUpdateProposal era
txScriptValidity :: TxScriptValidity era
txProtocolParams :: BuildTxWith BuildTx (Maybe ProtocolParameters)
txOuts :: [TxOut era]
txMintValue :: TxMintValue BuildTx era
txMetadata :: TxMetadataInEra era
txInsCollateral :: TxInsCollateral era
txIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
txFee :: TxFee era
txExtraScriptData :: BuildTxWith BuildTx (TxExtraScriptData era)
txExtraKeyWits :: TxExtraKeyWitnesses era
txCertificates :: TxCertificates BuildTx era
txAuxScripts :: TxAuxScripts era
txScriptValidity :: forall era. TxScriptValidity era
txMintValue :: TxMintValue BuildTx era
txUpdateProposal :: forall era. TxUpdateProposal era
txCertificates :: forall build era. TxCertificates build era
txWithdrawals :: forall build era. TxWithdrawals build era
txProtocolParams :: forall a. BuildTxWith BuildTx (Maybe a)
txExtraKeyWits :: forall era. TxExtraKeyWitnesses era
txExtraScriptData :: forall era. BuildTxWith BuildTx (TxExtraScriptData era)
txAuxScripts :: forall era. TxAuxScripts era
txMetadata :: TxMetadataInEra era
txValidityRange :: (TxValidityLowerBound era, TxValidityUpperBound era)
txFee :: TxFee era
txInsCollateral :: forall era. TxInsCollateral era
txIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
txOuts :: [TxOut era]
..}


-- | Include the fee in a transaction.
includeFee :: IsShelleyBasedEra era
           => MonadFail m
           => MonadIO m
           => NetworkId                             -- ^ The network.
           -> ProtocolParameters                    -- ^ The protocol parameters.
           -> Int                                   -- ^ The number of inputs.
           -> Int                                   -- ^ The number of outputs.
           -> Int                                   -- ^ The number of Shelley witnesses.
           -> Int                                   -- ^ The number of Byron witnesses.
           -> TxBodyContent BuildTx era             -- ^ The transaction body.
           -> MantraM m (TxBodyContent BuildTx era) -- ^ Action for the transaction body with fee included.
includeFee :: NetworkId
-> ProtocolParameters
-> Int
-> Int
-> Int
-> Int
-> TxBodyContent BuildTx era
-> MantraM m (TxBodyContent BuildTx era)
includeFee NetworkId
network ProtocolParameters
pparams Int
nIn Int
nOut Int
nShelley Int
nByron TxBodyContent BuildTx era
content =
  do
    TxBody era
body <- Either TxBodyError (TxBody era) -> MantraM m (TxBody era)
forall (m :: * -> *) e a.
(Monad m, Show e) =>
Either e a -> MantraM m a
foistMantraEither (Either TxBodyError (TxBody era) -> MantraM m (TxBody era))
-> Either TxBodyError (TxBody era) -> MantraM m (TxBody era)
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
makeTransactionBody TxBodyContent BuildTx era
content
    let
      tx :: Tx era
tx = [KeyWitness era] -> TxBody era -> Tx era
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] TxBody era
body
      lovelace :: Lovelace
lovelace = NetworkId
-> Natural
-> Natural
-> Tx era
-> Int
-> Int
-> Int
-> Int
-> Lovelace
forall era.
IsShelleyBasedEra era =>
NetworkId
-> Natural
-> Natural
-> Tx era
-> Int
-> Int
-> Int
-> Int
-> Lovelace
estimateTransactionFee
        NetworkId
network
        (ProtocolParameters -> Natural
protocolParamTxFeeFixed   ProtocolParameters
pparams)
        (ProtocolParameters -> Natural
protocolParamTxFeePerByte ProtocolParameters
pparams)
        Tx era
tx
        Int
nIn Int
nOut Int
nShelley Int
nByron
    [TxOut AddressInEra era
addr (TxOutValue MultiAssetSupportedInEra era
s Value
value) TxOutDatumHash era
_] <- [TxOut era] -> MantraM m [TxOut era]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxOut era] -> MantraM m [TxOut era])
-> [TxOut era] -> MantraM m [TxOut era]
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx era -> [TxOut era]
forall build era. TxBodyContent build era -> [TxOut era]
txOuts TxBodyContent BuildTx era
content
    let
      fee :: Value
fee = Value -> Value
negateValue (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Lovelace -> Value
lovelaceToValue Lovelace
lovelace
    TxBodyContent BuildTx era -> MantraM m (TxBodyContent BuildTx era)
forall (m :: * -> *) a. Monad m => a -> m a
return
      (TxBodyContent BuildTx era
 -> MantraM m (TxBodyContent BuildTx era))
-> TxBodyContent BuildTx era
-> MantraM m (TxBodyContent BuildTx era)
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx era
content
        {
          txFee :: TxFee era
txFee  = Lovelace -> TxFee era
forall era. IsCardanoEra era => Lovelace -> TxFee era
validFee Lovelace
lovelace
        , txOuts :: [TxOut era]
txOuts = [AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut era
forall era.
AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut era
TxOut AddressInEra era
addr (MultiAssetSupportedInEra era -> Value -> TxOutValue era
forall era. MultiAssetSupportedInEra era -> Value -> TxOutValue era
TxOutValue MultiAssetSupportedInEra era
s (Value -> TxOutValue era) -> Value -> TxOutValue era
forall a b. (a -> b) -> a -> b
$ Value
value Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
fee) TxOutDatumHash era
forall era. TxOutDatumHash era
TxOutDatumHashNone]
        }


-- | Read JSON metadata from a file.
readMetadata' :: MonadIO m
              => FilePath                        -- ^ Path to the metadata file.
              -> MantraM m (A.Value, TxMetadata) -- ^ Action for reading the file as JSON and metadata.
readMetadata' :: FilePath -> MantraM m (Value, TxMetadata)
readMetadata' FilePath
filename =
  do
    Value
json <-
      FilePath -> IO (Maybe Value) -> MantraM m Value
forall (m :: * -> *) a.
MonadIO m =>
FilePath -> IO (Maybe a) -> MantraM m a
foistMantraMaybeIO FilePath
"Could not decode metadata."
        (IO (Maybe Value) -> MantraM m Value)
-> IO (Maybe Value) -> MantraM m Value
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe Value)
forall a. FromJSON a => FilePath -> IO (Maybe a)
A.decodeFileStrict FilePath
filename
    TxMetadata
metadata <-
      Either TxMetadataJsonError TxMetadata -> MantraM m TxMetadata
forall (m :: * -> *) e a.
(Monad m, Show e) =>
Either e a -> MantraM m a
foistMantraEither
        (Either TxMetadataJsonError TxMetadata -> MantraM m TxMetadata)
-> Either TxMetadataJsonError TxMetadata -> MantraM m TxMetadata
forall a b. (a -> b) -> a -> b
$ TxMetadataJsonSchema
-> Value -> Either TxMetadataJsonError TxMetadata
metadataFromJson TxMetadataJsonSchema
TxMetadataJsonNoSchema Value
json
    (Value, TxMetadata) -> MantraM m (Value, TxMetadata)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
json, TxMetadata
metadata)


-- | Read JSON metadata from a file.
readMetadata :: MonadIO m
             => FilePath             -- ^ Path to the metadata file.
             -> MantraM m TxMetadata -- ^ Action for reading the file as metadata.
readMetadata :: FilePath -> MantraM m TxMetadata
readMetadata = ((Value, TxMetadata) -> TxMetadata)
-> MantraM m (Value, TxMetadata) -> MantraM m TxMetadata
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value, TxMetadata) -> TxMetadata
forall a b. (a, b) -> b
snd (MantraM m (Value, TxMetadata) -> MantraM m TxMetadata)
-> (FilePath -> MantraM m (Value, TxMetadata))
-> FilePath
-> MantraM m TxMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> MantraM m (Value, TxMetadata)
forall (m :: * -> *).
MonadIO m =>
FilePath -> MantraM m (Value, TxMetadata)
readMetadata'


-- | Print information about a UTxO.
printUTxO :: MonadIO m
          => String       -- ^ How much to indent the output.
          -> UTxO era     -- ^ The UTxO.
          -> MantraM m () -- ^ Action to print the information.
printUTxO :: FilePath -> UTxO era -> MantraM m ()
printUTxO FilePath
indent (UTxO Map TxIn (TxOut era)
utxoMap) =
  [MantraM m ()] -> MantraM m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
    [
      do
        IO () -> MantraM m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO () -> MantraM m ())
-> (FilePath -> IO ()) -> FilePath -> MantraM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
putStrLn
          (FilePath -> MantraM m ()) -> FilePath -> MantraM m ()
forall a b. (a -> b) -> a -> b
$ FilePath
indent FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Transaction: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Hash Blake2b_256 EraIndependentTxBody -> FilePath
forall a. Show a => a -> FilePath
show' Hash StandardCrypto EraIndependentTxBody
Hash Blake2b_256 EraIndependentTxBody
txhash  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"#" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TxIx -> FilePath
forall a. Show a => a -> FilePath
show TxIx
txin
        FilePath -> Value -> MantraM m ()
forall (m :: * -> *).
MonadIO m =>
FilePath -> Value -> MantraM m ()
printValue (FilePath
indent FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"  ") Value
value'
    |
      (TxIn (TxId Hash StandardCrypto EraIndependentTxBody
txhash) TxIx
txin, TxOut AddressInEra era
_ (TxOutValue MultiAssetSupportedInEra era
_ Value
value') TxOutDatumHash era
_) <- Map TxIn (TxOut era) -> [(TxIn, TxOut era)]
forall k a. Map k a -> [(k, a)]
M.assocs Map TxIn (TxOut era)
utxoMap
    ]


-- | Print a value.
printValue :: MonadIO m
           => String       -- ^ How much to indent the output.
           -> Value        -- ^ The value.
           -> MantraM m () -- ^ Action to print the information.
printValue :: FilePath -> Value -> MantraM m ()
printValue = (IO () -> MantraM m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MantraM m ())
-> (Value -> IO ()) -> Value -> MantraM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Value -> IO ()) -> Value -> MantraM m ())
-> (FilePath -> Value -> IO ())
-> FilePath
-> Value
-> MantraM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Value -> IO ()
printValueIO


-- | Print a value.
printValueIO :: String
             -> Value -- ^ The value.
             -> IO () -- ^ Action to print the information.
printValueIO :: FilePath -> Value -> IO ()
printValueIO FilePath
indent Value
value =
  do
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
indent FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Lovelace -> FilePath
forall a. Show a => a -> FilePath
show (Value -> Lovelace
selectLovelace Value
value)
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [
        FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
indent FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Quantity -> FilePath
forall a. Show a => a -> FilePath
show Quantity
quantity FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"  " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ScriptHash -> FilePath
forall a. Show a => a -> FilePath
show' ScriptHash
policy FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show' ByteString
asset
      |
        (AssetId (PolicyId ScriptHash
policy) (AssetName ByteString
asset), Quantity
quantity) <- Value -> [(AssetId, Quantity)]
valueToList (Value -> [(AssetId, Quantity)]) -> Value -> [(AssetId, Quantity)]
forall a b. (a -> b) -> a -> b
$ (AssetId -> Bool) -> Value -> Value
filterValue (AssetId -> AssetId -> Bool
forall a. Eq a => a -> a -> Bool
/= AssetId
AdaAssetId) Value
value
      ]


-- | Strip a leading and trailing quotation mark when showing a string.
show' :: Show a
      => a      -- ^ The value.
      -> String -- ^ The string represenation.
show' :: a -> FilePath
show' = FilePath -> FilePath
forall a. [a] -> [a]
init (FilePath -> FilePath) -> (a -> FilePath) -> a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall a. [a] -> [a]
tail (FilePath -> FilePath) -> (a -> FilePath) -> a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show


-- | Summarize the values in a UTxO.
summarizeValues :: UTxO era     -- ^ The UTxO.
                -> (Int, Value) -- ^ The number of values and their total.
summarizeValues :: UTxO era -> (Int, Value)
summarizeValues (UTxO Map TxIn (TxOut era)
utxoMap) =
  let
    values :: [Value]
values =
      [
        Value
value'
      |
        (TxIn
_, TxOut AddressInEra era
_ (TxOutValue MultiAssetSupportedInEra era
_ Value
value') TxOutDatumHash era
_) <- Map TxIn (TxOut era) -> [(TxIn, TxOut era)]
forall k a. Map k a -> [(k, a)]
M.assocs Map TxIn (TxOut era)
utxoMap
      ]
  in
    ([Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
values, [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat [Value]
values)


-- | Prepare a minting script.
makeMinting :: Value                               -- ^ The value to which minting will be added.
            -> String                              -- ^ The asset name.
            -> Integer                             -- ^ The number of tokens to omit.
            -> Hash PaymentKey                     -- ^ Hash of the payment key.
            -> Maybe SlotNo                        -- ^ The last slot number for minting.
            -> ((PolicyId, SimpleScript SimpleScriptV2, Value), Value) -- ^ The minting script, value minted, and total value.
makeMinting :: Value
-> FilePath
-> Integer
-> Hash PaymentKey
-> Maybe SlotNo
-> ((PolicyId, SimpleScript SimpleScriptV2, Value), Value)
makeMinting Value
value FilePath
name Integer
count Hash PaymentKey
verification Maybe SlotNo
before =
  let
    (SimpleScript SimpleScriptV2
script, ScriptHash
scriptHash) = Hash PaymentKey
-> Maybe SlotNo -> (SimpleScript SimpleScriptV2, ScriptHash)
mintingScript Hash PaymentKey
verification Maybe SlotNo
before
    minting :: Value
minting = [(AssetId, Quantity)] -> Value
valueFromList
      [(
        PolicyId -> AssetName -> AssetId
AssetId (ScriptHash -> PolicyId
PolicyId ScriptHash
scriptHash) (ByteString -> AssetName
AssetName (ByteString -> AssetName) -> ByteString -> AssetName
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
BS.pack FilePath
name)
      , Integer -> Quantity
Quantity Integer
count
      )]
  in
    (
      (ScriptHash -> PolicyId
PolicyId ScriptHash
scriptHash, SimpleScript SimpleScriptV2
script, Value
minting)
    , Value
value Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
minting
    )


-- | Prepare for minting from a JSON file specifying NFTs.
readMinting :: MonadFail m
            => MonadIO m
            => PolicyId                               -- ^ The policy ID.
            -> FilePath                               -- ^ Path to the metadata file.
            -> MantraM m (A.Value, TxMetadata, Value) -- ^ Action reading the metadata file and returning the JSON, metadata, and value for minting.
readMinting :: PolicyId -> FilePath -> MantraM m (Value, TxMetadata, Value)
readMinting PolicyId
policyId FilePath
filename =
  do
    A.Object Object
json <-
      FilePath -> IO (Maybe Value) -> MantraM m Value
forall (m :: * -> *) a.
MonadIO m =>
FilePath -> IO (Maybe a) -> MantraM m a
foistMantraMaybeIO FilePath
"Could not decode metadata."
        (IO (Maybe Value) -> MantraM m Value)
-> IO (Maybe Value) -> MantraM m Value
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe Value)
forall a. FromJSON a => FilePath -> IO (Maybe a)
A.decodeFileStrict FilePath
filename
    let
      json' :: Value
json' =
        Object -> Value
A.Object
        (Object -> Value) -> (Object -> Object) -> Object -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
H.singleton Text
"721"
        (Value -> Object) -> (Object -> Value) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
A.Object
        (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
H.singleton
          (FilePath -> Text
T.pack (FilePath -> Text)
-> (ByteString -> FilePath) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BS.unpack (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ PolicyId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex PolicyId
policyId)
          (Object -> Value
A.Object Object
json)
      minting :: Value
minting =
        [(AssetId, Quantity)] -> Value
valueFromList
          [
            (
              PolicyId -> AssetName -> AssetId
AssetId PolicyId
policyId (AssetName -> AssetId)
-> (FilePath -> AssetName) -> FilePath -> AssetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> AssetName
AssetName (ByteString -> AssetName)
-> (FilePath -> ByteString) -> FilePath -> AssetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
BS.pack (FilePath -> AssetId) -> FilePath -> AssetId
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
name
            , Integer -> Quantity
Quantity Integer
1
            )
          |
            Text
name <- Object -> [Text]
forall k v. HashMap k v -> [k]
H.keys Object
json
          ]
    TxMetadata
metadata <-
      Either TxMetadataJsonError TxMetadata -> MantraM m TxMetadata
forall (m :: * -> *) e a.
(Monad m, Show e) =>
Either e a -> MantraM m a
foistMantraEither
        (Either TxMetadataJsonError TxMetadata -> MantraM m TxMetadata)
-> Either TxMetadataJsonError TxMetadata -> MantraM m TxMetadata
forall a b. (a -> b) -> a -> b
$ TxMetadataJsonSchema
-> Value -> Either TxMetadataJsonError TxMetadata
metadataFromJson TxMetadataJsonSchema
TxMetadataJsonNoSchema Value
json'
    (Value, TxMetadata, Value) -> MantraM m (Value, TxMetadata, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
json', TxMetadata
metadata, Value
minting)