started with swap contract

code/week06/plutus-pioneer-program-week06.cabal

@@ -12,8 +12,8 @@ library
   hs-source-dirs:      src
   exposed-modules:     Week06.Oracle.Core
                        Week06.Oracle.Playground
+                       Week06.Oracle.Swap
                        Week06.Oracle.Test
-                       Week06.Oracle.User
   build-depends:       aeson
                      , base ^>=4.14.1.0
                      , containers

code/week06/src/Week06/Oracle/Core.hs

@@ -15,6 +15,7 @@ module Week06.Oracle.Core
     ( Oracle (..)
     , OracleRedeemer (..)
     , oracleTokenName
+    , oracleValue
     , oracleAsset
     , oracleInst
     , oracleValidator
@@ -64,6 +65,13 @@ oracleTokenName = TokenName emptyByteString
 oracleAsset :: Oracle -> AssetClass
 oracleAsset oracle = AssetClass (oSymbol oracle, oracleTokenName)
 
+{-# INLINABLE oracleValue #-}
+oracleValue :: TxOut -> (DatumHash -> Maybe Datum) -> Maybe Integer
+oracleValue o f = do
+    dh      <- txOutDatum o
+    Datum d <- f dh
+    PlutusTx.fromData d
+
 {-# INLINABLE mkOracleValidator #-}
 mkOracleValidator :: Oracle -> Integer -> OracleRedeemer -> ScriptContext -> Bool
 mkOracleValidator _      _ Use    _   = False
@@ -90,13 +98,9 @@ mkOracleValidator oracle _ Update ctx =
     outputHasToken = assetClassValueOf (txOutValue ownOutput) (oracleAsset oracle) == 1
 
     validOutputDatum :: Bool
-    validOutputDatum = case txOutDatum ownOutput of
+    validOutputDatum = case oracleValue ownOutput (`findDatum` info) of
         Nothing -> False
-        Just dh -> case findDatum dh info of
+        Just _  -> True
-            Nothing        -> False
-            Just (Datum d) -> case PlutusTx.fromData d of
-                Nothing             -> False
-                Just (_ :: Integer) -> True
 
 data Oracling
 instance Scripts.ScriptType Oracling where
@@ -159,9 +163,7 @@ findOracle oracle = do
     utxos <- Map.filter f <$> utxoAt (oracleAddress oracle)
     return $ case Map.toList utxos of
         [(oref, o)] -> do
-            dh        <- txOutDatumHash $ txOutTxOut o
+            x <- oracleValue (txOutTxOut o) $ \dh -> Map.lookup dh $ txData $ txOutTxTx o
-            (Datum d) <- Map.lookup dh $ txData $ txOutTxTx o
-            x         <- PlutusTx.fromData d
             return (oref, o, x)
         _           -> Nothing
   where

code/week06/src/Week06/Oracle/Swap.hs

@@ -0,0 +1,175 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module Week06.Oracle.Swap
+    ( offerSwap
+    ) where
+
+import           Control.Monad        hiding (fmap)
+import           Data.Aeson           (FromJSON, ToJSON)
+import qualified Data.Map             as Map
+import           Data.Monoid          (Last (..))
+import           Data.Text            (Text, pack)
+import           GHC.Generics         (Generic)
+import           Plutus.Contract      as Contract hiding (when)
+import qualified PlutusTx
+import           PlutusTx.Prelude     hiding (Semigroup(..), unless)
+import           Ledger               hiding (singleton)
+import           Ledger.Constraints   as Constraints
+import qualified Ledger.Typed.Scripts as Scripts
+import           Ledger.Ada           as Ada
+import           Ledger.Value         as Value
+import           Prelude              (Semigroup (..))
+
+import           Week06.Oracle.Core
+
+{-# INLINABLE mkSwapValidator #-}
+mkSwapValidator :: Oracle -> Address -> PubKeyHash -> () -> ScriptContext -> Bool
+mkSwapValidator oracle addr pkh () ctx =
+    txSignedBy info pkh ||
+    (traceIfFalse "expected exactly two script inputs" hasTwoScriptInputs &&
+     traceIfFalse "price not paid"                     sellerPaid)
+
+  where
+    info :: TxInfo
+    info = scriptContextTxInfo ctx
+
+    oracleInput :: TxOut
+    oracleInput =
+      let
+        ins = [ o
+              | i <- txInfoInputs info
+              , let o = txInInfoResolved i
+              , txOutAddress o == addr
+              ]
+      in
+        case ins of
+            [o] -> o
+            _   -> traceError "expected exactly one oracle input"
+
+    oracleValue' = case oracleValue oracleInput (`findDatum` info) of
+        Nothing -> traceError "oracle value not found"
+        Just x  -> x
+
+    hasTwoScriptInputs :: Bool
+    hasTwoScriptInputs =
+      let
+        xs = filter (isJust . toValidatorHash . txOutAddress . txInInfoResolved) $ txInfoInputs info
+      in
+        length xs == 2
+
+    minPrice :: Integer
+    minPrice =
+      let
+        lovelaceIn = case findOwnInput ctx of
+            Nothing -> traceError "own input not found"
+            Just i  -> Ada.getLovelace $ Ada.fromValue $ txOutValue $ txInInfoResolved i
+      in
+        lovelaceIn * oracleValue'
+
+    sellerPaid :: Bool
+    sellerPaid =
+      let
+        pricePaid :: Integer
+        pricePaid =  assetClassValueOf (valuePaidTo info pkh) (oAsset oracle)
+      in
+        pricePaid >= minPrice
+
+data Swapping
+instance Scripts.ScriptType Swapping where
+    type instance DatumType Swapping = PubKeyHash
+    type instance RedeemerType Swapping = ()
+
+swapInst :: Oracle -> Scripts.ScriptInstance Swapping
+swapInst oracle = Scripts.validator @Swapping
+    ($$(PlutusTx.compile [|| mkSwapValidator ||])
+        `PlutusTx.applyCode` PlutusTx.liftCode oracle
+        `PlutusTx.applyCode` PlutusTx.liftCode (oracleAddress oracle))
+    $$(PlutusTx.compile [|| wrap ||])
+  where
+    wrap = Scripts.wrapValidator @PubKeyHash @()
+
+swapValidator :: Oracle -> Validator
+swapValidator = Scripts.validatorScript . swapInst
+
+swapAddress :: Oracle -> Ledger.Address
+swapAddress = scriptAddress . swapValidator
+
+offerSwap :: forall w s. HasBlockchainActions s => Oracle -> Integer -> Contract w s Text ()
+offerSwap oracle amt = do
+    pkh <- pubKeyHash <$> Contract.ownPubKey
+    let tx = Constraints.mustPayToTheScript pkh $ Ada.lovelaceValueOf amt
+    ledgerTx <- submitTxConstraints (swapInst oracle) tx
+    awaitTxConfirmed $ txId ledgerTx
+    logInfo @String $ "offered " ++ show amt ++ " lovelace for swap"
+{-
+
+startOracle :: forall w s. HasBlockchainActions s => Integer -> Contract w s Text Oracle
+startOracle fees = do
+    pkh <- pubKeyHash <$> Contract.ownPubKey
+    osc <- mapError (pack . show) (forgeContract pkh [(oracleTokenName, 1)] :: Contract w s CurrencyError OneShotCurrency)
+    let cs     = Currency.currencySymbol osc
+        oracle = Oracle
+            { oSymbol   = cs
+            , oOperator = pkh
+            , oFee      = Ada.lovelaceValueOf fees
+            }
+    logInfo @String $ "forged oracle state token for oracle " ++ show oracle
+    return oracle
+
+updateOracle :: forall w s. HasBlockchainActions s => Oracle -> Integer -> Contract w s Text ()
+updateOracle oracle x = do
+    m <- findOracle oracle
+    let c = Constraints.mustPayToTheScript x $ assetClassValue (oracleAsset oracle) 1
+    case m of
+        Nothing -> do
+            ledgerTx <- submitTxConstraints (oracleInst oracle) c
+            awaitTxConfirmed $ txId ledgerTx
+            logInfo @String $ "set initial oracle value to " ++ show x
+        Just (oref, o,  _) -> do
+            let lookups = Constraints.unspentOutputs (Map.singleton oref o)     <>
+                          Constraints.scriptInstanceLookups (oracleInst oracle) <>
+                          Constraints.otherScript (oracleValidator oracle)
+                tx      = c <> Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData Update)
+            ledgerTx <- submitTxConstraintsWith @Oracling lookups tx
+            awaitTxConfirmed $ txId ledgerTx
+            logInfo @String $ "updated oracle value to " ++ show x
+
+findOracle :: forall w s. HasBlockchainActions s => Oracle -> Contract w s Text (Maybe (TxOutRef, TxOutTx, Integer))
+findOracle oracle = do
+    utxos <- Map.filter f <$> utxoAt (oracleAddress oracle)
+    return $ case Map.toList utxos of
+        [(oref, o)] -> do
+            dh        <- txOutDatumHash $ txOutTxOut o
+            (Datum d) <- Map.lookup dh $ txData $ txOutTxTx o
+            x         <- PlutusTx.fromData d
+            return (oref, o, x)
+        _           -> Nothing
+  where
+    f :: TxOutTx -> Bool
+    f o = assetClassValueOf (txOutValue $ txOutTxOut o) (oracleAsset oracle) == 1
+
+type OracleSchema = BlockchainActions .\/ Endpoint "update" Integer
+
+runOracle :: Integer -> Contract (Last Oracle) OracleSchema Text ()
+runOracle fees = do
+    oracle <- startOracle fees
+    tell $ Last $ Just oracle
+    go oracle
+  where
+    go :: Oracle -> Contract (Last Oracle) OracleSchema Text a
+    go oracle = do
+        x <- endpoint @"update"
+        updateOracle oracle x
+        go oracle
+-}

code/week06/src/Week06/Oracle/Test.hs

@@ -13,16 +13,17 @@
 
 module Week06.Oracle.Test where
 
-import           Control.Monad              hiding (fmap)
+import Control.Monad              hiding (fmap)
-import           Control.Monad.Freer.Extras as Extras
+import Control.Monad.Freer.Extras as Extras
-import           Data.Monoid                (Last (..))
+import Data.Monoid                (Last (..))
-import           Data.Text                  (Text)
+import Data.Text                  (Text)
-import           Plutus.Contract            as Contract hiding (when)
+import Plutus.Contract            as Contract hiding (when)
-import           Plutus.Trace.Emulator      as Emulator
+import Plutus.Trace.Emulator      as Emulator
-import           PlutusTx.Prelude           hiding (Semigroup(..), unless)
+import PlutusTx.Prelude           hiding (Semigroup(..), unless)
-import           Wallet.Emulator.Wallet
+import Wallet.Emulator.Wallet
 
 import Week06.Oracle.Core
+import Week06.Oracle.Swap
 
 test :: IO ()
 test = runEmulatorTraceIO myTrace
@@ -50,6 +51,8 @@ myTrace = do
     void $ Emulator.waitNSlots 3
     callEndpoint @"update" h 666
     void $ Emulator.waitNSlots 10
+    h' <- activateContractWallet (Wallet 2) (offerSwap oracle 12000000 :: Contract () BlockchainActions Text ())
+    void $ Emulator.waitNSlots 10
 
   where
     getOracle :: ContractHandle (Last Oracle) OracleSchema Text -> EmulatorTrace Oracle

code/week06/src/Week06/Oracle/User.hs

@@ -1,174 +0,0 @@
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveAnyClass        #-}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude     #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE TypeOperators         #-}
-
-module Week06.Oracle.User
-    ( Oracle (..)
-    , OracleRedeemer (..)
-    , oracleTokenName
-    , oracleAsset
-    , oracleInst
-    , oracleValidator
-    , oracleAddress
-    , OracleSchema
-    , runOracle
-    , findOracle
-    ) where
-
-import           Control.Monad             hiding (fmap)
-import           Data.Aeson                (FromJSON, ToJSON)
-import qualified Data.Map                  as Map
-import           Data.Monoid               (Last (..))
-import           Data.Text                 (Text, pack)
-import           GHC.Generics              (Generic)
-import           Plutus.Contract           as Contract hiding (when)
-import qualified PlutusTx
-import           PlutusTx.Prelude          hiding (Semigroup(..), unless)
-import           Ledger                    hiding (singleton)
-import           Ledger.Constraints        as Constraints
-import qualified Ledger.Typed.Scripts      as Scripts
-import           Ledger.Ada                as Ada
-import           Ledger.Value              as Value
-import           Plutus.Contracts.Currency as Currency
-import           Prelude                   (Semigroup (..))
-
-data Oracle = Oracle
-    { oSymbol   :: !CurrencySymbol
-    , oOperator :: !PubKeyHash
-    , oFee      :: !Value
-    } deriving (Show, Generic, FromJSON, ToJSON)
-
-PlutusTx.makeLift ''Oracle
-
-data OracleRedeemer = Update | Use
-    deriving Show
-
-PlutusTx.unstableMakeIsData ''OracleRedeemer
-
-{-# INLINABLE oracleTokenName #-}
-oracleTokenName :: TokenName
-oracleTokenName = TokenName emptyByteString
-
-{-# INLINABLE oracleAsset #-}
-oracleAsset :: Oracle -> AssetClass
-oracleAsset oracle = AssetClass (oSymbol oracle, oracleTokenName)
-
-{-# INLINABLE mkOracleValidator #-}
-mkOracleValidator :: Oracle -> Integer -> OracleRedeemer -> ScriptContext -> Bool
-mkOracleValidator _      _ Use    _   = False
-mkOracleValidator oracle _ Update ctx =
-    traceIfFalse "operator signature missing" (txSignedBy info $ oOperator oracle) &&
-    traceIfFalse "token missing from input"   inputHasToken                        &&
-    traceIfFalse "token missing from output"  outputHasToken                       &&
-    traceIfFalse "invalid output datum"       validOutputDatum
-  where
-    info :: TxInfo
-    info = scriptContextTxInfo ctx
-
-    inputHasToken :: Bool
-    inputHasToken = case findOwnInput ctx of
-        Nothing -> False
-        Just i  -> assetClassValueOf (txOutValue $ txInInfoResolved i) (oracleAsset oracle) == 1
-
-    ownOutput :: TxOut
-    ownOutput = case getContinuingOutputs ctx of
-        [o] -> o
-        _   -> traceError "expected exactly one oracle output"
-
-    outputHasToken :: Bool
-    outputHasToken = assetClassValueOf (txOutValue ownOutput) (oracleAsset oracle) == 1
-
-    validOutputDatum :: Bool
-    validOutputDatum = case txOutDatum ownOutput of
-        Nothing -> False
-        Just dh -> case findDatum dh info of
-            Nothing        -> False
-            Just (Datum d) -> case PlutusTx.fromData d of
-                Nothing             -> False
-                Just (_ :: Integer) -> True
-
-data Oracling
-instance Scripts.ScriptType Oracling where
-    type instance DatumType Oracling = Integer
-    type instance RedeemerType Oracling = OracleRedeemer
-
-oracleInst :: Oracle -> Scripts.ScriptInstance Oracling
-oracleInst oracle = Scripts.validator @Oracling
-    ($$(PlutusTx.compile [|| mkOracleValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode oracle)
-    $$(PlutusTx.compile [|| wrap ||])
-  where
-    wrap = Scripts.wrapValidator @Integer @OracleRedeemer
-
-oracleValidator :: Oracle -> Validator
-oracleValidator = Scripts.validatorScript . oracleInst
-
-oracleAddress :: Oracle -> Ledger.Address
-oracleAddress = scriptAddress . oracleValidator
-
-startOracle :: forall w s. HasBlockchainActions s => Integer -> Contract w s Text Oracle
-startOracle fees = do
-    pkh <- pubKeyHash <$> Contract.ownPubKey
-    osc <- mapError (pack . show) (forgeContract pkh [(oracleTokenName, 1)] :: Contract w s CurrencyError OneShotCurrency)
-    let cs     = Currency.currencySymbol osc
-        oracle = Oracle
-            { oSymbol   = cs
-            , oOperator = pkh
-            , oFee      = Ada.lovelaceValueOf fees
-            }
-    logInfo @String $ "forged oracle state token for oracle " ++ show oracle
-    return oracle
-
-updateOracle :: forall w s. HasBlockchainActions s => Oracle -> Integer -> Contract w s Text ()
-updateOracle oracle x = do
-    m <- findOracle oracle
-    let c = Constraints.mustPayToTheScript x $ assetClassValue (oracleAsset oracle) 1
-    case m of
-        Nothing -> do
-            ledgerTx <- submitTxConstraints (oracleInst oracle) c
-            awaitTxConfirmed $ txId ledgerTx
-            logInfo @String $ "set initial oracle value to " ++ show x
-        Just (oref, o,  _) -> do
-            let lookups = Constraints.unspentOutputs (Map.singleton oref o)     <>
-                          Constraints.scriptInstanceLookups (oracleInst oracle) <>
-                          Constraints.otherScript (oracleValidator oracle)
-                tx      = c <> Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData Update)
-            ledgerTx <- submitTxConstraintsWith @Oracling lookups tx
-            awaitTxConfirmed $ txId ledgerTx
-            logInfo @String $ "updated oracle value to " ++ show x
-
-findOracle :: forall w s. HasBlockchainActions s => Oracle -> Contract w s Text (Maybe (TxOutRef, TxOutTx, Integer))
-findOracle oracle = do
-    utxos <- Map.filter f <$> utxoAt (oracleAddress oracle)
-    return $ case Map.toList utxos of
-        [(oref, o)] -> do
-            dh        <- txOutDatumHash $ txOutTxOut o
-            (Datum d) <- Map.lookup dh $ txData $ txOutTxTx o
-            x         <- PlutusTx.fromData d
-            return (oref, o, x)
-        _           -> Nothing
-  where
-    f :: TxOutTx -> Bool
-    f o = assetClassValueOf (txOutValue $ txOutTxOut o) (oracleAsset oracle) == 1
-
-type OracleSchema = BlockchainActions .\/ Endpoint "update" Integer
-
-runOracle :: Integer -> Contract (Last Oracle) OracleSchema Text ()
-runOracle fees = do
-    oracle <- startOracle fees
-    tell $ Last $ Just oracle
-    go oracle
-  where
-    go :: Oracle -> Contract (Last Oracle) OracleSchema Text a
-    go oracle = do
-        x <- endpoint @"update"
-        updateOracle oracle x
-        go oracle