{-# LANGUAGE DataKinds #-}

-- | Convenience transaction construction functions
module Cardano.Api.Convenience.Construction
  ( constructBalancedTx

    -- * Misc
  , TxInsExistError (..)
  , ScriptLockedTxInsError (..)
  , notScriptLockedTxIns
  , renderNotScriptLockedTxInsError
  , renderTxInsExistError
  , txInsExistInUTxO
  )
where

import           Cardano.Api.Address
import           Cardano.Api.Certificate
import           Cardano.Api.Eon.ShelleyBasedEra
import           Cardano.Api.Experimental.Eras
import           Cardano.Api.Experimental.Tx
import           Cardano.Api.Fees
import           Cardano.Api.ProtocolParameters
import           Cardano.Api.Query
import           Cardano.Api.Tx.Body
import           Cardano.Api.Tx.Sign
import           Cardano.Api.Utils

import qualified Cardano.Ledger.Api as L
import qualified Cardano.Ledger.Coin as L
import qualified Cardano.Ledger.Credential as L
import qualified Cardano.Ledger.Keys as L

import           Data.Bifunctor
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import           Data.Set (Set)
import           Data.Text (Text)
import qualified Data.Text as Text
import           GHC.Exts (IsList (..))

-- | Construct a balanced transaction.
-- See Cardano.Api.Convenience.Query.queryStateForBalancedTx for a
-- convenient way of querying the node to get the required arguements
-- for constructBalancedTx.
constructBalancedTx
  :: ()
  => ShelleyBasedEra era
  -> TxBodyContent BuildTx era
  -> AddressInEra era
  -- ^ Change address
  -> Maybe Word
  -- ^ Override key witnesses
  -> UTxO era
  -- ^ Just the transaction inputs, not the entire 'UTxO'.
  -> LedgerProtocolParameters era
  -> LedgerEpochInfo
  -> SystemStart
  -> Set PoolId
  -- ^ The set of registered stake pools
  -> Map.Map StakeCredential L.Coin
  -> Map.Map (L.Credential L.DRepRole L.StandardCrypto) L.Coin
  -> [ShelleyWitnessSigningKey]
  -> Either (TxBodyErrorAutoBalance era) (Tx era)
constructBalancedTx :: forall era.
ShelleyBasedEra era
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> UTxO era
-> LedgerProtocolParameters era
-> LedgerEpochInfo
-> SystemStart
-> Set PoolId
-> Map StakeCredential Coin
-> Map (Credential 'DRepRole StandardCrypto) Coin
-> [ShelleyWitnessSigningKey]
-> Either (TxBodyErrorAutoBalance era) (Tx era)
constructBalancedTx
  ShelleyBasedEra era
sbe
  TxBodyContent BuildTx era
txbodcontent
  AddressInEra era
changeAddr
  Maybe Word
mOverrideWits
  UTxO era
utxo
  LedgerProtocolParameters era
lpp
  LedgerEpochInfo
ledgerEpochInfo
  SystemStart
systemStart
  Set PoolId
stakePools
  Map StakeCredential Coin
stakeDelegDeposits
  Map (Credential 'DRepRole StandardCrypto) Coin
drepDelegDeposits
  [ShelleyWitnessSigningKey]
shelleyWitSigningKeys = do
    Era era
availableEra <- (DeprecatedEra era -> TxBodyErrorAutoBalance era)
-> Either (DeprecatedEra era) (Era era)
-> Either (TxBodyErrorAutoBalance era) (Era era)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DeprecatedEra era -> TxBodyErrorAutoBalance era
forall era. DeprecatedEra era -> TxBodyErrorAutoBalance era
TxBodyErrorDeprecatedEra (Either (DeprecatedEra era) (Era era)
 -> Either (TxBodyErrorAutoBalance era) (Era era))
-> Either (DeprecatedEra era) (Era era)
-> Either (TxBodyErrorAutoBalance era) (Era era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> Either (DeprecatedEra era) (Era era)
forall era (m :: * -> *).
MonadError (DeprecatedEra era) m =>
ShelleyBasedEra era -> m (Era era)
sbeToEra ShelleyBasedEra era
sbe

    BalancedTxBody TxBodyContent BuildTx era
_ UnsignedTx era
unsignedTx TxOut CtxTx era
_txBalanceOutput Coin
_fee <-
      ShelleyBasedEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> Set PoolId
-> Map StakeCredential Coin
-> Map (Credential 'DRepRole StandardCrypto) Coin
-> UTxO era
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> Either (TxBodyErrorAutoBalance era) (BalancedTxBody era)
forall era.
ShelleyBasedEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> Set PoolId
-> Map StakeCredential Coin
-> Map (Credential 'DRepRole StandardCrypto) Coin
-> UTxO era
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> Either (TxBodyErrorAutoBalance era) (BalancedTxBody era)
makeTransactionBodyAutoBalance
        ShelleyBasedEra era
sbe
        SystemStart
systemStart
        LedgerEpochInfo
ledgerEpochInfo
        LedgerProtocolParameters era
lpp
        Set PoolId
stakePools
        Map StakeCredential Coin
stakeDelegDeposits
        Map (Credential 'DRepRole StandardCrypto) Coin
drepDelegDeposits
        UTxO era
utxo
        TxBodyContent BuildTx era
txbodcontent
        AddressInEra era
changeAddr
        Maybe Word
mOverrideWits

    let alternateKeyWits :: [WitVKey 'Witness StandardCrypto]
alternateKeyWits = (ShelleyWitnessSigningKey -> WitVKey 'Witness StandardCrypto)
-> [ShelleyWitnessSigningKey] -> [WitVKey 'Witness StandardCrypto]
forall a b. (a -> b) -> [a] -> [b]
map (Era era
-> UnsignedTx era
-> ShelleyWitnessSigningKey
-> WitVKey 'Witness StandardCrypto
forall era.
Era era
-> UnsignedTx era
-> ShelleyWitnessSigningKey
-> WitVKey 'Witness StandardCrypto
makeKeyWitness Era era
availableEra UnsignedTx era
unsignedTx) [ShelleyWitnessSigningKey]
shelleyWitSigningKeys
        signedTx :: Tx (LedgerEra era)
signedTx = Era era
-> [BootstrapWitness StandardCrypto]
-> [WitVKey 'Witness StandardCrypto]
-> UnsignedTx era
-> Tx (LedgerEra era)
forall era.
Era era
-> [BootstrapWitness StandardCrypto]
-> [WitVKey 'Witness StandardCrypto]
-> UnsignedTx era
-> Tx (LedgerEra era)
signTx Era era
availableEra [] [WitVKey 'Witness StandardCrypto]
alternateKeyWits UnsignedTx era
unsignedTx

    Tx era -> Either (TxBodyErrorAutoBalance era) (Tx era)
forall a. a -> Either (TxBodyErrorAutoBalance era) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tx era -> Either (TxBodyErrorAutoBalance era) (Tx era))
-> Tx era -> Either (TxBodyErrorAutoBalance era) (Tx era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Tx era
forall era.
ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Tx era
ShelleyTx ShelleyBasedEra era
sbe (Tx (ShelleyLedgerEra era) -> Tx era)
-> Tx (ShelleyLedgerEra era) -> Tx era
forall a b. (a -> b) -> a -> b
$ Era era
-> (EraCommonConstraints era => Tx (ShelleyLedgerEra era))
-> Tx (ShelleyLedgerEra era)
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
availableEra Tx (ShelleyLedgerEra era)
Tx (LedgerEra era)
EraCommonConstraints era => Tx (ShelleyLedgerEra era)
signedTx

data TxInsExistError
  = TxInsDoNotExist [TxIn]
  | EmptyUTxO

renderTxInsExistError :: TxInsExistError -> Text
renderTxInsExistError :: TxInsExistError -> Text
renderTxInsExistError TxInsExistError
EmptyUTxO =
  Text
"The UTxO is empty"
renderTxInsExistError (TxInsDoNotExist [TxIn]
txins) =
  Text
"The following tx input(s) were not present in the UTxO: "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
'\n'
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate (Char -> Text
Text.singleton Char
'\n') ((TxIn -> Text) -> [TxIn] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TxIn -> Text
renderTxIn [TxIn]
txins)

txInsExistInUTxO :: [TxIn] -> UTxO era -> Either TxInsExistError ()
txInsExistInUTxO :: forall era. [TxIn] -> UTxO era -> Either TxInsExistError ()
txInsExistInUTxO [TxIn]
ins (UTxO Map TxIn (TxOut CtxUTxO era)
utxo)
  | Map TxIn (TxOut CtxUTxO era) -> Bool
forall a. Map TxIn a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map TxIn (TxOut CtxUTxO era)
utxo = TxInsExistError -> Either TxInsExistError ()
forall a b. a -> Either a b
Left TxInsExistError
EmptyUTxO
  | Bool
otherwise = do
      let utxoIns :: [TxIn]
utxoIns = Map TxIn (TxOut CtxUTxO era) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys Map TxIn (TxOut CtxUTxO era)
utxo
          occursInUtxo :: [TxIn]
occursInUtxo = [TxIn
txin | TxIn
txin <- [TxIn]
ins, TxIn
txin TxIn -> [TxIn] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TxIn]
utxoIns]
      if [TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxIn]
occursInUtxo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxIn]
ins
        then () -> Either TxInsExistError ()
forall a. a -> Either TxInsExistError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else TxInsExistError -> Either TxInsExistError ()
forall a b. a -> Either a b
Left (TxInsExistError -> Either TxInsExistError ())
-> ([TxIn] -> TxInsExistError)
-> [TxIn]
-> Either TxInsExistError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxIn] -> TxInsExistError
TxInsDoNotExist ([TxIn] -> Either TxInsExistError ())
-> [TxIn] -> Either TxInsExistError ()
forall a b. (a -> b) -> a -> b
$ [TxIn]
ins [TxIn] -> [TxIn] -> [TxIn]
forall a. Eq a => [a] -> [a] -> [a]
List.\\ [TxIn]
occursInUtxo

newtype ScriptLockedTxInsError = ScriptLockedTxIns [TxIn]

renderNotScriptLockedTxInsError :: ScriptLockedTxInsError -> Text
renderNotScriptLockedTxInsError :: ScriptLockedTxInsError -> Text
renderNotScriptLockedTxInsError (ScriptLockedTxIns [TxIn]
txins) =
  Text
"The followings tx inputs were expected to be key witnessed but are actually script witnessed: "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
textShow ((TxIn -> Text) -> [TxIn] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TxIn -> Text
renderTxIn [TxIn]
txins)

notScriptLockedTxIns :: [TxIn] -> UTxO era -> Either ScriptLockedTxInsError ()
notScriptLockedTxIns :: forall era. [TxIn] -> UTxO era -> Either ScriptLockedTxInsError ()
notScriptLockedTxIns [TxIn]
collTxIns (UTxO Map TxIn (TxOut CtxUTxO era)
utxo) = do
  let onlyCollateralUTxOs :: Map TxIn (TxOut CtxUTxO era)
onlyCollateralUTxOs = Map TxIn (TxOut CtxUTxO era)
-> Set TxIn -> Map TxIn (TxOut CtxUTxO era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (TxOut CtxUTxO era)
utxo (Set TxIn -> Map TxIn (TxOut CtxUTxO era))
-> Set TxIn -> Map TxIn (TxOut CtxUTxO era)
forall a b. (a -> b) -> a -> b
$ [Item (Set TxIn)] -> Set TxIn
forall l. IsList l => [Item l] -> l
fromList [Item (Set TxIn)]
[TxIn]
collTxIns
      scriptLockedTxIns :: [(TxIn, TxOut CtxUTxO era)]
scriptLockedTxIns =
        ((TxIn, TxOut CtxUTxO era) -> Bool)
-> [(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIn
_, TxOut AddressInEra era
aInEra TxOutValue era
_ TxOutDatum CtxUTxO era
_ ReferenceScript era
_) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ AddressInEra era -> Bool
forall era. AddressInEra era -> Bool
isKeyAddress AddressInEra era
aInEra) ([(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)])
-> [(TxIn, TxOut CtxUTxO era)] -> [(TxIn, TxOut CtxUTxO era)]
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO era) -> [(TxIn, TxOut CtxUTxO era)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map TxIn (TxOut CtxUTxO era)
onlyCollateralUTxOs
  if [(TxIn, TxOut CtxUTxO era)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TxIn, TxOut CtxUTxO era)]
scriptLockedTxIns
    then () -> Either ScriptLockedTxInsError ()
forall a. a -> Either ScriptLockedTxInsError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else ScriptLockedTxInsError -> Either ScriptLockedTxInsError ()
forall a b. a -> Either a b
Left (ScriptLockedTxInsError -> Either ScriptLockedTxInsError ())
-> ([TxIn] -> ScriptLockedTxInsError)
-> [TxIn]
-> Either ScriptLockedTxInsError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxIn] -> ScriptLockedTxInsError
ScriptLockedTxIns ([TxIn] -> Either ScriptLockedTxInsError ())
-> [TxIn] -> Either ScriptLockedTxInsError ()
forall a b. (a -> b) -> a -> b
$ ((TxIn, TxOut CtxUTxO era) -> TxIn)
-> [(TxIn, TxOut CtxUTxO era)] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, TxOut CtxUTxO era) -> TxIn
forall a b. (a, b) -> a
fst [(TxIn, TxOut CtxUTxO era)]
scriptLockedTxIns