diff --git a/code/week10/.gitignore b/code/week10/.gitignore index 1da8ff9..64a29ea 100644 --- a/code/week10/.gitignore +++ b/code/week10/.gitignore @@ -1,6 +1,5 @@ dist-newstyle/ symbol.json -uniswap.json W1.cid W2.cid W3.cid diff --git a/code/week10/app/uniswap-client.hs b/code/week10/app/uniswap-client.hs index f7889da..94f7f9f 100644 --- a/code/week10/app/uniswap-client.hs +++ b/code/week10/app/uniswap-client.hs @@ -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 + Funds -> getFunds cid + Pools -> getPools 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 +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 cid) /: "status") + NoReqBody + (Proxy :: Proxy (JsonResponse (ContractInstanceClientState UniswapContracts))) + (port 8080) + 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" + +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" /: "pools") - (ReqBodyJson ()) + (http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show cid) /: "endpoint" /: pack name) + (ReqBodyJson a) (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.Pools ps)))) -> "pools: " ++ show ps - Success (Last (Just (Left e))) -> "error: " ++ show (e :: Text) - _ -> "error decoding state" + when (responseStatusCode v /= 200) $ + liftIO $ ioError $ userError $ "error calling endpoint " ++ name 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 - - 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 - v <- req - POST - (http "127.0.0.1" /: "api" /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "endpoint" /: "offer") - (ReqBodyJson amt) - (Proxy :: Proxy (JsonResponse ())) - (port 8080) - liftIO $ putStrLn $ if responseStatusCode v == 200 - then "offered swap of " ++ show amt ++ " lovelace" - else "error offering swap" - 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 diff --git a/code/week10/app/uniswap-pab.hs b/code/week10/app/uniswap-pab.hs index 36fb74e..5f80588 100644 --- a/code/week10/app/uniswap-pab.hs +++ b/code/week10/app/uniswap-pab.hs @@ -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