mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-25 08:12:00 +01:00
90 lines
4.4 KiB
Haskell
90 lines
4.4 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
module Main
|
|
( main
|
|
) where
|
|
|
|
import Control.Monad (forM_, 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 (Result (..), encode, fromJSON)
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import qualified Data.Monoid as Monoid
|
|
import qualified Data.Semigroup as Semigroup
|
|
import Data.Text (Text)
|
|
import Plutus.Contract
|
|
import qualified Plutus.Contracts.Currency as Currency
|
|
import qualified Plutus.Contracts.Uniswap as Uniswap
|
|
import Plutus.PAB.Effects.Contract (ContractEffect (..))
|
|
import Plutus.PAB.Effects.Contract.Builtin (Builtin, SomeBuiltin (..), type (.\\))
|
|
import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin
|
|
import Plutus.PAB.Monitoring.PABLogMsg (PABMultiAgentMsg)
|
|
import Plutus.PAB.Simulator (SimulatorEffectHandlers, logString)
|
|
import qualified Plutus.PAB.Simulator as Simulator
|
|
import Plutus.PAB.Types (PABError (..))
|
|
import qualified Plutus.PAB.Webserver.Server as PAB.Server
|
|
import Prelude hiding (init)
|
|
import Wallet.Emulator.Types (Wallet (..))
|
|
import Wallet.Types (ContractInstanceId (..))
|
|
|
|
import Uniswap as US
|
|
|
|
main :: IO ()
|
|
main = void $ Simulator.runSimulationWith handlers $ do
|
|
logString @(Builtin UniswapContracts) "Starting Uniswap PAB webserver on port 8080. Press enter to exit."
|
|
shutdown <- PAB.Server.startServerDebug
|
|
|
|
cidInit <- Simulator.activateContract (Wallet 1) Init
|
|
cs <- flip Simulator.waitForState cidInit $ \json -> case fromJSON json of
|
|
Success (Just (Semigroup.Last cur)) -> Just $ Currency.currencySymbol cur
|
|
_ -> Nothing
|
|
_ <- Simulator.waitUntilFinished cidInit
|
|
|
|
logString @(Builtin UniswapContracts) $ "Initialization finished. Minted: " ++ show cs
|
|
|
|
cidStart <- Simulator.activateContract (Wallet 1) UniswapStart
|
|
us <- flip Simulator.waitForState cidStart $ \json -> case (fromJSON json :: Result (Monoid.Last (Either Text Uniswap.Uniswap))) of
|
|
Success (Monoid.Last (Just (Right us))) -> Just us
|
|
_ -> Nothing
|
|
liftIO $ LB.writeFile "uniswap.json" $ encode us
|
|
logString @(Builtin UniswapContracts) $ "Uniswap instance created: " ++ show us
|
|
|
|
forM_ wallets $ \w -> do
|
|
cid <- Simulator.activateContract w $ UniswapUser us
|
|
liftIO $ writeFile (cidFile w) $ show $ unContractInstanceId cid
|
|
logString @(Builtin UniswapContracts) $ "Uniswap user contract started for " ++ show w
|
|
|
|
void $ liftIO getLine
|
|
|
|
shutdown
|
|
|
|
handleUniswapContract ::
|
|
( Member (Error PABError) effs
|
|
, Member (LogMsg (PABMultiAgentMsg (Builtin UniswapContracts))) effs
|
|
)
|
|
=> ContractEffect (Builtin UniswapContracts)
|
|
~> Eff effs
|
|
handleUniswapContract = Builtin.handleBuiltin getSchema getContract where
|
|
getSchema = \case
|
|
UniswapUser _ -> Builtin.endpointsToSchemas @(Uniswap.UniswapUserSchema .\\ BlockchainActions)
|
|
UniswapStart -> Builtin.endpointsToSchemas @(Uniswap.UniswapOwnerSchema .\\ BlockchainActions)
|
|
Init -> Builtin.endpointsToSchemas @Empty
|
|
getContract = \case
|
|
UniswapUser us -> SomeBuiltin $ Uniswap.userEndpoints us
|
|
UniswapStart -> SomeBuiltin Uniswap.ownerEndpoint
|
|
Init -> SomeBuiltin US.initContract
|
|
|
|
handlers :: SimulatorEffectHandlers (Builtin UniswapContracts)
|
|
handlers =
|
|
Simulator.mkSimulatorHandlers @(Builtin UniswapContracts) []
|
|
$ interpret handleUniswapContract
|