started with oracle PAB

This commit is contained in:
Lars Brünjes 2021-05-10 11:11:08 +02:00
parent af90b54f0e
commit 2643aa2cb2
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
7 changed files with 164 additions and 21 deletions

79
code/week06/app/oracle.hs Normal file
View file

@ -0,0 +1,79 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Main
( main
) where
import Control.Monad (void)
import Control.Monad.Freer (Eff, Member, interpret, type (~>))
import Control.Monad.Freer.Error (Error)
import Control.Monad.Freer.Extras.Log (LogMsg)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson (FromJSON, ToJSON)
import Data.Text.Prettyprint.Doc (Pretty (..), viaShow)
import GHC.Generics (Generic)
import Plutus.Contract (BlockchainActions, ContractError)
import Plutus.PAB.Effects.Contract (ContractEffect (..))
import Plutus.PAB.Effects.Contract.Builtin (Builtin, SomeBuiltin (..), type (.\\), endpointsToSchemas, handleBuiltin)
import Plutus.PAB.Effects.ContractTest.Uniswap as US
import Plutus.PAB.Monitoring.PABLogMsg (PABMultiAgentMsg)
import Plutus.PAB.Simulator (SimulatorEffectHandlers)
import qualified Plutus.PAB.Simulator as Simulator
import Plutus.PAB.Types (PABError (..))
import qualified Plutus.PAB.Webserver.Server as PAB.Server
import Wallet.Emulator.Types (Wallet (..))
import qualified Week06.Oracle.Core as Oracle
import qualified Week06.Oracle.Swap as Oracle
main :: IO ()
main = void $ Simulator.runSimulationWith handlers $ do
Simulator.logString @(Builtin OracleContracts) "Starting Oracle PAB webserver on port 8080. Press enter to exit."
shutdown <- PAB.Server.startServerDebug
void $ liftIO getLine
shutdown
data OracleContracts = Oracle | Swap Oracle.Oracle
deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
instance Pretty OracleContracts where
pretty = viaShow
oracleParams :: Oracle.OracleParams
oracleParams = Oracle.OracleParams
{ Oracle.opFees = 1_000_000
, Oracle.opSymbol = "ff"
, Oracle.opToken = "USDT"
}
handleOracleContracts ::
( Member (Error PABError) effs
, Member (LogMsg (PABMultiAgentMsg (Builtin OracleContracts))) effs
)
=> ContractEffect (Builtin OracleContracts)
~> Eff effs
handleOracleContracts = handleBuiltin getSchema getContract where
getSchema = \case
Oracle -> endpointsToSchemas @(Oracle.OracleSchema .\\ BlockchainActions)
Swap _ -> endpointsToSchemas @(Oracle.SwapSchema .\\ BlockchainActions)
getContract = \case
Oracle -> SomeBuiltin $ Oracle.runOracle oracleParams
Swap oracle -> SomeBuiltin $ Oracle.swap oracle
handlers :: SimulatorEffectHandlers (Builtin OracleContracts)
handlers =
Simulator.mkSimulatorHandlers @(Builtin OracleContracts) []
$ interpret handleOracleContracts

View file

