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

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

  ) where

import           Prelude

import qualified Data.List as List
import qualified Data.Map.Strict as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Text (Text)
import qualified Data.Text as Text

import           Cardano.Api.Address
import           Cardano.Api.Certificate
import           Cardano.Api.Eras
import           Cardano.Api.Fees
import           Cardano.Api.IPC
import           Cardano.Api.Modes
import           Cardano.Api.ProtocolParameters
import           Cardano.Api.Query
import           Cardano.Api.Tx
import           Cardano.Api.TxBody
import           Cardano.Api.Utils

-- | 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
  :: IsShelleyBasedEra era
  => EraInMode era CardanoMode
  -> TxBodyContent BuildTx era
  -> AddressInEra era -- ^ Change address
  -> Maybe Word       -- ^ Override key witnesses
  -> UTxO era         -- ^ Just the transaction inputs, not the entire 'UTxO'.
  -> ProtocolParameters
  -> EraHistory CardanoMode
  -> SystemStart
  -> Set PoolId       -- ^ The set of registered stake pools
  -> [ShelleyWitnessSigningKey]
  -> Either TxBodyErrorAutoBalance (Tx era)
constructBalancedTx :: EraInMode era CardanoMode
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> UTxO era
-> ProtocolParameters
-> EraHistory CardanoMode
-> SystemStart
-> Set PoolId
-> [ShelleyWitnessSigningKey]
-> Either TxBodyErrorAutoBalance (Tx era)
constructBalancedTx EraInMode era CardanoMode
eInMode TxBodyContent BuildTx era
txbodcontent AddressInEra era
changeAddr Maybe Word
mOverrideWits UTxO era
utxo ProtocolParameters
pparams
                    EraHistory CardanoMode
eraHistory SystemStart
systemStart Set PoolId
stakePools [ShelleyWitnessSigningKey]
shelleyWitSigningKeys = do
  BalancedTxBody TxBody era
txbody TxOut CtxTx era
_txBalanceOutput Lovelace
_fee
    <- EraInMode era CardanoMode
-> SystemStart
-> EraHistory CardanoMode
-> ProtocolParameters
-> Set PoolId
-> UTxO era
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> Either TxBodyErrorAutoBalance (BalancedTxBody era)
forall era mode.
IsShelleyBasedEra era =>
EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> Set PoolId
-> UTxO era
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> Either TxBodyErrorAutoBalance (BalancedTxBody era)
makeTransactionBodyAutoBalance
         EraInMode era CardanoMode
eInMode SystemStart
systemStart EraHistory CardanoMode
eraHistory
         ProtocolParameters
pparams Set PoolId
stakePools 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 (TxBody era -> ShelleyWitnessSigningKey -> KeyWitness era
forall era.
IsShelleyBasedEra era =>
TxBody era -> ShelleyWitnessSigningKey -> KeyWitness era
makeShelleyKeyWitness TxBody era
txbody) [ShelleyWitnessSigningKey]
shelleyWitSigningKeys
  Tx era -> Either TxBodyErrorAutoBalance (Tx era)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tx era -> Either TxBodyErrorAutoBalance (Tx era))
-> Tx era -> Either TxBodyErrorAutoBalance (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 :: [TxIn] -> UTxO era -> Either TxInsExistError ()
txInsExistInUTxO [TxIn]
ins (UTxO Map TxIn (TxOut CtxUTxO era)
utxo)
  | Map TxIn (TxOut CtxUTxO era) -> 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TxIn]
utxoIns ]
      if [TxIn] -> 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 (t :: * -> *) a. Foldable t => t a -> Int
length [TxIn]
ins
      then () -> Either TxInsExistError ()
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 :: [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
$ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [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 (t :: * -> *) a. Foldable t => t a -> Bool
null [(TxIn, TxOut CtxUTxO era)]
scriptLockedTxIns
  then () -> Either ScriptLockedTxInsError ()
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