mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-24 15:52:00 +01:00
refactoring and creating poolw
This commit is contained in:
Lars Brünjes
parent
f09f5ddc4f
commit
1012f99d4a
3 changed files with 80 additions and 135 deletions
1
code/week10/.gitignore
vendored
1
code/week10/.gitignore
vendored
|
|
@ -1,6 +1,5 @@
|
|||
dist-newstyle/
|
||||
symbol.json
|
||||
uniswap.json
|
||||
W1.cid
|
||||
W2.cid
|
||||
W3.cid
|
||||
|
|
|
|||
|
|
@ -8,22 +8,22 @@ module Main
|
|||
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad (forever)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (MonadIO (..))
|
||||
import Data.Aeson (Result (..), decode, fromJSON)
|
||||
import Data.Aeson (Result (..), ToJSON, decode, fromJSON)
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Monoid (Last (..))
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.String (IsString (..))
|
||||
import Data.Text (Text, pack)
|
||||
import Data.UUID
|
||||
import Ledger.Value (CurrencySymbol, flattenValue)
|
||||
import Data.UUID hiding (fromString)
|
||||
import Ledger.Value (AssetClass (..), CurrencySymbol, flattenValue)
|
||||
import Network.HTTP.Req
|
||||
import qualified Plutus.Contracts.Uniswap as US
|
||||
import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse (..))
|
||||
import Plutus.PAB.Webserver.Types
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO
|
||||
import Text.Read (readMaybe)
|
||||
import Wallet.Emulator.Types (Wallet (..))
|
||||
|
||||
|
|
@ -33,154 +33,101 @@ main :: IO ()
|
|||
main = do
|
||||
w <- Wallet . read . head <$> getArgs
|
||||
cid <- read <$> readFile (cidFile w)
|
||||
mus <- decode <$> LB.readFile "uniswap.json"
|
||||
mcs <- decode <$> LB.readFile "symbol.json"
|
||||
case (mus, mcs) of
|
||||
(Just us, Just cs) -> do
|
||||
case mcs of
|
||||
Nothing -> putStrLn "invalid symbol.json" >> exitFailure
|
||||
Just cs -> do
|
||||
putStrLn $ "cid: " ++ show cid
|
||||
putStrLn $ "uniswap: " ++ show (us :: US.Uniswap)
|
||||
putStrLn $ "symbol: " ++ show (cs :: CurrencySymbol)
|
||||
go cid
|
||||
_ -> putStrLn "invalid uniswap.json and/or symbol.json" >> exitFailure
|
||||
go cid cs
|
||||
where
|
||||
go :: UUID -> IO a
|
||||
go cid = do
|
||||
go :: UUID -> CurrencySymbol -> IO a
|
||||
go cid cs = do
|
||||
cmd <- readCommandIO
|
||||
case cmd of
|
||||
Funds -> getFunds cid
|
||||
Pools -> getPools cid
|
||||
go cid
|
||||
Create amtA tnA amtB tnB -> createPool cid $ toCreateParams cs amtA tnA amtB tnB
|
||||
go cid cs
|
||||
|
||||
data Command = Funds | Pools
|
||||
data Command =
|
||||
Funds
|
||||
| Pools
|
||||
| Create Integer Char Integer Char
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
|
||||
readCommandIO :: IO Command
|
||||
readCommandIO = do
|
||||
putStrLn "Enter a command: Funds, Pools"
|
||||
putStrLn "Enter a command: Funds, Pools, Create amtA tnA amtB tnB"
|
||||
s <- getLine
|
||||
maybe readCommandIO return $ readMaybe s
|
||||
|
||||
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 (US.Funds f)))) -> "funds: " ++ show (flattenValue f)
|
||||
Success (Last (Just (Left e))) -> "error: " ++ show (e :: Text)
|
||||
_ -> "error decoding state"
|
||||
toCreateParams :: CurrencySymbol -> Integer -> Char -> Integer -> Char -> US.CreateParams
|
||||
toCreateParams cs amtA tnA amtB tnB = US.CreateParams (toCoin tnA) (toCoin tnB) (US.Amount amtA) (US.Amount amtB)
|
||||
where
|
||||
h :: HttpException -> IO ()
|
||||
h _ = threadDelay 1_000_000 >> getFunds uuid
|
||||
toCoin :: Char -> US.Coin c
|
||||
toCoin tn = US.Coin $ AssetClass (cs, fromString [tn])
|
||||
|
||||
getFunds :: UUID -> IO ()
|
||||
getFunds cid = do
|
||||
callEndpoint cid "funds" ()
|
||||
threadDelay 2_000_000
|
||||
go
|
||||
where
|
||||
go = do
|
||||
e <- getStatus cid
|
||||
case e of
|
||||
Right (US.Funds v) -> putStrLn $ "funds: " ++ show (flattenValue v)
|
||||
_ -> go
|
||||
|
||||
getPools :: UUID -> IO ()
|
||||
getPools uuid = handle h $ runReq defaultHttpConfig $ do
|
||||
v <- req
|
||||
POST
|
||||
(http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "endpoint" /: "pools")
|
||||
(ReqBodyJson ())
|
||||
(Proxy :: Proxy (JsonResponse ()))
|
||||
(port 8080)
|
||||
if responseStatusCode v /= 200
|
||||
then liftIO $ putStrLn "error getting funds"
|
||||
else do
|
||||
liftIO $ threadDelay 2_000_000
|
||||
getPools cid = do
|
||||
callEndpoint cid "pools" ()
|
||||
threadDelay 2_000_000
|
||||
go
|
||||
where
|
||||
go = do
|
||||
e <- getStatus cid
|
||||
case e of
|
||||
Right (US.Pools ps) -> putStrLn $ "pools: " ++ show ps
|
||||
_ -> go
|
||||
|
||||
createPool :: UUID -> US.CreateParams -> IO ()
|
||||
createPool cid cps = do
|
||||
callEndpoint cid "create" cps
|
||||
threadDelay 2_000_000
|
||||
go
|
||||
where
|
||||
go = do
|
||||
e <- getStatus cid
|
||||
case e of
|
||||
Right US.Created -> putStrLn "created"
|
||||
Left err' -> putStrLn $ "error: " ++ show err'
|
||||
_ -> go
|
||||
|
||||
getStatus :: UUID -> IO (Either Text US.UserContractState)
|
||||
getStatus cid = runReq defaultHttpConfig $ do
|
||||
w <- req
|
||||
GET
|
||||
(http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "status")
|
||||
(http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show cid) /: "status")
|
||||
NoReqBody
|
||||
(Proxy :: Proxy (JsonResponse (ContractInstanceClientState UniswapContracts)))
|
||||
(port 8080)
|
||||
liftIO $ putStrLn $ case fromJSON $ observableState $ cicCurrentState $ responseBody w of
|
||||
Success (Last (Just (Right (US.Pools ps)))) -> "pools: " ++ show ps
|
||||
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")
|
||||
hSetBuffering stdout NoBuffering
|
||||
putStrLn $ "swap contract instance id for Wallet " ++ show i ++ ": " ++ show uuid
|
||||
go uuid
|
||||
where
|
||||
go :: UUID -> IO a
|
||||
go uuid = do
|
||||
cmd <- readCommand
|
||||
case cmd of
|
||||
Offer amt -> offer uuid amt
|
||||
Retrieve -> retrieve uuid
|
||||
Use -> use uuid
|
||||
Funds -> getFunds uuid
|
||||
go uuid
|
||||
case fromJSON $ observableState $ cicCurrentState $ responseBody w of
|
||||
Success (Last Nothing) -> liftIO $ threadDelay 1_000_000 >> getStatus cid
|
||||
Success (Last (Just e)) -> return e
|
||||
_ -> liftIO $ ioError $ userError "error decoding state"
|
||||
|
||||
readCommand :: IO Command
|
||||
readCommand = do
|
||||
putStr "enter command (Offer amt, Retrieve, Use or Funds): "
|
||||
s <- getLine
|
||||
maybe readCommand return $ readMaybe s
|
||||
|
||||
data Command = Offer Integer | Retrieve | Use | Funds
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
|
||||
offer :: UUID -> Integer -> IO ()
|
||||
offer uuid amt = handle h $ runReq defaultHttpConfig $ do
|
||||
callEndpoint :: ToJSON a => UUID -> String -> a -> IO ()
|
||||
callEndpoint cid name a = handle h $ runReq defaultHttpConfig $ do
|
||||
v <- req
|
||||
POST
|
||||
(http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "endpoint" /: "offer")
|
||||
(ReqBodyJson amt)
|
||||
(http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show cid) /: "endpoint" /: pack name)
|
||||
(ReqBodyJson a)
|
||||
(Proxy :: Proxy (JsonResponse ()))
|
||||
(port 8080)
|
||||
liftIO $ putStrLn $ if responseStatusCode v == 200
|
||||
then "offered swap of " ++ show amt ++ " lovelace"
|
||||
else "error offering swap"
|
||||
when (responseStatusCode v /= 200) $
|
||||
liftIO $ ioError $ userError $ "error calling endpoint " ++ name
|
||||
where
|
||||
h :: HttpException -> IO ()
|
||||
h _ = threadDelay 1_000_000 >> offer uuid amt
|
||||
|
||||
retrieve :: UUID -> IO ()
|
||||
retrieve uuid = handle h $ runReq defaultHttpConfig $ do
|
||||
v <- req
|
||||
POST
|
||||
(http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "endpoint" /: "retrieve")
|
||||
(ReqBodyJson ())
|
||||
(Proxy :: Proxy (JsonResponse ()))
|
||||
(port 8080)
|
||||
liftIO $ putStrLn $ if responseStatusCode v == 200
|
||||
then "retrieved swaps"
|
||||
else "error retrieving swaps"
|
||||
where
|
||||
h :: HttpException -> IO ()
|
||||
h _ = threadDelay 1_000_000 >> retrieve uuid
|
||||
|
||||
use :: UUID -> IO ()
|
||||
use uuid = handle h $ runReq defaultHttpConfig $ do
|
||||
v <- req
|
||||
POST
|
||||
(http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "endpoint" /: "use")
|
||||
(ReqBodyJson ())
|
||||
(Proxy :: Proxy (JsonResponse ()))
|
||||
(port 8080)
|
||||
liftIO $ putStrLn $ if responseStatusCode v == 200
|
||||
then "used swap"
|
||||
else "error using swap"
|
||||
where
|
||||
h :: HttpException -> IO ()
|
||||
h _ = threadDelay 1_000_000 >> use uuid
|
||||
|
||||
|
||||
-}
|
||||
h = ioError . userError . show
|
||||
|
|
|
|||
|
|
@ -57,7 +57,6 @@ main = void $ Simulator.runSimulationWith handlers $ do
|
|||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue