View on GitHub
File Changes
import           Ledger.Tokens
import qualified Ledger.Typed.Scripts           as Scripts
import           Ledger.Scripts                 (unitData)
-
import           Ledger.Validation              (OracleValue (..))
import           Ledger.Value                   as Value

                      
import qualified Language.PlutusTx.Coordination.Contracts.Currency as Currency
validator :: Future -> FutureAccounts -> Validator
validator ft fos = Scripts.validatorScript (scriptInstance ft fos)

                      
-
{-# INLINABLE verifyOracleOnChain #-}
-
verifyOracleOnChain :: PlutusTx.IsData a => PendingTx -> Future -> SignedMessage (Observation a) -> Maybe (Slot, a)
-
verifyOracleOnChain ptx Future{ftPriceOracle} sm =
-
    case Oracle.verifySignedMessageOnChain ptx ftPriceOracle sm of
-
        Left _ -> Nothing
-
        Right Observation{obsValue, obsSlot} -> Just (obsSlot, obsValue)
+
{-# INLINABLE verifyOracle #-}
+
verifyOracle :: PlutusTx.IsData a => PubKey -> SignedMessage a -> Maybe (a, TxConstraint)
+
verifyOracle pubKey sm =
+
    either (const Nothing) pure 
+
    $ Oracle.verifySignedMessageConstraints pubKey sm

                      
verifyOracleOffChain :: PlutusTx.IsData a => Future -> SignedMessage (Observation a) -> Maybe (Slot, a)
verifyOracleOffChain Future{ftPriceOracle} sm =
{-# INLINABLE transition #-}
transition :: Future -> FutureAccounts -> OldState FutureState -> FutureAction -> Maybe (NewState FutureState)
transition future owners OldState{oldData=s, oldValue=currentValue} i = 
-
    let Future{ftDeliveryDate} = future in
+
    let Future{ftDeliveryDate, ftPriceOracle} = future in
        case (s, i) of
            (Running accounts, AdjustMargin role topUp) ->
                Just NewState
                        , newConstraints = []
                        }
            (Running accounts, Settle ov)
-
                | Just (oracleDate, spotPrice) <- verifyOracle future ov, True <- ftDeliveryDate == oracleDate ->
+
                | Just (Observation{obsValue=spotPrice, obsSlot=oracleDate}, constraint) <- verifyOracle ftPriceOracle ov, ftDeliveryDate == oracleDate ->
                    let payment = payouts future accounts spotPrice in
                    Just NewState
                            { newData = Finished
                            , newValue = mempty
                            , newConstraints = 
                                (Constraints.MustValidateIn (Interval.from ftDeliveryDate)
+
                                : constraint
                                : payoutsTx payment owners)
                            }
            (Running accounts, SettleEarly ov)
-
                | Just (oracleDate, spotPrice) <- verifyOracle future ov, Just vRole <- violatingRole future accounts spotPrice, True <- (ftDeliveryDate > oracleDate) ->
+
                | Just (Observation{obsValue=spotPrice, obsSlot=oracleDate}, constraint) <- verifyOracle ftPriceOracle ov, Just vRole <- violatingRole future accounts spotPrice, ftDeliveryDate > oracleDate ->
                    let
                        total = totalMargin accounts
                        FutureAccounts{ftoLongAccount, ftoShortAccount} = owners
                    in Just NewState
                        { newData = Finished
                        , newValue = mempty
-
                        , newConstraints = [payment]
+
                        , newConstraints = [payment, constraint]
                        }
            _ -> Nothing

                      
contract params = go where
    theClient = client params
    go = endpoints >> go
-
    endpoints = (Just <$> lock) <|> propose <|> cancel <|> addSignature <|> pay
+
    endpoints = lock <|> propose <|> cancel <|> addSignature <|> pay
    propose = endpoint @"propose-payment" >>= SM.runStep theClient . ProposePayment
    cancel  = endpoint @"cancel-payment" >> SM.runStep theClient Cancel
    addSignature = endpoint @"add-signature" >> (pubKeyHash <$> ownPubKey) >>= SM.runStep theClient . AddSignature
  -> Account
  -- ^ The token account
  -> Contract s e TxId
-
redeem pk account = redeemTx account pk >>= submitTx
+
redeem pk account = redeemTx account pk >>= submitUnbalancedTx

                      
-- | @balance [email protected] returns the value of all unspent outputs that can be
--   unlocked with @accountToken [email protected]

                      
    , Lib.goldenPir "test/Spec/future.pir" $$(PlutusTx.compile [|| F.futureStateMachine ||])

                      
-
    , HUnit.testCase "script size is reasonable" (Lib.reasonable (F.validator theFuture accounts) 52000)
+
    , HUnit.testCase "script size is reasonable" (Lib.reasonable (F.validator theFuture accounts) 54000)

                      
    ]

                      
    , mustBeSignedBy
    , mustIncludeDataValue
    , mustPayToOtherScript
+
    , mustHashDataValue
    -- * Queries
    , modifiesUtxoSet
    , isSatisfiable
    | ValidatorHashNotFound Address
    | OwnPubKeyMissing
    | ScriptInstanceMissing
+
    | DataValueWrongHash DataValueHash DataValue
    deriving (Eq, Show)

                      
lookupTxOutRef
        unbalancedTx . tx . Tx.dataWitnesses %= set (at theHash) (Just dv)
        unbalancedTx . tx . Tx.outputs %= (Tx.scriptTxOut' vl addr dv :)
        valueSpentRequired <>= N.negate vl
+
    MustHashDataValue dvh dv -> do
+
        unless (dataValueHash dv == dvh)
+
            (throwError $ DataValueWrongHash dvh dv)
+
        unbalancedTx . tx . Tx.dataWitnesses %= set (at dvh) (Just dv)
        in
        traceIfFalseH "MustPayToOtherScript"
        $ any checkOutput outs
+
    MustHashDataValue dvh dv ->
+
        traceIfFalseH "MustHashDataValue"
+
        $ V.findData dvh ptx == Just dv

                      
{-# INLINABLE checkPendingTx #-}
-- | Does the 'PendingTx' satisfy the constraints?

                      
import           Ledger.Crypto             (PubKeyHash)
import qualified Ledger.Interval           as I
-
import           Ledger.Scripts            (DataValue (..), MonetaryPolicyHash, RedeemerValue, ValidatorHash)
+
import           Ledger.Scripts            (DataValue (..), DataValueHash, MonetaryPolicyHash, RedeemerValue,
+
                                            ValidatorHash)
import           Ledger.Slot               (SlotRange)
import           Ledger.Tx                 (TxOutRef)
import           Ledger.Value              (TokenName, Value, isZero)
    | MustForgeValue MonetaryPolicyHash TokenName Integer
    | MustPayToPubKey PubKeyHash Value
    | MustPayToOtherScript ValidatorHash DataValue Value
+
    | MustHashDataValue DataValueHash DataValue
    deriving stock (Generic, Haskell.Eq)
    deriving anyclass (ToJSON, FromJSON)

                      
            hang 2 $ vsep ["must pay to pubkey:", pretty pk, pretty v]
        MustPayToOtherScript vlh dv vl ->
            hang 2 $ vsep ["must pay to script:", pretty vlh, pretty dv, pretty vl]
+
        MustHashDataValue dvh dv ->
+
            hang 2 $ vsep ["must hash data value:", pretty dvh, pretty dv]

                      
data InputConstraint a =
    InputConstraint
mustSpendScriptOutput :: forall i o. TxOutRef -> RedeemerValue -> TxConstraints i o
mustSpendScriptOutput txOutref = singleton . MustSpendScriptOutput txOutref

                      
+
{-# INLINABLE mustHashDataValue #-}
+
mustHashDataValue :: DataValueHash -> DataValue -> TxConstraints i o
+
mustHashDataValue dvh = singleton . MustHashDataValue dvh
+

                      
{-# INLINABLE isSatisfiable #-}
-- | Are the constraints satisfiable?
isSatisfiable :: forall i o. TxConstraints i o -> Bool
  -- * Checking signed messages
  , SignedMessageCheckError(..)
  , checkSignature
-
  , checkHashOnChain
+
  , checkHashConstraints
  , checkHashOffChain
  , verifySignedMessageOffChain
  , verifySignedMessageOnChain
+
  , verifySignedMessageConstraints
  -- * Signing messages
  , signMessage
  , signObservation
  ) where

                      
-
import qualified Data.ByteString.Lazy      as BSL
-
import           GHC.Generics              (Generic)
+
import qualified Data.ByteString.Lazy        as BSL
+
import           GHC.Generics                (Generic)

                      
import           Language.PlutusTx
import           Language.PlutusTx.Prelude

                      
-
import           Ledger.Crypto             (PrivateKey, PubKey (..), Signature (..))
-
import qualified Ledger.Crypto             as Crypto
-
import           Ledger.Scripts            (DataValue (..), DataValueHash (..))
-
import qualified Ledger.Scripts            as Scripts
-
import           Ledger.Slot               (Slot)
-
import           Ledger.Validation         (PendingTx')
-
import qualified Ledger.Validation         as V
+
import           Ledger.Constraints          (TxConstraint)
+
import qualified Ledger.Constraints          as Constraints
+
import qualified Ledger.Constraints.OnChain  as Constraints
+
import           Ledger.Crypto               (PrivateKey, PubKey (..), Signature (..))
+
import qualified Ledger.Crypto               as Crypto
+
import           Ledger.Scripts              (DataValue (..), DataValueHash (..))
+
import qualified Ledger.Scripts              as Scripts
+
import           Ledger.Slot                 (Slot)
+
import           Ledger.Validation           (PendingTx)
import           LedgerBytes

                      
-
import qualified Prelude                   as Haskell
+
import qualified Prelude                     as Haskell

                      
-- $oracles
-- This module provides a way to verify signed messages, and a type for
--    message 'o' as a data value. This is because we can't hash anything in
--    on-chain code, and therefore have to rely on the node to do it for us
--    via the pending transaction's map of data value hashes to data values.
+
--    (The constraints resolution mechanism takes care of including the message)
--  * The contract then calls 'checkSignature' to check the signature, and
-
--    'checkHashOnChain' to ensure that the signed hash is really the hash of
-
--    the data value.
+
--    produces a constraint ensuring that the signed hash is really the hash
+
--    of the data value.

                      
-- | A value that was observed at a specific point in time
data Observation a = Observation
        then Right ()
        else Left $ SignatureMismatch signature_ pubKey dataValueHash

                      
-
{-# INLINABLE checkHashOnChain #-}
-
-- | Verify the hash of a data value and extract the contents of the
-
--   message from the pending transaction. In off-chain code, where there is no
-
--   'PendingTx' value, 'checkHashOffChain' can be used instead of this.
-
checkHashOnChain ::
-
  ( IsData a )
-
  => PendingTx' b
-
  -- ^ The transaction that contains the message as a data value
-
  -> SignedMessage a
-
  -- ^ The signed message
-
  -> Either SignedMessageCheckError a
-
checkHashOnChain ptx SignedMessage{osmMessageHash, osmData=DataValue dt} = do
-
    DataValue dt' <- maybe (traceH "DataValueMissing" $ Left $ DataValueMissing osmMessageHash) pure (V.findData osmMessageHash ptx)
-
    unless (dt == dt') (traceH "DataNotEqualToExpected" $ Left DataNotEqualToExpected)
-
    maybe (traceH "DecodingError" $ Left DecodingError) pure (fromData dt')
+
{-# INLINABLE checkHashConstraints #-}
+
-- | Extrat the contents of the message and produce a constraint that checks
+
--   that the hash is correct. In off-chain code, where we check the hash
+
--   straightforwardly, 'checkHashOffChain' can be used instead of this.
+
checkHashConstraints ::
+
    ( IsData a )
+
    => SignedMessage a
+
    -- ^ The signed message
+
    -> Either SignedMessageCheckError (a, TxConstraint)
+
checkHashConstraints SignedMessage{osmMessageHash, osmData=DataValue dt} =
+
    maybe
+
        (traceH "DecodingError" $ Left DecodingError)
+
        (\a -> pure (a, Constraints.MustHashDataValue osmMessageHash (DataValue dt)))
+
        (fromData dt)
+

                      
+
{-# INLINABLE verifySignedMessageConstraints #-}
+
-- | Check the signature on a 'SignedMessage' and extract the contents of the
+
--   message, producing a 'TxConstraint' value that ensures the hashes match
+
--   up.
+
verifySignedMessageConstraints ::
+
    ( IsData a)
+
    => PubKey
+
    -> SignedMessage a
+
    -> Either SignedMessageCheckError (a, TxConstraint)
+
verifySignedMessageConstraints pk [email protected]{osmSignature, osmMessageHash} =
+
    checkSignature osmMessageHash pk osmSignature
+
    >> checkHashConstraints s

                      
{-# INLINABLE verifySignedMessageOnChain #-}
-- | Check the signature on a 'SignedMessage' and extract the contents of the
-
--   message, using the pending transaction in lieu of a hash function.
+
--   message, using the pending transaction in lieu of a hash function. See
+
--   'verifySignedMessageConstraints' for a version that does not require a
+
--   'PendingTx' value.
verifySignedMessageOnChain ::
    ( IsData a)
-
    => PendingTx' b
+
    => PendingTx
    -> PubKey
    -> SignedMessage a
    -> Either SignedMessageCheckError a
-
verifySignedMessageOnChain ptx pk [email protected]{osmSignature, osmMessageHash} =
+
verifySignedMessageOnChain ptx pk [email protected]{osmSignature, osmMessageHash} = do
    checkSignature osmMessageHash pk osmSignature
-
    >> checkHashOnChain ptx s
+
    (a, constraint) <- checkHashConstraints s
+
    unless (Constraints.checkTxConstraint ptx constraint)
+
        (Left $ DataValueMissing osmMessageHash)
+
    pure a

                      
-
-- | The off-chain version of 'checkHashOnChain', using the hash function
+
-- | The off-chain version of 'checkHashConstraints', using the hash function
--   directly instead of obtaining the hash from a 'PendingTx' value
checkHashOffChain ::
    ( IsData a )