Skip to content

Commit

Permalink
refactoring and creating poolw
Browse files Browse the repository at this point in the history
  • Loading branch information
@brunjlar
brunjlar committed Jun 8, 2021
1 parent f09f5dd commit 1012f99
Show file tree
Hide file tree
Showing 3 changed files with 73 additions and 128 deletions.
1 change: 0 additions & 1 deletion code/week10/.gitignore
View file
@@ -1,6 +1,5 @@
dist-newstyle/
symbol.json
uniswap.json
W1.cid
W2.cid
W3.cid
Expand Down
199 changes: 73 additions & 126 deletions code/week10/app/uniswap-client.hs
View file
Expand Up @@ -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 (..))

Expand All @@ -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

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
toCoin :: Char -> US.Coin c
toCoin tn = US.Coin $ AssetClass (cs, fromString [tn])

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"
getFunds cid = do
callEndpoint cid "funds" ()
threadDelay 2_000_000
go
where
h :: HttpException -> IO ()
h _ = threadDelay 1_000_000 >> getFunds uuid
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
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"
getPools cid = do
callEndpoint cid "pools" ()
threadDelay 2_000_000
go
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
go = do
e <- getStatus cid
case e of
Right (US.Pools ps) -> putStrLn $ "pools: " ++ show ps
_ -> go

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"
createPool :: UUID -> US.CreateParams -> IO ()
createPool cid cps = do
callEndpoint cid "create" cps
threadDelay 2_000_000
go
where
h :: HttpException -> IO ()
h _ = threadDelay 1_000_000 >> offer uuid amt
go = do
e <- getStatus cid
case e of
Right US.Created -> putStrLn "created"
Left err' -> putStrLn $ "error: " ++ show err'
_ -> go

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 ()))
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)
liftIO $ putStrLn $ if responseStatusCode v == 200
then "retrieved swaps"
else "error retrieving swaps"
where
h :: HttpException -> IO ()
h _ = threadDelay 1_000_000 >> retrieve 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"

use :: UUID -> IO ()
use uuid = 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" /: "use")
(ReqBodyJson ())
(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 "used swap"
else "error using swap"
when (responseStatusCode v /= 200) $
liftIO $ ioError $ userError $ "error calling endpoint " ++ name
where
h :: HttpException -> IO ()
h _ = threadDelay 1_000_000 >> use uuid
-}
h = ioError . userError . show
1 change: 0 additions & 1 deletion code/week10/app/uniswap-pab.hs
View file
Expand Up @@ -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
Expand Down

0 comments on commit 1012f99

Please sign in to comment.