mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-13 10:22:34 +01:00
started with oracle PAB
This commit is contained in:
parent
af90b54f0e
commit
2643aa2cb2
7 changed files with 164 additions and 21 deletions
79
code/week06/app/oracle.hs
Normal file
79
code/week06/app/oracle.hs
Normal 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
|
|
@ -19,6 +19,7 @@ source-repository-package
|
|||
plutus-contract
|
||||
plutus-ledger
|
||||
plutus-ledger-api
|
||||
plutus-pab
|
||||
plutus-tx
|
||||
plutus-tx-plugin
|
||||
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
|
||||
-- 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
|
||||
ghc-options: -XDerivingStrategies -XStandaloneDeriving -XUndecidableInstances -XDataKinds -XFlexibleInstances
|
||||
|
||||
|
@ -48,6 +52,15 @@ allow-newer:
|
|||
constraints:
|
||||
-- aws-lambda-haskell-runtime-wai doesn't compile with newer versions
|
||||
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)
|
||||
source-repository-package
|
||||
|
@ -65,12 +78,6 @@ source-repository-package
|
|||
location: https://github.com/input-output-hk/cardano-crypto.git
|
||||
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
|
||||
type: git
|
||||
location: https://github.com/input-output-hk/cardano-base
|
||||
|
|
|
@ -2,3 +2,5 @@ cradle:
|
|||
cabal:
|
||||
- path: "./src"
|
||||
component: "lib:plutus-pioneer-program-week06"
|
||||
- path: "./app/oracle.hs"
|
||||
component: "exe:oracle"
|
||||
|
|
|
@ -29,3 +29,17 @@ library
|
|||
, text
|
||||
default-language: Haskell2010
|
||||
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
|
||||
|
|
|
@ -42,13 +42,14 @@ import Ledger.Value as Value
|
|||
import Ledger.Ada as Ada
|
||||
import Plutus.Contracts.Currency as Currency
|
||||
import Prelude (Semigroup (..))
|
||||
import qualified Prelude as Prelude
|
||||
|
||||
data Oracle = Oracle
|
||||
{ oSymbol :: !CurrencySymbol
|
||||
, oOperator :: !PubKeyHash
|
||||
, oFee :: !Integer
|
||||
, oAsset :: !AssetClass
|
||||
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||
} deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord)
|
||||
|
||||
PlutusTx.makeLift ''Oracle
|
||||
|
||||
|
|
|
@ -12,9 +12,8 @@
|
|||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week06.Oracle.Swap
|
||||
( offerSwap
|
||||
, retrieveSwaps
|
||||
, useSwap
|
||||
( SwapSchema
|
||||
, swap
|
||||
) where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
|
@ -199,3 +198,37 @@ useSwap oracle = do
|
|||
|
||||
f :: Integer -> Integer -> (TxOutRef, TxOutTx, PubKeyHash) -> Bool
|
||||
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
|
||||
|
|
|
@ -64,35 +64,42 @@ myTrace = do
|
|||
, opToken = assetToken
|
||||
}
|
||||
|
||||
h <- activateContractWallet (Wallet 1) $ runOracle op
|
||||
h1 <- activateContractWallet (Wallet 1) $ runOracle op
|
||||
void $ Emulator.waitNSlots 1
|
||||
oracle <- getOracle h
|
||||
oracle <- getOracle h1
|
||||
|
||||
void $ activateContractWallet (Wallet 2) $ checkOracle oracle
|
||||
|
||||
callEndpoint @"update" h 1_500_000
|
||||
callEndpoint @"update" h1 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 ())
|
||||
h3 <- activateContractWallet (Wallet 3) $ swap oracle
|
||||
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 $ activateContractWallet (Wallet 5) (useSwap oracle :: Contract () BlockchainActions Text ())
|
||||
callEndpoint @"use" h5 ()
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
callEndpoint @"update" h 1_700_000
|
||||
callEndpoint @"update" h1 1_700_000
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
void $ activateContractWallet (Wallet 5) (useSwap oracle :: Contract () BlockchainActions Text ())
|
||||
callEndpoint @"use" h5 ()
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
callEndpoint @"update" h 1_800_000
|
||||
callEndpoint @"update" h1 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 ())
|
||||
callEndpoint @"retrieve" h3 ()
|
||||
callEndpoint @"retrieve" h4 ()
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
callEndpoint @"funds" h3 ()
|
||||
callEndpoint @"funds" h4 ()
|
||||
callEndpoint @"funds" h5 ()
|
||||
where
|
||||
getOracle :: ContractHandle (Last Oracle) OracleSchema Text -> EmulatorTrace Oracle
|
||||
getOracle h = do
|
||||
|
|
Loading…
Reference in a new issue