@ -19,6 +19,7 @@ source-repository-package
plutus-contract plutus-contract
plutus-ledger plutus-ledger
plutus-ledger-api plutus-ledger-api
plutus-pab
plutus-tx plutus-tx
plutus-tx-plugin plutus-tx-plugin
plutus-use-cases plutus-use-cases
@ -32,6 +33,9 @@ source-repository-package
-- not on Hackage, and so need to be pulled in as `source-repository-package`s themselves. Make sure to -- not on Hackage, and so need to be pulled in as `source-repository-package`s themselves. Make sure to
-- re-update this section from the template when you do an upgrade. -- re-update this section from the template when you do an upgrade.
-- This is also needed so evenful-sql-common will build with a
-- newer version of persistent. See stack.yaml for the mirrored
-- configuration.
package eventful-sql-common package eventful-sql-common
ghc-options: -XDerivingStrategies -XStandaloneDeriving -XUndecidableInstances -XDataKinds -XFlexibleInstances ghc-options: -XDerivingStrategies -XStandaloneDeriving -XUndecidableInstances -XDataKinds -XFlexibleInstances
@ -48,6 +52,15 @@ allow-newer:
constraints: constraints:
-- aws-lambda-haskell-runtime-wai doesn't compile with newer versions -- aws-lambda-haskell-runtime-wai doesn't compile with newer versions
aws-lambda-haskell-runtime <= 3.0.3 aws-lambda-haskell-runtime <= 3.0.3
-- big breaking change here, inline-r doens't have an upper bound
, singletons < 3.0
-- breaks eventful even more than it already was
, persistent-template < 2.12
-- See the note on nix/pkgs/default.nix:agdaPackages for why this is here.
-- (NOTE this will change to ieee754 in newer versions of nixpkgs).
extra-packages: ieee, filemanip
-- Needs some patches, but upstream seems to be fairly dead (no activity in > 1 year) -- Needs some patches, but upstream seems to be fairly dead (no activity in > 1 year)
source-repository-package source-repository-package
@ -65,12 +78,6 @@ source-repository-package
location: https://github.com/input-output-hk/cardano-crypto.git location: https://github.com/input-output-hk/cardano-crypto.git
tag: f73079303f663e028288f9f4a9e08bcca39a923e tag: f73079303f663e028288f9f4a9e08bcca39a923e
-- Needs a fix (https://github.com/wenkokke/unlit/pull/11) and a Hackage release
source-repository-package
type: git
location: https://github.com/michaelpj/unlit.git
tag: 9ca1112093c5ffd356fc99c7dafa080e686dd748
source-repository-package source-repository-package
type: git type: git
location: https://github.com/input-output-hk/cardano-base location: https://github.com/input-output-hk/cardano-base

View file

@ -2,3 +2,5 @@ cradle:
cabal: cabal:
- path: "./src" - path: "./src"
component: "lib:plutus-pioneer-program-week06" component: "lib:plutus-pioneer-program-week06"
- path: "./app/oracle.hs"
component: "exe:oracle"

View file

@ -29,3 +29,17 @@ library
, text , text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise
executable oracle
main-is: oracle.hs
hs-source-dirs: app
ghc-options: -threaded
build-depends: aeson
, base ^>= 4.14.1.0
, freer-extras
, freer-simple
, plutus-contract
, plutus-ledger
, plutus-pab
, plutus-pioneer-program-week06
, prettyprinter

View file

@ -42,13 +42,14 @@ import Ledger.Value as Value
import Ledger.Ada as Ada import Ledger.Ada as Ada
import Plutus.Contracts.Currency as Currency import Plutus.Contracts.Currency as Currency
import Prelude (Semigroup (..)) import Prelude (Semigroup (..))
import qualified Prelude as Prelude
data Oracle = Oracle data Oracle = Oracle
{ oSymbol :: !CurrencySymbol { oSymbol :: !CurrencySymbol
, oOperator :: !PubKeyHash , oOperator :: !PubKeyHash
, oFee :: !Integer , oFee :: !Integer
, oAsset :: !AssetClass , oAsset :: !AssetClass
} deriving (Show, Generic, FromJSON, ToJSON) } deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord)
PlutusTx.makeLift ''Oracle PlutusTx.makeLift ''Oracle

View file

