{-# 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.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 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
    BalancedTxBody TxBodyContent BuildTx era
_ TxBody era
txbody 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 keyWits :: [KeyWitness era]
keyWits = (ShelleyWitnessSigningKey -> KeyWitness era)
-> [ShelleyWitnessSigningKey] -> [KeyWitness era]
forall a b. (a -> b) -> [a] -> [b]
map (ShelleyBasedEra era
-> TxBody era -> ShelleyWitnessSigningKey -> KeyWitness era
forall era.
ShelleyBasedEra era
-> TxBody era -> ShelleyWitnessSigningKey -> KeyWitness era
makeShelleyKeyWitness ShelleyBasedEra era
sbe TxBody era
txbody) [ShelleyWitnessSigningKey]
shelleyWitSigningKeys
    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
$ [KeyWitness era] -> TxBody era -> Tx era
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [KeyWitness era]
keyWits TxBody era
txbody

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