diff --git a/code/week10/app/Uniswap.hs b/code/week10/app/Uniswap.hs index cbbe17f..676898d 100644 --- a/code/week10/app/Uniswap.hs +++ b/code/week10/app/Uniswap.hs @@ -13,14 +13,28 @@ module Uniswap where import Control.Monad (forM_, when) +import Data.Aeson (FromJSON, ToJSON) import qualified Data.Semigroup as Semigroup +import Data.Text.Prettyprint.Doc (Pretty (..), viaShow) +import GHC.Generics (Generic) import Ledger import Ledger.Constraints import Ledger.Value as Value import Plutus.Contract hiding (when) import qualified Plutus.Contracts.Currency as Currency +import qualified Plutus.Contracts.Uniswap as Uniswap import Wallet.Emulator.Types (Wallet (..), walletPubKey) +data UniswapContracts = + Init + | UniswapStart + | UniswapUser Uniswap.Uniswap + deriving (Eq, Ord, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Pretty UniswapContracts where + pretty = viaShow + initContract :: Contract (Maybe (Semigroup.Last Currency.OneShotCurrency)) Currency.CurrencySchema Currency.CurrencyError () initContract = do ownPK <- pubKeyHash <$> ownPubKey diff --git a/code/week10/app/uniswap-client.hs b/code/week10/app/uniswap-client.hs index d4ba46b..c8a8e8f 100644 --- a/code/week10/app/uniswap-client.hs +++ b/code/week10/app/uniswap-client.hs @@ -8,16 +8,17 @@ module Main import Control.Concurrent import Control.Exception +import Control.Monad (forever) import Control.Monad.IO.Class (MonadIO (..)) import Data.Aeson (Result (..), decode, fromJSON) import qualified Data.ByteString.Lazy as LB import Data.Monoid (Last (..)) import Data.Proxy (Proxy (..)) -import Data.Text (pack) +import Data.Text (Text, pack) import Data.UUID import Ledger.Value (flattenValue) import Network.HTTP.Req -import Plutus.Contracts.Uniswap (Uniswap) +import Plutus.Contracts.Uniswap (Uniswap, UserContractState (..)) import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse (..)) import Plutus.PAB.Webserver.Types import System.Environment (getArgs) @@ -26,7 +27,7 @@ import System.IO import Text.Read (readMaybe) import Wallet.Emulator.Types (Wallet (..)) -import Uniswap (cidFile) +import Uniswap (cidFile, UniswapContracts) main :: IO () main = do @@ -36,8 +37,37 @@ main = do case mus of Nothing -> putStrLn "invalid uniswap.json" >> exitFailure Just us -> do - putStrLn $ "cid: " ++ show (cid :: UUID) + putStrLn $ "cid: " ++ show cid putStrLn $ "uniswap: " ++ show (us :: Uniswap) + forever $ do + getFunds cid + threadDelay 1_000_000 + +getFunds :: UUID -> IO () +getFunds uuid = handle h $ runReq defaultHttpConfig $ do + v <- req + POST + (http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "endpoint" /: "funds") + (ReqBodyJson ()) + (Proxy :: Proxy (JsonResponse ())) + (port 8080) + if responseStatusCode v /= 200 + then liftIO $ putStrLn "error getting funds" + else do + liftIO $ threadDelay 2_000_000 + w <- req + GET + (http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "status") + NoReqBody + (Proxy :: Proxy (JsonResponse (ContractInstanceClientState UniswapContracts))) + (port 8080) + liftIO $ putStrLn $ case fromJSON $ observableState $ cicCurrentState $ responseBody w of + Success (Last (Just (Right (Funds f)))) -> "funds: " ++ show (flattenValue f) + Success (Last (Just (Left e))) -> "error: " ++ show (e :: Text) + _ -> "error decoding state" + where + h :: HttpException -> IO () + h _ = threadDelay 1_000_000 >> getFunds uuid {- [i :: Int] <- map read <$> getArgs uuid <- read <$> readFile ('W' : show i ++ ".cid") @@ -64,30 +94,6 @@ main = do data Command = Offer Integer | Retrieve | Use | Funds deriving (Show, Read, Eq, Ord) -getFunds :: UUID -> IO () -getFunds uuid = handle h $ runReq defaultHttpConfig $ do - v <- req - POST - (http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "endpoint" /: "funds") - (ReqBodyJson ()) - (Proxy :: Proxy (JsonResponse ())) - (port 8080) - if responseStatusCode v /= 200 - then liftIO $ putStrLn "error getting funds" - else do - w <- req - GET - (http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "status") - NoReqBody - (Proxy :: Proxy (JsonResponse (ContractInstanceClientState OracleContracts))) - (port 8080) - liftIO $ putStrLn $ case fromJSON $ observableState $ cicCurrentState $ responseBody w of - Success (Last (Just f)) -> "funds: " ++ show (flattenValue f) - _ -> "error decoding state" - where - h :: HttpException -> IO () - h _ = threadDelay 1_000_000 >> getFunds uuid - offer :: UUID -> Integer -> IO () offer uuid amt = handle h $ runReq defaultHttpConfig $ do v <- req diff --git a/code/week10/app/uniswap-pab.hs b/code/week10/app/uniswap-pab.hs index c32d567..202cc9c 100644 --- a/code/week10/app/uniswap-pab.hs +++ b/code/week10/app/uniswap-pab.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} @@ -18,13 +17,11 @@ import Control.Monad.Freer (Eff, Member, interpret, ty import Control.Monad.Freer.Error (Error) import Control.Monad.Freer.Extras.Log (LogMsg) import Control.Monad.IO.Class (MonadIO (..)) -import Data.Aeson (FromJSON, Result (..), ToJSON, encode, fromJSON) +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 Data.Text.Prettyprint.Doc (Pretty (..), viaShow) -import GHC.Generics (Generic) import Plutus.Contract import qualified Plutus.Contracts.Currency as Currency import qualified Plutus.Contracts.Uniswap as Uniswap @@ -37,10 +34,11 @@ 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 Uniswap as US 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." @@ -70,16 +68,6 @@ main = void $ Simulator.runSimulationWith handlers $ do shutdown -data UniswapContracts = - Init - | UniswapStart - | UniswapUser Uniswap.Uniswap - deriving (Eq, Ord, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -instance Pretty UniswapContracts where - pretty = viaShow - handleUniswapContract :: ( Member (Error PABError) effs , Member (LogMsg (PABMultiAgentMsg (Builtin UniswapContracts))) effs diff --git a/code/week10/plutus-pioneer-program-week10.cabal b/code/week10/plutus-pioneer-program-week10.cabal index eae700e..a554631 100644 --- a/code/week10/plutus-pioneer-program-week10.cabal +++ b/code/week10/plutus-pioneer-program-week10.cabal @@ -66,6 +66,7 @@ executable uniswap-client , plutus-ledger , plutus-pab , plutus-use-cases + , prettyprinter , req ^>= 3.9.0 , text , uuid