mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-22 06:42:00 +01:00
refactoring
This commit is contained in:
Lars Brünjes
parent
395ebef4a8
commit
b5ce65494d
2 changed files with 81 additions and 31 deletions
|
|
@ -15,50 +15,75 @@ module Main
|
||||||
( main
|
( main
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad (void)
|
import Control.Monad (forM_, void, when)
|
||||||
import Control.Monad.Freer (Eff, Member, interpret, type (~>))
|
import Control.Monad.Freer (Eff, Member, interpret, type (~>))
|
||||||
import Control.Monad.Freer.Error (Error)
|
import Control.Monad.Freer.Error (Error)
|
||||||
import Control.Monad.Freer.Extras.Log (LogMsg)
|
import Control.Monad.Freer.Extras.Log (LogMsg)
|
||||||
import Control.Monad.IO.Class (MonadIO (..))
|
import Control.Monad.IO.Class (MonadIO (..))
|
||||||
import Data.Aeson (FromJSON, ToJSON)
|
import Data.Aeson (FromJSON, ToJSON, Result (..), fromJSON)
|
||||||
import Data.Text.Prettyprint.Doc (Pretty (..), viaShow)
|
import Data.Monoid (Last (..))
|
||||||
import GHC.Generics (Generic)
|
import Data.Text (Text, pack)
|
||||||
import Plutus.Contract (BlockchainActions, ContractError)
|
import Data.Text.Prettyprint.Doc (Pretty (..), viaShow)
|
||||||
import Plutus.PAB.Effects.Contract (ContractEffect (..))
|
import GHC.Generics (Generic)
|
||||||
import Plutus.PAB.Effects.Contract.Builtin (Builtin, SomeBuiltin (..), type (.\\), endpointsToSchemas, handleBuiltin)
|
import Ledger
|
||||||
import Plutus.PAB.Effects.ContractTest.Uniswap as US
|
import Ledger.Constraints
|
||||||
import Plutus.PAB.Monitoring.PABLogMsg (PABMultiAgentMsg)
|
import qualified Ledger.Value as Value
|
||||||
import Plutus.PAB.Simulator (SimulatorEffectHandlers)
|
import Plutus.Contract hiding (when)
|
||||||
import qualified Plutus.PAB.Simulator as Simulator
|
import Plutus.PAB.Effects.Contract (ContractEffect (..))
|
||||||
import Plutus.PAB.Types (PABError (..))
|
import Plutus.PAB.Effects.Contract.Builtin (Builtin, SomeBuiltin (..), type (.\\), endpointsToSchemas, handleBuiltin)
|
||||||
import qualified Plutus.PAB.Webserver.Server as PAB.Server
|
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 qualified Plutus.Contracts.Currency as Currency
|
||||||
|
|
||||||
import Wallet.Emulator.Types (Wallet (..))
|
import Wallet.Emulator.Types (Wallet (..), walletPubKey)
|
||||||
|
|
||||||
import qualified Week06.Oracle.Core as Oracle
|
import qualified Week06.Oracle.Core as Oracle
|
||||||
import qualified Week06.Oracle.Swap as Oracle
|
import qualified Week06.Oracle.Funds as Oracle
|
||||||
|
import qualified Week06.Oracle.Swap as Oracle
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = void $ Simulator.runSimulationWith handlers $ do
|
main = void $ Simulator.runSimulationWith handlers $ do
|
||||||
Simulator.logString @(Builtin OracleContracts) "Starting Oracle PAB webserver on port 8080. Press enter to exit."
|
Simulator.logString @(Builtin OracleContracts) "Starting Oracle PAB webserver. Press enter to exit."
|
||||||
shutdown <- PAB.Server.startServerDebug
|
shutdown <- PAB.Server.startServerDebug
|
||||||
|
|
||||||
cidOracle <- Simulator.activateContract (Wallet 1) Oracle
|
forM_ wallets $ \w ->
|
||||||
|
void $ Simulator.activateContract w Funds
|
||||||
|
|
||||||
|
cidInit <- Simulator.activateContract (Wallet 1) Init
|
||||||
|
cs <- waitForLast cidInit
|
||||||
|
_ <- Simulator.waitUntilFinished cidInit
|
||||||
|
|
||||||
|
cidOracle <- Simulator.activateContract (Wallet 1) $ Oracle cs
|
||||||
|
|
||||||
void $ liftIO getLine
|
void $ liftIO getLine
|
||||||
shutdown
|
shutdown
|
||||||
|
|
||||||
data OracleContracts = Oracle | Swap Oracle.Oracle
|
waitForLast :: FromJSON a => ContractInstanceId -> Simulator.Simulation t a
|
||||||
|
waitForLast cid =
|
||||||
|
flip Simulator.waitForState cid $ \json -> case fromJSON json of
|
||||||
|
Success (Last (Just x)) -> Just x
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
data OracleContracts = Init | Oracle CurrencySymbol | Funds | Swap Oracle.Oracle
|
||||||
deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
|
deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
|
||||||
|
|
||||||
instance Pretty OracleContracts where
|
instance Pretty OracleContracts where
|
||||||
pretty = viaShow
|
pretty = viaShow
|
||||||
|
|
||||||
oracleParams :: Oracle.OracleParams
|
wallets :: [Wallet]
|
||||||
oracleParams = Oracle.OracleParams
|
wallets = [Wallet i | i <- [1 .. 5]]
|
||||||
|
|
||||||
|
usdt :: TokenName
|
||||||
|
usdt = "USDT"
|
||||||
|
|
||||||
|
oracleParams :: CurrencySymbol -> Oracle.OracleParams
|
||||||
|
oracleParams cs = Oracle.OracleParams
|
||||||
{ Oracle.opFees = 1_000_000
|
{ Oracle.opFees = 1_000_000
|
||||||
, Oracle.opSymbol = "ff"
|
, Oracle.opSymbol = cs
|
||||||
, Oracle.opToken = "USDT"
|
, Oracle.opToken = usdt
|
||||||
}
|
}
|
||||||
|
|
||||||
handleOracleContracts ::
|
handleOracleContracts ::
|
||||||
|
|
@ -69,13 +94,36 @@ handleOracleContracts ::
|
||||||
~> Eff effs
|
~> Eff effs
|
||||||
handleOracleContracts = handleBuiltin getSchema getContract where
|
handleOracleContracts = handleBuiltin getSchema getContract where
|
||||||
getSchema = \case
|
getSchema = \case
|
||||||
Oracle -> endpointsToSchemas @(Oracle.OracleSchema .\\ BlockchainActions)
|
Init -> endpointsToSchemas @Empty
|
||||||
Swap _ -> endpointsToSchemas @(Oracle.SwapSchema .\\ BlockchainActions)
|
Oracle _ -> endpointsToSchemas @(Oracle.OracleSchema .\\ BlockchainActions)
|
||||||
|
Funds -> endpointsToSchemas @Empty
|
||||||
|
Swap _ -> endpointsToSchemas @(Oracle.SwapSchema .\\ BlockchainActions)
|
||||||
getContract = \case
|
getContract = \case
|
||||||
Oracle -> SomeBuiltin $ Oracle.runOracle oracleParams
|
Init -> SomeBuiltin initContract
|
||||||
|
Oracle cs -> SomeBuiltin $ Oracle.runOracle $ oracleParams cs
|
||||||
|
Funds -> SomeBuiltin $ Oracle.ownFunds'
|
||||||
Swap oracle -> SomeBuiltin $ Oracle.swap oracle
|
Swap oracle -> SomeBuiltin $ Oracle.swap oracle
|
||||||
|
|
||||||
handlers :: SimulatorEffectHandlers (Builtin OracleContracts)
|
handlers :: SimulatorEffectHandlers (Builtin OracleContracts)
|
||||||
handlers =
|
handlers =
|
||||||
Simulator.mkSimulatorHandlers @(Builtin OracleContracts) []
|
Simulator.mkSimulatorHandlers @(Builtin OracleContracts) []
|
||||||
$ interpret handleOracleContracts
|
$ interpret handleOracleContracts
|
||||||
|
|
||||||
|
initContract :: Contract (Last CurrencySymbol) BlockchainActions Text ()
|
||||||
|
initContract = do
|
||||||
|
ownPK <- pubKeyHash <$> ownPubKey
|
||||||
|
cur <-
|
||||||
|
mapError (pack . show)
|
||||||
|
(Currency.forgeContract ownPK [(usdt, fromIntegral (length wallets) * amount)]
|
||||||
|
:: Contract (Last CurrencySymbol) BlockchainActions Currency.CurrencyError Currency.OneShotCurrency)
|
||||||
|
let cs = Currency.currencySymbol cur
|
||||||
|
v = Value.singleton cs usdt amount
|
||||||
|
forM_ wallets $ \w -> do
|
||||||
|
let pkh = pubKeyHash $ walletPubKey w
|
||||||
|
when (pkh /= ownPK) $ do
|
||||||
|
tx <- submitTx $ mustPayToPubKey pkh v
|
||||||
|
awaitTxConfirmed $ txId tx
|
||||||
|
tell $ Last $ Just cs
|
||||||
|
where
|
||||||
|
amount :: Integer
|
||||||
|
amount = 100_000_000
|
||||||
|
|
|
||||||
|
|
@ -34,7 +34,7 @@ library
|
||||||
executable oracle
|
executable oracle
|
||||||
main-is: oracle.hs
|
main-is: oracle.hs
|
||||||
hs-source-dirs: app
|
hs-source-dirs: app
|
||||||
ghc-options: -threaded
|
ghc-options: -Wall -threaded
|
||||||
build-depends: aeson
|
build-depends: aeson
|
||||||
, base ^>= 4.14.1.0
|
, base ^>= 4.14.1.0
|
||||||
, freer-extras
|
, freer-extras
|
||||||
|
|
@ -43,4 +43,6 @@ executable oracle
|
||||||
, plutus-ledger
|
, plutus-ledger
|
||||||
, plutus-pab
|
, plutus-pab
|
||||||
, plutus-pioneer-program-week06
|
, plutus-pioneer-program-week06
|
||||||
|
, plutus-use-cases
|
||||||
, prettyprinter
|
, prettyprinter
|
||||||
|
, text
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue