Add validity range functions

Author: gege251

src/BotPlutusInterface/CardanoCLI.hs

@@ -12,6 +12,7 @@ module BotPlutusInterface.CardanoCLI (
   validatorScriptFilePath,
   unsafeSerialiseAddress,
   policyScriptFilePath,
+  validateRange,
   utxosAt,
   queryTip,
 ) where
@@ -49,10 +50,17 @@ import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Text.Encoding (decodeUtf8)
+import Ledger (Slot (Slot), SlotRange)
 import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Address (Address (..))
 import Ledger.Crypto (PubKey, PubKeyHash)
+import Ledger.Interval (
+  Extended (Finite, NegInf, PosInf),
+  Interval (Interval),
+  LowerBound (LowerBound),
+  UpperBound (UpperBound),
+ )
 import Ledger.Scripts (Datum, DatumHash (..))
 import Ledger.Scripts qualified as Scripts
 import Ledger.Tx (
@@ -185,9 +193,7 @@ isRawBuildMode :: BuildMode -> Bool
 isRawBuildMode (BuildRaw _) = True
 isRawBuildMode _ = False
 
-{- | Build a tx body and write it to disk
- If a fee if specified, it uses the build-raw command
--}
+-- | Build a tx body and write it to disk
 buildTx ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
@@ -211,6 +217,7 @@ buildTx pabConf ownPkh buildMode tx =
         , txInCollateralOpts (txCollateral tx)
         , txOutOpts pabConf (txData tx) (txOutputs tx)
         , mintOpts pabConf buildMode (txMintScripts tx) (txRedeemers tx) (txMint tx)
+        , validRangeOpts (txValidRange tx)
         , requiredSigners
         , case buildMode of
             BuildRaw fee -> ["--fee", showText fee]
@@ -350,6 +357,20 @@ mintOpts pabConf buildMode mintingPolicies redeemers mintValue =
         else []
     ]
 
+-- | This function does not check if the range is valid, that
+validRangeOpts :: SlotRange -> [Text]
+validRangeOpts (Interval lowerBound upperBound) =
+  mconcat
+    [ case lowerBound of
+        LowerBound (Finite (Slot x)) True -> ["--invalid-hereafter", showText x]
+        LowerBound (Finite (Slot x)) False -> ["--invalid-hereafter", showText (x + 1)]
+        _ -> []
+    , case upperBound of
+        UpperBound (Finite (Slot x)) True -> ["--invalid-before", showText (x + 1)]
+        UpperBound (Finite (Slot x)) False -> ["--invalid-before", showText x]
+        _ -> []
+    ]
+
 txOutOpts :: PABConfig -> Map DatumHash Datum -> [TxOut] -> [Text]
 txOutOpts pabConf datums =
   concatMap
@@ -417,6 +438,14 @@ exBudgetToCliArg (ExBudget (ExCPU steps) (ExMemory memory)) =
 showText :: forall (a :: Type). Show a => a -> Text
 showText = Text.pack . show
 
+validateRange :: SlotRange -> Bool
+validateRange (Interval (LowerBound PosInf _) _) = False
+validateRange (Interval _ (UpperBound NegInf _)) = False
+validateRange (Interval (LowerBound (Finite lowerBound) _) (UpperBound (Finite upperBound) _))
+  | lowerBound >= upperBound = False
+  | otherwise = True
+validateRange _ = True
+
 -- -- TODO: There is some issue with this function, the generated wallet key is incorrect
 -- toWalletKey :: Wallet -> Text
 -- toWalletKey =

src/BotPlutusInterface/PreBalance.hs

@@ -14,6 +14,7 @@ import Control.Monad (foldM, void, zipWithM)
 import Control.Monad.Freer (Eff, Member)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Either (EitherT, hoistEither, newEitherT, runEitherT)
+import Data.Default (Default (def))
 import Data.Either.Combinators (maybeToRight, rightToMaybe)
 import Data.Kind (Type)
 import Data.List (partition, (\\))
@@ -30,6 +31,8 @@ import Ledger.Address (Address (..))
 import Ledger.Constraints.OffChain (UnbalancedTx (..), fromScriptOutput)
 import Ledger.Crypto (PrivateKey, PubKeyHash)
 import Ledger.Scripts (Datum, DatumHash)
