swap contract with tests

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

@@ -17,6 +17,7 @@ library
   build-depends:       aeson
                      , base ^>=4.14.1.0
                      , containers
+                     , data-default
                      , freer-extras
                      , playground-common
                      , plutus-contract

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

@@ -38,7 +38,6 @@ 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 (..))
@@ -46,7 +45,7 @@ import           Prelude                   (Semigroup (..))
 data Oracle = Oracle
     { oSymbol   :: !CurrencySymbol
     , oOperator :: !PubKeyHash
-    , oFee      :: !Value
+    , oFee      :: !Integer
     , oAsset    :: !AssetClass
     } deriving (Show, Generic, FromJSON, ToJSON)
 
@@ -74,7 +73,7 @@ oracleValue o f = do
 
 {-# INLINABLE mkOracleValidator #-}
 mkOracleValidator :: Oracle -> Integer -> OracleRedeemer -> ScriptContext -> Bool
-mkOracleValidator _      _ Use    _   = False
+mkOracleValidator _      _ Use    _   = True
 mkOracleValidator oracle _ Update ctx =
     traceIfFalse "operator signature missing" (txSignedBy info $ oOperator oracle) &&
     traceIfFalse "token missing from input"   inputHasToken                        &&
@@ -134,7 +133,7 @@ startOracle op = do
         oracle = Oracle
             { oSymbol   = cs
             , oOperator = pkh
-            , oFee      = Ada.lovelaceValueOf $ opFees op
+            , oFee      = opFees op
             , oAsset    = AssetClass (opSymbol op, opToken op)
             }
     logInfo @String $ "forged oracle state token for oracle " ++ show oracle

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

@@ -14,27 +14,35 @@
 module Week06.Oracle.Swap
     ( offerSwap
     , retrieveSwaps
+    , useSwap
     ) where
 
 import           Control.Monad        hiding (fmap)
-import           Data.Aeson           (FromJSON, ToJSON)
+import           Data.List            (find)
 import qualified Data.Map             as Map
 import           Data.Maybe           (mapMaybe)
 import           Data.Monoid          (Last (..))
-import           Data.Text            (Text, pack)
+import           Data.Text            (Text)
-import           GHC.Generics         (Generic)
 import           Plutus.Contract      as Contract hiding (when)
 import qualified PlutusTx
-import           PlutusTx.Prelude     hiding (Semigroup(..), unless, mapMaybe)
+import           PlutusTx.Prelude     hiding (Semigroup(..), (<$>), unless, mapMaybe, find)
 import           Ledger               hiding (singleton)
 import           Ledger.Constraints   as Constraints
 import qualified Ledger.Typed.Scripts as Scripts
-import           Ledger.Ada           as Ada
+import           Ledger.Ada           as Ada hiding (divide)
 import           Ledger.Value         as Value
-import           Prelude              (Semigroup (..))
+import           Prelude              (Semigroup (..), (<$>))
 
 import           Week06.Oracle.Core
 
+{-# INLINABLE price #-}
+price :: Integer -> Integer -> Integer
+price lovelace exchangeRate = (lovelace * exchangeRate) `divide` 1000000
+
+{-# INLINABLE lovelaces #-}
+lovelaces :: Value -> Integer
+lovelaces = Ada.getLovelace . Ada.fromValue
+
 {-# INLINABLE mkSwapValidator #-}
 mkSwapValidator :: Oracle -> Address -> PubKeyHash -> () -> ScriptContext -> Bool
 mkSwapValidator oracle addr pkh () ctx =
@@ -75,9 +83,9 @@ mkSwapValidator oracle addr pkh () ctx =
       let
         lovelaceIn = case findOwnInput ctx of
             Nothing -> traceError "own input not found"
-            Just i  -> Ada.getLovelace $ Ada.fromValue $ txOutValue $ txInInfoResolved i
+            Just i  -> lovelaces $ txOutValue $ txInInfoResolved i
       in
-        lovelaceIn * oracleValue'
+        price lovelaceIn oracleValue'
 
     sellerPaid :: Bool
     sellerPaid =
@@ -145,3 +153,49 @@ retrieveSwaps oracle = do
             ledgerTx <- submitTxConstraintsWith @Swapping lookups tx
             awaitTxConfirmed $ txId ledgerTx
             logInfo @String $ "retrieved " ++ show (length xs) ++ " swap(s)"
+
+ownFunds :: HasBlockchainActions s => Contract w s Text Value
+ownFunds = do
+    pk    <- ownPubKey
+    utxos <- utxoAt $ pubKeyAddress pk
+    let v = mconcat $ Map.elems $ txOutValue . txOutTxOut <$>  utxos
+    logInfo @String $ "own funds: " ++ show (Value.flattenValue v)
+    return v
+
+useSwap :: forall w s. HasBlockchainActions s => Oracle -> Contract w s Text ()
+useSwap oracle = do
+    funds <- ownFunds
+    let amt = assetClassValueOf funds $ oAsset oracle
+    logInfo @String $ "available assets: " ++ show amt
+
+    m <- findOracle oracle
+    case m of
+        Nothing           -> logInfo @String "oracle not found"
+        Just (oref, o, x) -> do
+            logInfo @String $ "found oracle, exchange rate " ++ show x
+            pkh   <- pubKeyHash <$> Contract.ownPubKey
+            swaps <- findSwaps oracle (/= pkh)
+            case find (f amt x) swaps of
+                Nothing                -> logInfo @String "no suitable swap found"
+                Just (oref', o', pkh') -> do
+                    let v       = txOutValue (txOutTxOut o) <> lovelaceValueOf (oFee oracle)
+                        p       = assetClassValue (oAsset oracle) $ price (lovelaces $ txOutValue $ txOutTxOut o') x
+                        lookups = Constraints.otherScript (swapValidator oracle)                     <>
+                                  Constraints.otherScript (oracleValidator oracle)                   <>
+                                  Constraints.unspentOutputs (Map.fromList [(oref, o), (oref', o')])
+                        tx      = Constraints.mustSpendScriptOutput oref  (Redeemer $ PlutusTx.toData Use) <>
+                                  Constraints.mustSpendScriptOutput oref' (Redeemer $ PlutusTx.toData ())  <>
+                                  Constraints.mustPayToOtherScript
+                                    (validatorHash $ oracleValidator oracle)
+                                    (Datum $ PlutusTx.toData x)
+                                    v                                                                      <>
+                                  Constraints.mustPayToPubKey pkh' p
+                    ledgerTx <- submitTxConstraintsWith @Swapping lookups tx
+                    awaitTxConfirmed $ txId ledgerTx
+                    logInfo @String $ "made swap with price " ++ show (Value.flattenValue p)
+  where
+    getPrice :: Integer -> TxOutTx -> Integer
+    getPrice x o = price (lovelaces $ txOutValue $ txOutTxOut o) x
+
+    f :: Integer -> Integer -> (TxOutRef, TxOutTx, PubKeyHash) -> Bool
+    f amt x (_, o, _) = getPrice x o <= amt

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE NumericUnderscores    #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TemplateHaskell       #-}
@@ -13,20 +14,39 @@
 
 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.Default               (Default (..))
-import Data.Text                  (Text)
+import qualified Data.Map                   as Map
-import Plutus.Contract            as Contract hiding (when)
+import           Data.Monoid                (Last (..))
-import Plutus.Trace.Emulator      as Emulator
+import           Data.Text                  (Text)
-import PlutusTx.Prelude           hiding (Semigroup(..), unless)
+import           Ledger
-import Wallet.Emulator.Wallet
+import           Ledger.Value               as Value
+import           Ledger.Ada                 as Ada
+import           Plutus.Contract            as Contract hiding (when)
+import           Plutus.Trace.Emulator      as Emulator
+import           PlutusTx.Prelude           hiding (Semigroup(..), unless)
+import           Prelude                    (Semigroup(..))
+import           Wallet.Emulator.Wallet
 
-import Week06.Oracle.Core
+import           Week06.Oracle.Core
-import Week06.Oracle.Swap
+import           Week06.Oracle.Swap
+
+assetSymbol :: CurrencySymbol
+assetSymbol = "ff"
+
+assetToken :: TokenName
+assetToken = "USDT"
 
 test :: IO ()
-test = runEmulatorTraceIO myTrace
+test = runEmulatorTraceIO' def emCfg myTrace
+  where
+    emCfg :: EmulatorConfig
+    emCfg = EmulatorConfig $ Left $ Map.fromList [(Wallet i, v) | i <- [1 .. 10]]
+
+    v :: Value
+    v = Ada.lovelaceValueOf                    100_000_000 <>
+        Value.singleton assetSymbol assetToken 100_000_000
 
 checkOracle :: Oracle -> Contract () BlockchainActions Text a
 checkOracle oracle = do
@@ -39,25 +59,39 @@ checkOracle oracle = do
 myTrace :: EmulatorTrace ()
 myTrace = do
     let op = OracleParams
-                { opFees = 1000000
+                { opFees = 1_000_000
-                , opSymbol = "ff"
+                , opSymbol = assetSymbol
-                , opToken  = "USDT"
+                , opToken  = assetToken
                 }
+
     h <- activateContractWallet (Wallet 1) $ runOracle op
     void $ Emulator.waitNSlots 1
     oracle <- getOracle h
-    void $ activateContractWallet (Wallet 2) $ checkOracle oracle
-    callEndpoint @"update" h 42
-    void $ Emulator.waitNSlots 3
-    callEndpoint @"update" h 666
-    void $ Emulator.waitNSlots 10
-    void $ activateContractWallet (Wallet 2) (offerSwap oracle 12000000 :: Contract () BlockchainActions Text ())
-    void $ Emulator.waitNSlots 10
-    void $ activateContractWallet (Wallet 2) (offerSwap oracle 18000000 :: Contract () BlockchainActions Text ())
-    void $ Emulator.waitNSlots 10
-    void $ activateContractWallet (Wallet 2) (retrieveSwaps oracle :: Contract () BlockchainActions Text ())
-    void $ Emulator.waitNSlots 10
 
+    void $ activateContractWallet (Wallet 2) $ checkOracle oracle
+
+    callEndpoint @"update" h 1_500_000
+    void $ Emulator.waitNSlots 3
+
+    void $ activateContractWallet (Wallet 3) (offerSwap oracle 10_000_000 :: Contract () BlockchainActions Text ())
+    void $ activateContractWallet (Wallet 4) (offerSwap oracle 20_000_000 :: Contract () BlockchainActions Text ())
+    void $ Emulator.waitNSlots 3
+
+    void $ activateContractWallet (Wallet 5) (useSwap oracle :: Contract () BlockchainActions Text ())
+    void $ Emulator.waitNSlots 3
+
+    callEndpoint @"update" h 1_700_000
+    void $ Emulator.waitNSlots 3
+
+    void $ activateContractWallet (Wallet 5) (useSwap oracle :: Contract () BlockchainActions Text ())
+    void $ Emulator.waitNSlots 3
+
+    callEndpoint @"update" h 1_800_000
+    void $ Emulator.waitNSlots 3
+
+    void $ activateContractWallet (Wallet 3) (retrieveSwaps oracle :: Contract () BlockchainActions Text ())
+    void $ activateContractWallet (Wallet 4) (retrieveSwaps oracle :: Contract () BlockchainActions Text ())
+    void $ Emulator.waitNSlots 3
 
   where
     getOracle :: ContractHandle (Last Oracle) OracleSchema Text -> EmulatorTrace Oracle