@ -12,9 +12,8 @@
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
module Week06.Oracle.Swap module Week06.Oracle.Swap
( offerSwap ( SwapSchema
, retrieveSwaps , swap
, useSwap
) where ) where
import Control.Monad hiding (fmap) import Control.Monad hiding (fmap)
@ -199,3 +198,37 @@ useSwap oracle = do
f :: Integer -> Integer -> (TxOutRef, TxOutTx, PubKeyHash) -> Bool f :: Integer -> Integer -> (TxOutRef, TxOutTx, PubKeyHash) -> Bool
f amt x (_, o, _) = getPrice x o <= amt f amt x (_, o, _) = getPrice x o <= amt
type SwapSchema =
BlockchainActions
.\/ Endpoint "offer" Integer
.\/ Endpoint "retrieve" ()
.\/ Endpoint "use" ()
.\/ Endpoint "funds" ()
swap :: Oracle -> Contract (Last Value) SwapSchema Text ()
swap oracle = (offer `select` retrieve `select` use `select` funds) >> swap oracle
where
offer :: Contract (Last Value) SwapSchema Text ()
offer = h $ do
amt <- endpoint @"offer"
offerSwap oracle amt
retrieve :: Contract (Last Value) SwapSchema Text ()
retrieve = h $ do
endpoint @"retrieve"
retrieveSwaps oracle
use :: Contract (Last Value) SwapSchema Text ()
use = h $ do
endpoint @"use"
useSwap oracle
funds :: Contract (Last Value) SwapSchema Text ()
funds = h $ do
endpoint @"funds"
v <- ownFunds
tell $ Last $ Just v
h :: Contract (Last Value) SwapSchema Text () -> Contract (Last Value) SwapSchema Text ()
h = handleError logError

View file

@ -64,35 +64,42 @@ myTrace = do
, opToken = assetToken , opToken = assetToken
} }
h <- activateContractWallet (Wallet 1) $ runOracle op h1 <- activateContractWallet (Wallet 1) $ runOracle op
void $ Emulator.waitNSlots 1 void $ Emulator.waitNSlots 1
oracle <- getOracle h oracle <- getOracle h1
void $ activateContractWallet (Wallet 2) $ checkOracle oracle void $ activateContractWallet (Wallet 2) $ checkOracle oracle
callEndpoint @"update" h 1_500_000 callEndpoint @"update" h1 1_500_000
void $ Emulator.waitNSlots 3 void $ Emulator.waitNSlots 3
void $ activateContractWallet (Wallet 3) (offerSwap oracle 10_000_000 :: Contract () BlockchainActions Text ()) h3 <- activateContractWallet (Wallet 3) $ swap oracle
void $ activateContractWallet (Wallet 4) (offerSwap oracle 20_000_000 :: Contract () BlockchainActions Text ()) h4 <- activateContractWallet (Wallet 4) $ swap oracle
h5 <- activateContractWallet (Wallet 5) $ swap oracle
callEndpoint @"offer" h3 10_000_000
callEndpoint @"offer" h4 20_000_000
void $ Emulator.waitNSlots 3 void $ Emulator.waitNSlots 3
void $ activateContractWallet (Wallet 5) (useSwap oracle :: Contract () BlockchainActions Text ()) callEndpoint @"use" h5 ()
void $ Emulator.waitNSlots 3 void $ Emulator.waitNSlots 3
callEndpoint @"update" h 1_700_000 callEndpoint @"update" h1 1_700_000
void $ Emulator.waitNSlots 3 void $ Emulator.waitNSlots 3
void $ activateContractWallet (Wallet 5) (useSwap oracle :: Contract () BlockchainActions Text ()) callEndpoint @"use" h5 ()
void $ Emulator.waitNSlots 3 void $ Emulator.waitNSlots 3
callEndpoint @"update" h 1_800_000 callEndpoint @"update" h1 1_800_000
void $ Emulator.waitNSlots 3 void $ Emulator.waitNSlots 3
void $ activateContractWallet (Wallet 3) (retrieveSwaps oracle :: Contract () BlockchainActions Text ()) callEndpoint @"retrieve" h3 ()
void $ activateContractWallet (Wallet 4) (retrieveSwaps oracle :: Contract () BlockchainActions Text ()) callEndpoint @"retrieve" h4 ()
void $ Emulator.waitNSlots 3 void $ Emulator.waitNSlots 3
callEndpoint @"funds" h3 ()
callEndpoint @"funds" h4 ()
callEndpoint @"funds" h5 ()
where where
getOracle :: ContractHandle (Last Oracle) OracleSchema Text -> EmulatorTrace Oracle getOracle :: ContractHandle (Last Oracle) OracleSchema Text -> EmulatorTrace Oracle
getOracle h = do getOracle h = do