+import Ledger.Time (POSIXTimeRange)
+import Ledger.TimeSlot (posixTimeRangeToContainedSlotRange)
 import Ledger.Tx (
   Tx (..),
   TxIn (..),
@@ -64,7 +67,7 @@ preBalanceTxIO pabConf ownPkh unbalancedTx =
       utxos <- lift $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
       privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf
       let utxoIndex = fmap Tx.toTxOut utxos <> fmap (Ledger.toTxOut . fromScriptOutput) (unBalancedTxUtxoIndex unbalancedTx)
-          tx = unBalancedTxTx unbalancedTx
+          tx = addValidRange (unBalancedTxValidityTimeRange unbalancedTx) (unBalancedTxTx unbalancedTx)
           requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx)
 
       lift $ printLog @w Debug $ show utxoIndex
@@ -259,6 +262,10 @@ addSignatories ownPkh privKeys pkhs tx =
     tx
     (ownPkh : pkhs)
 
+addValidRange :: POSIXTimeRange -> Tx -> Tx
+addValidRange timeRange tx =
+  tx {txValidRange = posixTimeRangeToContainedSlotRange def timeRange}
+
 showText :: forall (a :: Type). Show a => a -> Text
 showText = Text.pack . show
 

test/Spec/BotPlutusInterface/Contract.hs

@@ -21,8 +21,10 @@ import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Address qualified as Address
 import Ledger.Constraints qualified as Constraints
+import Ledger.Interval (interval)
 import Ledger.Scripts qualified as Scripts
 import Ledger.Slot (Slot)
+import Ledger.Time (POSIXTime (POSIXTime))
 import Ledger.Tx (CardanoTx, TxOut (TxOut), TxOutRef (TxOutRef))
 import Ledger.Tx qualified as Tx
 import Ledger.TxId qualified as TxId
@@ -78,6 +80,7 @@ tests =
     , testCase "Spend to validator script" spendToValidator
     , testCase "Redeem from validator script" redeemFromValidator
     , testCase "Multiple txs in a contract" multiTx
+    , testCase "With valid range" withValidRange
     , testCase "Use Writer in a contract" useWriter
     , testCase "Wait for next block" waitNextBlock
     ]
@@ -678,6 +681,53 @@ multiTx = do
             ]
     Right _ -> assertFailure "Wrong number of txs"
 
+withValidRange :: Assertion
+withValidRange = do
+  let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0
+      txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing
+      initState = def & utxos .~ [(txOutRef, txOut)]
+      inTxId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txOutRefId txOutRef
+
+      contract :: Contract () (Endpoint "SendAda" ()) Text CardanoTx
+      contract = do
+        let constraints =
+              Constraints.mustPayToPubKey paymentPkh2 (Ada.lovelaceValueOf 1000)
+                <> Constraints.mustValidateIn (interval (POSIXTime 1643636293000) (POSIXTime 1646314693000))
+        submitTx constraints
+
+  assertContractWithTxId contract initState $ \state outTxId ->
+    assertCommandHistory
+      state
+      [
+        ( 2
+        , [text|
+          cardano-cli transaction build-raw --alonzo-era
+          --tx-in ${inTxId}#0
+          --tx-in-collateral ${inTxId}#0
+          --tx-out ${addr2}+1000
+          --invalid-hereafter 47577202
+          --invalid-before 50255602
+          --required-signer ./signing-keys/signing-key-${pkh1'}.skey
+          --fee 0
+          --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw
+          |]
+        )
+      ,
+        ( 6
+        , [text|
+          cardano-cli transaction build --alonzo-era
+          --tx-in ${inTxId}#0
+          --tx-in-collateral ${inTxId}#0
+          --tx-out ${addr2}+1000
+          --invalid-hereafter 47577202
+          --invalid-before 50255602
+          --required-signer ./signing-keys/signing-key-${pkh1'}.skey
+          --change-address ${addr1}
+          --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw
+        |]
+        )
+      ]
+
 useWriter :: Assertion
 useWriter = do
   let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0