mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-21 22:32:00 +01:00
getting funds
This commit is contained in:
Lars Brünjes
parent
4e4b7dc900
commit
d80641a9e0
4 changed files with 52 additions and 43 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -66,6 +66,7 @@ executable uniswap-client
|
|||
, plutus-ledger
|
||||
, plutus-pab
|
||||
, plutus-use-cases
|
||||
, prettyprinter
|
||||
, req ^>= 3.9.0
|
||||
, text
|
||||
, uuid
|
||||
|
|
|
|||
Loading…
Reference in a new issue