diff --git a/code/week06/app/oracle.hs b/code/week06/app/oracle.hs new file mode 100644 index 0000000..d4a4824 --- /dev/null +++ b/code/week06/app/oracle.hs @@ -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 diff --git a/code/week06/cabal.project b/code/week06/cabal.project index bb7fb02..996b7db 100644 --- a/code/week06/cabal.project +++ b/code/week06/cabal.project @@ -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 diff --git a/code/week06/hie.yaml b/code/week06/hie.yaml index 50081a2..9be7de5 100644 --- a/code/week06/hie.yaml +++ b/code/week06/hie.yaml @@ -2,3 +2,5 @@ cradle: cabal: - path: "./src" component: "lib:plutus-pioneer-program-week06" + - path: "./app/oracle.hs" + component: "exe:oracle" diff --git a/code/week06/plutus-pioneer-program-week06.cabal b/code/week06/plutus-pioneer-program-week06.cabal index d953a59..1115adb 100644 --- a/code/week06/plutus-pioneer-program-week06.cabal +++ b/code/week06/plutus-pioneer-program-week06.cabal @@ -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 diff --git a/code/week06/src/Week06/Oracle/Core.hs b/code/week06/src/Week06/Oracle/Core.hs index d47acc2..6427de6 100644 --- a/code/week06/src/Week06/Oracle/Core.hs +++ b/code/week06/src/Week06/Oracle/Core.hs @@ -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 diff --git a/code/week06/src/Week06/Oracle/Swap.hs b/code/week06/src/Week06/Oracle/Swap.hs index d3b6d46..1482119 100644 --- a/code/week06/src/Week06/Oracle/Swap.hs +++ b/code/week06/src/Week06/Oracle/Swap.hs @@ -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 diff --git a/code/week06/src/Week06/Oracle/Test.hs b/code/week06/src/Week06/Oracle/Test.hs index fcaf746..f27f07c 100644 --- a/code/week06/src/Week06/Oracle/Test.hs +++ b/code/week06/src/Week06/Oracle/Test.hs @@ -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