Merge pull request #3197 from input-output-hk/scp-2214-switch-slot-to…

…-time

SCP-2214 Switch to POSIXTime instead of Slot in TxInfo

plutus-ledger-api/plutus-ledger-api.cabal

@@ -52,6 +52,7 @@ library
         Plutus.V1.Ledger.Slot
         Plutus.V1.Ledger.Tx
         Plutus.V1.Ledger.TxId
+        Plutus.V1.Ledger.Time
         Plutus.V1.Ledger.Value
     build-depends:
         base >=4.9 && <5,
@@ -63,7 +64,6 @@ library
         cardano-crypto -any,
         flat -any,
         hashable -any,
-        hedgehog -any,
         plutus-core -any,
         memory -any,
         mtl -any,

plutus-ledger-api/src/Plutus/V1/Ledger/Contexts.hs

@@ -67,7 +67,7 @@ import           Plutus.V1.Ledger.Credential (Credential (..), StakingCredential
 import           Plutus.V1.Ledger.Crypto     (PubKey (..), PubKeyHash (..), Signature (..), pubKeyHash)
 import           Plutus.V1.Ledger.DCert      (DCert (..))
 import           Plutus.V1.Ledger.Scripts
-import           Plutus.V1.Ledger.Slot       (SlotRange)
+import           Plutus.V1.Ledger.Time       (POSIXTimeRange)
 import           Plutus.V1.Ledger.Tx         (TxOut (..), TxOutRef (..))
 import           Plutus.V1.Ledger.TxId
 import           Plutus.V1.Ledger.Value      (CurrencySymbol (..), Value)
@@ -105,7 +105,7 @@ data TxInfo = TxInfo
     , txInfoForge       :: Value -- ^ The 'Value' forged by this transaction.
     , txInfoDCert       :: [DCert] -- ^ Digests of certificates included in this transaction
     , txInfoWdrl        :: [(StakingCredential, Integer)] -- ^ Withdrawals
-    , txInfoValidRange  :: SlotRange -- ^ The valid range for the transaction.
+    , txInfoValidRange  :: POSIXTimeRange -- ^ The valid range for the transaction.
     , txInfoSignatories :: [PubKeyHash] -- ^ Signatures provided with the transaction, attested that they all signed the tx
     , txInfoData        :: [(DatumHash, Datum)]
     , txInfoId          :: TxId
@@ -118,7 +118,7 @@ data ScriptContext = ScriptContext{scriptContextTxInfo :: TxInfo, scriptContextP
 -- | Find the input currently being validated.
 findOwnInput :: ScriptContext -> Maybe TxInInfo
 findOwnInput ScriptContext{scriptContextTxInfo=TxInfo{txInfoInputs}, scriptContextPurpose=Spending txOutRef} =
-    listToMaybe $ filter (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs
+    find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs
 findOwnInput _ = Nothing
 
 {-# INLINABLE findDatum #-}
@@ -139,20 +139,19 @@ findDatumHash ds TxInfo{txInfoData} = fst <$> find f txInfoData
 {-# INLINABLE findTxInByTxOutRef #-}
 findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxInInfo
 findTxInByTxOutRef outRef TxInfo{txInfoInputs} =
-    listToMaybe
-    $ filter (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs
+    find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs
 
 {-# INLINABLE findContinuingOutputs #-}
 -- | Finds all the outputs that pay to the same script address that we are currently spending from, if any.
 findContinuingOutputs :: ScriptContext -> [Integer]
-findContinuingOutputs ctx | Just (TxInInfo{txInInfoResolved=TxOut{txOutAddress}}) <- findOwnInput ctx = findIndices (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx)
+findContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = findIndices (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx)
     where
         f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress
 findContinuingOutputs _ = Builtins.error()
 
 {-# INLINABLE getContinuingOutputs #-}
 getContinuingOutputs :: ScriptContext -> [TxOut]
-getContinuingOutputs ctx | Just (TxInInfo{txInInfoResolved=TxOut{txOutAddress}}) <- findOwnInput ctx = filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx)
+getContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx)
     where
         f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress
 getContinuingOutputs _ = Builtins.error()
@@ -201,7 +200,7 @@ pubKeyOutput TxOut{txOutAddress} = toPubKeyHash txOutAddress
 {-# INLINABLE ownHashes #-}
 -- | Get the validator and datum hashes of the output that is curently being validated
 ownHashes :: ScriptContext -> (ValidatorHash, DatumHash)
-ownHashes (findOwnInput -> Just (TxInInfo{txInInfoResolved=TxOut{txOutAddress=Address (ScriptCredential s) _, txOutDatumHash=Just dh}})) = (s,dh)
+ownHashes (findOwnInput -> Just TxInInfo{txInInfoResolved=TxOut{txOutAddress=Address (ScriptCredential s) _, txOutDatumHash=Just dh}}) = (s,dh)
 ownHashes _                                                        = Builtins.error ()
 
 {-# INLINABLE ownHash #-}
@@ -252,7 +251,7 @@ adaLockedBy ptx h = Ada.fromValue (valueLockedBy ptx h)
 -- | Check if the provided signature is the result of signing the pending
 --   transaction (without witnesses) with the given public key.
 signsTransaction :: Signature -> PubKey -> TxInfo -> Bool
-signsTransaction (Signature sig) (PubKey (LedgerBytes pk)) (TxInfo{txInfoId=TxId h}) =
+signsTransaction (Signature sig) (PubKey (LedgerBytes pk)) TxInfo{txInfoId=TxId h} =
     verifySignature pk h sig
 
 {-# INLINABLE valueSpent #-}

plutus-ledger-api/src/Plutus/V1/Ledger/Interval.hs

@@ -45,7 +45,7 @@ import           Data.Text.Prettyprint.Doc (Pretty (pretty), (<+>))
 import           GHC.Generics              (Generic)
 import qualified Prelude                   as Haskell
 
-import qualified PlutusTx                  as PlutusTx
+import qualified PlutusTx
 import           PlutusTx.Lift             (makeLift)
 import           PlutusTx.Prelude
 
@@ -59,11 +59,19 @@ data Interval a = Interval { ivFrom :: LowerBound a, ivTo :: UpperBound a }
     deriving stock (Haskell.Eq, Haskell.Ord, Show, Generic)
     deriving anyclass (FromJSON, ToJSON, Serialise, Hashable, NFData)
 
+instance Functor Interval where
+  fmap f (Interval from to) = Interval (f <$> from) (f <$> to)
+
 -- | A set extended with a positive and negative infinity.
 data Extended a = NegInf | Finite a | PosInf
     deriving stock (Haskell.Eq, Haskell.Ord, Show, Generic)
     deriving anyclass (FromJSON, ToJSON, Serialise, Hashable, NFData)
 
+instance Functor Extended where
+  fmap _ NegInf     = NegInf
+  fmap f (Finite a) = Finite (f a)
+  fmap _ PosInf     = PosInf
+
 instance Pretty a => Pretty (Extended a) where
     pretty NegInf     = pretty "-∞"
     pretty PosInf     = pretty "+∞"
@@ -77,6 +85,9 @@ data UpperBound a = UpperBound (Extended a) Closure
     deriving stock (Haskell.Eq, Haskell.Ord, Show, Generic)
     deriving anyclass (FromJSON, ToJSON, Serialise, Hashable, NFData)
 
+instance Functor UpperBound where
+  fmap f (UpperBound e c) = UpperBound (f <$> e) c
+
 instance Pretty a => Pretty (UpperBound a) where
     pretty (UpperBound PosInf _) = pretty "+∞)"
     pretty (UpperBound NegInf _) = pretty "-∞)"
@@ -88,6 +99,9 @@ data LowerBound a = LowerBound (Extended a) Closure
     deriving stock (Haskell.Eq, Haskell.Ord, Show, Generic)
     deriving anyclass (FromJSON, ToJSON, Serialise, Hashable, NFData)
 
+instance Functor LowerBound where
+  fmap f (LowerBound e c) = LowerBound (f <$> e) c
+
 instance Pretty a => Pretty (LowerBound a) where
     pretty (LowerBound PosInf _) = pretty "(+∞"
     pretty (LowerBound NegInf _) = pretty "(-∞"

plutus-ledger-api/src/Plutus/V1/Ledger/Time.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE DeriveAnyClass       #-}
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE DerivingStrategies   #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE MonoLocalBinds       #-}
+{-# LANGUAGE NoImplicitPrelude    #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE UndecidableInstances #-}
+-- Otherwise we get a complaint about the 'fromIntegral' call in the generated instance of 'Integral' for 'Ada'
+{-# OPTIONS_GHC -Wno-identities #-}
+{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
+{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
+
+-- | UTCTime and UTCTime ranges.
+module Plutus.V1.Ledger.Time(
+      POSIXTime(..)
+    , POSIXTimeRange
+    ) where
+
+import           Codec.Serialise.Class     (Serialise)
+import           Control.DeepSeq           (NFData)
+import           Data.Aeson                (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
+import           Data.Hashable             (Hashable)
+import           Data.Text.Prettyprint.Doc (Pretty (pretty), comma, (<+>))
+import           GHC.Generics              (Generic)
+import qualified Prelude                   as Haskell
+
+import qualified PlutusTx
+import           PlutusTx.Lift             (makeLift)
+import           PlutusTx.Prelude
+
+import           Plutus.V1.Ledger.Interval
+
+-- | POSIX time is measured as the number of seconds since 1970-01-01 00:00 UTC
+newtype POSIXTime = POSIXTime { getPOSIXTime :: Integer }
+  deriving stock (Haskell.Eq, Haskell.Ord, Show, Generic)
+  deriving anyclass (FromJSON, FromJSONKey, ToJSON, ToJSONKey, NFData)
+  deriving newtype (Haskell.Num, AdditiveSemigroup, AdditiveMonoid, AdditiveGroup, Enum, Eq, Ord, Real, Integral, Serialise, Hashable, PlutusTx.IsData)
+
+makeLift ''POSIXTime
+
+instance Pretty POSIXTime where
+  pretty (POSIXTime i) = "POSIXTime" <+> pretty i
+
+instance Pretty (Interval POSIXTime) where
+  pretty (Interval l h) = pretty l <+> comma <+> pretty h
+
+-- | An 'Interval' of 'POSIXTime's.
+type POSIXTimeRange = Interval POSIXTime

plutus-ledger/plutus-ledger.cabal

@@ -52,6 +52,7 @@ library
         Ledger.Oracle
         Ledger.Orphans
         Ledger.Index
+        Ledger.TimeSlot
         Ledger.Tokens
         Ledger.Typed.Scripts
         Ledger.Typed.Scripts.Validators
@@ -73,11 +74,12 @@ library
         Plutus.V1.Ledger.Slot as Ledger.Slot,
         Plutus.V1.Ledger.Tx as Ledger.Tx,
         Plutus.V1.Ledger.TxId as Ledger.TxId,
+        Plutus.V1.Ledger.Time as Ledger.Time,
         Plutus.V1.Ledger.Value as Ledger.Value
     build-depends:
         base >=4.9 && <5,
         aeson -any,
-        base16-bytestring, 
+        base16-bytestring,
         bytestring -any,
         cborg -any,
         containers -any,

plutus-ledger/src/Ledger.hs

@@ -17,6 +17,7 @@ import           Plutus.V1.Ledger.Interval as Export
 import           Plutus.V1.Ledger.Orphans  ()
 import           Plutus.V1.Ledger.Scripts  as Export
 import           Plutus.V1.Ledger.Slot     as Export
+import           Plutus.V1.Ledger.Time     as Export
 import           Plutus.V1.Ledger.Tx       as Export
 import           Plutus.V1.Ledger.TxId     as Export
 import           Plutus.V1.Ledger.Value    (CurrencySymbol, TokenName, Value)

plutus-ledger/src/Ledger/Constraints/OnChain.hs

@@ -15,6 +15,7 @@ import           PlutusTx                         (IsData (..))
 import           PlutusTx.Prelude
 
 import           Ledger.Constraints.TxConstraints
+import qualified Ledger.TimeSlot                  as TimeSlot
 import qualified Plutus.V1.Ledger.Address         as Address
 import           Plutus.V1.Ledger.Contexts        (ScriptContext (..), TxInInfo (..), TxInfo (..))
 import qualified Plutus.V1.Ledger.Contexts        as V
@@ -54,7 +55,7 @@ checkTxConstraint ScriptContext{scriptContextTxInfo} = \case
         $ dv `elem` fmap snd (txInfoData scriptContextTxInfo)
     MustValidateIn interval ->
         traceIfFalse "Wrong validation interval"
-        $ interval `contains` txInfoValidRange scriptContextTxInfo
+        $ TimeSlot.slotRangeToPOSIXTimeRange interval `contains` txInfoValidRange scriptContextTxInfo
     MustBeSignedBy pubKey ->
         traceIfFalse "Missing signature"
         $ scriptContextTxInfo `V.txSignedBy` pubKey

plutus-ledger/src/Ledger/Constraints/TxConstraints.hs

@@ -23,7 +23,7 @@ import qualified Data.Map                  as Map
 import           Data.Text.Prettyprint.Doc hiding ((<>))
 import           GHC.Generics              (Generic)
 
-import qualified PlutusTx                  as PlutusTx
+import qualified PlutusTx
 import qualified PlutusTx.AssocMap         as AssocMap
 import           PlutusTx.Prelude
 

plutus-ledger/src/Ledger/Index.hs

@@ -52,6 +52,7 @@ import           Data.Text.Prettyprint.Doc        (Pretty)
 import           Data.Text.Prettyprint.Doc.Extras (PrettyShow (..))
 import           GHC.Generics                     (Generic)
 import           Ledger.Blockchain
+import           Ledger.TimeSlot                  (slotRangeToPOSIXTimeRange)
 import qualified Plutus.V1.Ledger.Ada             as Ada
 import           Plutus.V1.Ledger.Address
 import           Plutus.V1.Ledger.Contexts        (ScriptContext (..), ScriptPurpose (..), TxInfo (..))
@@ -361,7 +362,7 @@ mkTxInfo tx = do
             , txInfoFee = txFee tx
             , txInfoDCert = [] -- DCerts not supported in emulator
             , txInfoWdrl = [] -- Withdrawals not supported in emulator
-            , txInfoValidRange = txValidRange tx
+            , txInfoValidRange = slotRangeToPOSIXTimeRange $ txValidRange tx
             , txInfoSignatories = fmap pubKeyHash $ Map.keys (tx ^. signatures)
             , txInfoData = Map.toList (tx ^. datumWitnesses)
             , txInfoId = txId tx

plutus-ledger/src/Ledger/TimeSlot.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- This GHC option prevents the error:
+-- "GHC Core to PLC plugin: E042:Error: Unsupported feature: Kind: *"
+-- Because Plutus can't handle unboxed tuples which come from worker/wrapper
+{-# OPTIONS_GHC -fno-worker-wrapper #-}
+
+module Ledger.TimeSlot(
+  slotRangeToPOSIXTimeRange
+, slotToPOSIXTime
+, posixTimeRangeToSlotRange
+, posixTimeToSlot
+) where
+
+import           Plutus.V1.Ledger.Slot (Slot (Slot), SlotRange)
+import           Plutus.V1.Ledger.Time (POSIXTime (POSIXTime), POSIXTimeRange)
+import           PlutusTx.Prelude
+
+{-# INLINABLE shelleyLaunchDate #-}
+-- | 'shelleyLaunchDatePOSIXTime' corresponds to the time 2020-07-29T21:44:51Z
+-- which is 1596059091 in POSIX time.
+shelleyLaunchDate :: Integer
+shelleyLaunchDate = 1596059091
+
+{-# INLINABLE slotRangeToPOSIXTimeRange #-}
+-- | Convert a 'SlotRange' to 'POSIXTimeRange'
+slotRangeToPOSIXTimeRange :: SlotRange -> POSIXTimeRange
+slotRangeToPOSIXTimeRange sr = slotToPOSIXTime <$> sr
+
+{-# INLINABLE slotToPOSIXTime #-}
+-- | Convert a 'Slot to 'POSIXTime
+slotToPOSIXTime :: Slot -> POSIXTime
+slotToPOSIXTime (Slot n) = POSIXTime (n + shelleyLaunchDate)
+
+{-# INLINABLE posixTimeRangeToSlotRange #-}
+-- | Convert a 'POSIXTimeRange' to 'SlotRange'
+posixTimeRangeToSlotRange :: POSIXTimeRange -> SlotRange
+posixTimeRangeToSlotRange ptr = posixTimeToSlot <$> ptr
+
+{-# INLINABLE posixTimeToSlot #-}
+-- | Convert a 'POSIXTime' to 'Slot'
+posixTimeToSlot :: POSIXTime -> Slot
+posixTimeToSlot (POSIXTime t) = Slot (t - shelleyLaunchDate)
+