SCP-2270: Added time action support in plutus-contract and update plu…

…tus-use-cases examples.
IntersectMBO · Jun 18, 2021 · 81bf0b9 · 81bf0b9
1 parent 5ef6215
commit 81bf0b9
Show file tree

Hide file tree

Showing 71 changed files with 794 additions and 1,388 deletions.
diff --git a/marlowe/src/Language/Marlowe/Client.hs b/marlowe/src/Language/Marlowe/Client.hs
@@ -3,7 +3,6 @@
 {-# LANGUAGE DefaultSignatures     #-}
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
@@ -50,6 +49,7 @@ import           Ledger.Constraints
 import qualified Ledger.Constraints           as Constraints
 import qualified Ledger.Interval              as Interval
 import           Ledger.Scripts               (Validator, datumHash, unitRedeemer)
+import qualified Ledger.TimeSlot              as TimeSlot
 import qualified Ledger.Typed.Scripts         as Scripts
 import           Ledger.Typed.Tx              (TypedScriptTxOut (..), tyTxOutData)
 import qualified Ledger.Value                 as Val
@@ -58,7 +58,7 @@ import           Plutus.Contract.StateMachine (AsSMContractError (..), StateMach
                                                WaitingResult (..), getStates)
 import qualified Plutus.Contract.StateMachine as SM
 import qualified Plutus.Contracts.Currency    as Currency
-import qualified PlutusTx                     as PlutusTx
+import qualified PlutusTx
 import qualified PlutusTx.AssocMap            as AssocMap
 import qualified PlutusTx.Prelude             as P
 
@@ -280,7 +280,7 @@ marlowePlutusContract = do
         maybeState <- SM.getOnChainState theClient
         case maybeState of
             Nothing -> do
-                wr <- SM.waitForUpdateUntil theClient untilSlot
+                wr <- SM.waitForUpdateUntilSlot theClient untilSlot
                 case wr of
                     ContractEnded -> do
                         logInfo @String $ "Contract Ended for party " <> show party
@@ -323,7 +323,7 @@ marlowePlutusContract = do
                 continueWith marloweData
             WaitOtherActionUntil timeout -> do
                 logInfo @String $ "WaitOtherActionUntil " <> show timeout
-                wr <- SM.waitForUpdateUntil theClient timeout
+                wr <- SM.waitForUpdateUntilSlot theClient timeout
                 case wr of
                     ContractEnded -> do
                         logInfo @String $ "Contract Ended"
@@ -527,7 +527,8 @@ mkMarloweStateMachineTransition params SM.State{ SM.stateData=MarloweData{..}, S
                         totalPayouts = P.foldMap (\(Payment _ v) -> v) txOutPayments
                         finalBalance = totalIncome P.- totalPayouts
                         in (outputsConstraints, finalBalance)
-            let range = Interval.interval minSlot maxSlot
+            -- TODO Push this use of time further down the code
+            let range = TimeSlot.slotRangeToPOSIXTimeRange $ Interval.interval minSlot maxSlot
             let constraints = inputsConstraints <> outputsConstraints <> mustValidateIn range
             if preconditionsOk
             then Just (constraints, SM.State marloweData finalBalance)

diff --git a/playground-common/src/PSGenerator/Common.hs b/playground-common/src/PSGenerator/Common.hs
@@ -30,6 +30,7 @@ import           Ledger.Index                              (ScriptType, ScriptVa
 import           Ledger.Interval                           (Extended, Interval, LowerBound, UpperBound)
 import           Ledger.Scripts                            (ScriptError)
 import           Ledger.Slot                               (Slot)
+import           Ledger.Time                               (POSIXTime)
 import           Ledger.Typed.Tx                           (ConnectionError, WrongOutTypeError)
 import           Ledger.Value                              (CurrencySymbol, TokenName, Value)
 import           Playground.Types                          (ContractCall, FunctionSchema, KnownCurrency)
@@ -232,6 +233,7 @@ servantBridge = headersBridge <|> headerBridge
 ledgerTypes :: [SumType 'Haskell]
 ledgerTypes =
     [ (equal <*> (genericShow <*> mkSumType)) (Proxy @Slot)
+    , (equal <*> (genericShow <*> mkSumType)) (Proxy @POSIXTime)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @Ada)
     , (equal <*> (genericShow <*> mkSumType)) (Proxy @Tx)
     , (order <*> (genericShow <*> mkSumType)) (Proxy @TxId)

diff --git a/playground-common/src/Playground/Contract.hs b/playground-common/src/Playground/Contract.hs
@@ -46,7 +46,7 @@ module Playground.Contract
     , modifiesUtxoSet
     , nextTransactionsAt
     , utxoAt
-    , watchAddressUntil
+    , watchAddressUntilSlot
     , submitTx
     , Tx
     , TxOutRef(TxOutRef, txOutRefId)
@@ -70,7 +70,7 @@ import           Playground.TH               (ensureKnownCurrencies, mkFunction,
 import           Playground.Types            (Expression, FunctionSchema, KnownCurrency (KnownCurrency), adaCurrency)
 import           Plutus.Contract             (AsContractError, Contract, Endpoint, awaitSlot, endpoint,
                                               nextTransactionsAt, ownPubKey, submitTx, type (.\/), utxoAt,
-                                              watchAddressUntil)
+                                              watchAddressUntilSlot)
 import           Plutus.Contract.Trace       (TraceError (..))
 import           Schema                      (FormSchema, ToArgument, ToSchema)
 import           Wallet.Emulator.Types       (Wallet (..))

diff --git a/playground-common/src/Schema.hs b/playground-common/src/Schema.hs
@@ -57,8 +57,9 @@ import qualified Data.Text              as Text
 import           Data.UUID              (UUID)
 import           GHC.Generics           (C1, Constructor, D1, Generic, K1 (K1), M1 (M1), Rec0, Rep, S1, Selector, U1,
                                          conIsRecord, conName, from, selName, (:*:) ((:*:)), (:+:) (L1, R1))
-import           Ledger                 (Ada, AssetClass, CurrencySymbol, DatumHash, Interval, PubKey, PubKeyHash,
-                                         RedeemerHash, Signature, Slot, SlotRange, TokenName, ValidatorHash, Value)
+import           Ledger                 (Ada, AssetClass, CurrencySymbol, DatumHash, Interval, POSIXTime,
+                                         POSIXTimeRange, PubKey, PubKeyHash, RedeemerHash, Signature, TokenName,
+                                         ValidatorHash, Value)
 import           Ledger.Bytes           (LedgerBytes)
 import qualified PlutusTx.AssocMap
 import qualified PlutusTx.Prelude       as P
@@ -87,7 +88,7 @@ data FormSchema
     | FormSchemaObject [(String, FormSchema)]
     -- Blessed types that get their own special UI widget.
     | FormSchemaValue
-    | FormSchemaSlotRange
+    | FormSchemaPOSIXTimeRange
     -- Exceptions.
     | FormSchemaUnsupported String
     deriving (Show, Eq, Generic)
@@ -109,7 +110,7 @@ data FormArgumentF a
     | FormTupleF a a
     | FormObjectF [(String, a)]
     | FormValueF Value
-    | FormSlotRangeF (Interval Slot)
+    | FormPOSIXTimeRangeF (Interval POSIXTime)
     | FormUnsupportedF String
     deriving (Show, Generic, Eq, Functor)
     deriving anyclass (ToJSON, FromJSON)
@@ -137,7 +138,7 @@ formArgumentToJson = cata algebra
         JSON.Object . HashMap.fromList . map (first Text.pack) <$>
         traverse sequence vs
     algebra (FormValueF v) = justJSON v
-    algebra (FormSlotRangeF v) = justJSON v
+    algebra (FormPOSIXTimeRangeF v) = justJSON v
     algebra (FormUnsupportedF _) = Nothing
     justJSON ::
            forall a. ToJSON a
@@ -373,8 +374,8 @@ instance ToSchema LedgerBytes where
 instance ToSchema UUID where
     toSchema = toSchema @String
 
-instance ToSchema SlotRange where
-    toSchema = FormSchemaSlotRange
+instance ToSchema POSIXTimeRange where
+    toSchema = FormSchemaPOSIXTimeRange
 
 deriving anyclass instance ToSchema Ada
 
@@ -390,7 +391,7 @@ deriving anyclass instance ToSchema RedeemerHash
 
 deriving anyclass instance ToSchema Signature
 
-deriving anyclass instance ToSchema Slot
+deriving anyclass instance ToSchema POSIXTime
 
 deriving anyclass instance ToSchema TokenName
 

diff --git a/plutus-benchmark/flat/Dataset.hs b/plutus-benchmark/flat/Dataset.hs
@@ -11,10 +11,11 @@ import           Data.Either                       (fromRight)
 import           Data.Text                         (Text)
 
 import qualified Language.Marlowe                  as Marlowe
-import qualified Ledger                            as Ledger
+import qualified Ledger
 import qualified Ledger.Ada                        as Ada
 import           Ledger.Crypto
 import qualified Ledger.Scripts                    as Plutus
+import qualified Ledger.TimeSlot                   as TimeSlot
 import qualified Ledger.Typed.Scripts              as Plutus
 import           Ledger.Value
 import           Plutus.Contract.Trace
@@ -34,7 +35,7 @@ wallet2 = Wallet 2
 escrowParams :: Escrow.EscrowParams d
 escrowParams =
   Escrow.EscrowParams
-    { Escrow.escrowDeadline = 200
+    { Escrow.escrowDeadline = TimeSlot.slotToPOSIXTime 200
     , Escrow.escrowTargets  =
         [ Escrow.payToPubKeyTarget (pubKeyHash $ walletPubKey wallet1)
                                    (Ada.lovelaceValueOf 10)
@@ -47,9 +48,9 @@ vesting :: Vesting.VestingParams
 vesting =
     Vesting.VestingParams
         { Vesting.vestingTranche1 =
-            Vesting.VestingTranche (Ledger.Slot 10) (Ada.lovelaceValueOf 20)
+            Vesting.VestingTranche (TimeSlot.slotToPOSIXTime 10) (Ada.lovelaceValueOf 20)
         , Vesting.vestingTranche2 =
-            Vesting.VestingTranche (Ledger.Slot 20) (Ada.lovelaceValueOf 40)
+            Vesting.VestingTranche (TimeSlot.slotToPOSIXTime 20) (Ada.lovelaceValueOf 40)
         , Vesting.vestingOwner    = Ledger.pubKeyHash $ walletPubKey wallet1 }
 
 -- Future data
@@ -69,7 +70,7 @@ oracleKeys =
 
 theFuture :: Future.Future
 theFuture = Future.Future {
-    Future.ftDeliveryDate  = Ledger.Slot 100,
+    Future.ftDeliveryDate  = TimeSlot.slotToPOSIXTime 100,
     Future.ftUnits         = units,
     Future.ftUnitPrice     = forwardPrice,
     Future.ftInitialMargin = Ada.lovelaceValueOf 800,

diff --git a/plutus-contract/src/Plutus/Contract.hs b/plutus-contract/src/Plutus/Contract.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE ConstraintKinds  #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MonoLocalBinds   #-}
-{-# LANGUAGE TypeOperators    #-}
+{-# LANGUAGE ConstraintKinds    #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE MonoLocalBinds     #-}
 module Plutus.Contract(
       Contract(..)
     , ContractError(..)
@@ -18,6 +18,9 @@ module Plutus.Contract(
     , Request.awaitSlot
     , Request.currentSlot
     , Request.waitNSlots
+    , Request.awaitTime
+    , Request.currentTime
+    , Request.waitNSeconds
     -- * Endpoints
     , Request.HasEndpoint
     , Request.EndpointDescription(..)
@@ -30,7 +33,8 @@ module Plutus.Contract(
     , Wallet.Types.AddressChangeResponse(..)
     , Request.addressChangeRequest
     , Request.nextTransactionsAt
-    , Request.watchAddressUntil
+    , Request.watchAddressUntilSlot
+    , Request.watchAddressUntilTime
     , Request.fundsAtAddressGt
     , Request.fundsAtAddressGeq
     -- * UTXO set
@@ -115,4 +119,3 @@ logError = Contract . L.logError . toJSON
 -- | Update the contract's accumulating state @w@
 tell :: w -> Contract w s e ()
 tell = Contract . W.tell
-
diff --git a/plutus-contract/src/Plutus/Contract/Effects.hs b/plutus-contract/src/Plutus/Contract/Effects.hs
@@ -1,14 +1,15 @@
-{-# LANGUAGE DeriveAnyClass     #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DerivingVia        #-}
-{-# LANGUAGE LambdaCase         #-}
-{-# LANGUAGE NamedFieldPuns     #-}
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DerivingVia       #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     PABReq(..),
     _AwaitSlotReq,
+    _AwaitTimeReq,
     _CurrentSlotReq,
+    _CurrentTimeReq,
     _AwaitTxConfirmedReq,
     _OwnContractInstanceIdReq,
     _SendNotificationReq,
@@ -19,7 +20,9 @@ module Plutus.Contract.Effects( -- TODO: Move to Requests.Internal
     _ExposeEndpointReq,
     PABResp(..),
     _AwaitSlotResp,
+    _AwaitTimeResp,
     _CurrentSlotResp,
+    _CurrentTimeResp,
     _AwaitTxConfirmedResp,
     _OwnContractInstanceIdResp,
     _SendNotificationResp,
@@ -48,14 +51,17 @@ import           Ledger                      (Address, PubKey, Tx, TxId, TxOutTx
 import           Ledger.AddressMap           (UtxoMap)
 import           Ledger.Constraints.OffChain (UnbalancedTx)
 import           Ledger.Slot                 (Slot (..))
+import           Ledger.Time                 (POSIXTime (..))
 import           Wallet.API                  (WalletAPIError)
 import           Wallet.Types                (AddressChangeRequest, AddressChangeResponse, ContractInstanceId,
                                               EndpointDescription, EndpointValue, Notification, NotificationError)
 
 -- | Requests that 'Contract's can make
 data PABReq =
     AwaitSlotReq Slot
+    | AwaitTimeReq POSIXTime
     | CurrentSlotReq
+    | CurrentTimeReq
     | AwaitTxConfirmedReq TxId
     | OwnContractInstanceIdReq
     | SendNotificationReq Notification -- TODO: Delete
@@ -70,7 +76,9 @@ data PABReq =
 instance Pretty PABReq where
   pretty = \case
     AwaitSlotReq s           -> "Await slot:" <+> pretty s
+    AwaitTimeReq s           -> "Await time:" <+> pretty s
     CurrentSlotReq           -> "Current slot"
+    CurrentTimeReq           -> "Current time"
     AwaitTxConfirmedReq txid -> "Await tx confirmed:" <+> pretty txid
     OwnContractInstanceIdReq -> "Own contract instance ID"
     SendNotificationReq noti -> "Send notification:" <+> pretty noti
@@ -83,7 +91,9 @@ instance Pretty PABReq where
 -- | Responses that 'Contract's receive
 data PABResp =
     AwaitSlotResp Slot
+    | AwaitTimeResp POSIXTime
     | CurrentSlotResp Slot
+    | CurrentTimeResp POSIXTime
     | AwaitTxConfirmedResp TxId
     | OwnContractInstanceIdResp ContractInstanceId
     | SendNotificationResp (Maybe NotificationError)
@@ -99,7 +109,9 @@ data PABResp =
 instance Pretty PABResp where
   pretty = \case
     AwaitSlotResp s             -> "Slot:" <+> pretty s
+    AwaitTimeResp s             -> "Time:" <+> pretty s
     CurrentSlotResp s           -> "Current slot:" <+> pretty s
+    CurrentTimeResp s           -> "Current time:" <+> pretty s
     AwaitTxConfirmedResp txid   -> "Tx confirmed:" <+> pretty txid
     OwnContractInstanceIdResp i -> "Own contract instance ID:" <+> pretty i
     SendNotificationResp e      -> "Send notification:" <+> pretty e
@@ -112,7 +124,9 @@ instance Pretty PABResp where
 matches :: PABReq -> PABResp -> Bool
 matches a b = case (a, b) of
   (AwaitSlotReq{}, AwaitSlotResp{})                       -> True
+  (AwaitTimeReq{}, AwaitTimeResp{})                       -> True
   (CurrentSlotReq, CurrentSlotResp{})                     -> True
+  (CurrentTimeReq, CurrentTimeResp{})                     -> True
   (AwaitTxConfirmedReq{}, AwaitTxConfirmedResp{})         -> True
   (OwnContractInstanceIdReq, OwnContractInstanceIdResp{}) -> True
   (SendNotificationReq{}, SendNotificationResp{})         -> True