refactoring and creating poolw

code/week10/.gitignore

@@ -1,6 +1,5 @@
 dist-newstyle/
 symbol.json
-uniswap.json
 W1.cid
 W2.cid
 W3.cid

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           Data.UUID                               hiding (fromString)
-import           Ledger.Value                            (CurrencySymbol, flattenValue)
+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
+    case mcs of
-        (Just us, Just cs) -> do
+        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
+            go cid cs
-        _ -> putStrLn "invalid uniswap.json and/or symbol.json" >> exitFailure
   where
-    go :: UUID -> IO a
+    go :: UUID -> CurrencySymbol -> IO a
-    go cid = do
+    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 ()
+toCreateParams :: CurrencySymbol -> Integer -> Char -> Integer -> Char -> US.CreateParams
-getFunds uuid = handle h $ runReq defaultHttpConfig $ do
+toCreateParams cs amtA tnA amtB tnB = US.CreateParams (toCoin tnA) (toCoin tnB) (US.Amount amtA) (US.Amount amtB)
-    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"
   where
-    h :: HttpException -> IO ()
+    toCoin :: Char -> US.Coin c
-    h _ = threadDelay 1_000_000 >> getFunds uuid
+    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
-    v <- req
+    callEndpoint cid "pools" ()
-        POST
+    threadDelay 2_000_000
-        (http "127.0.0.1" /: "api"  /: "new" /: "contract" /: "instance" /: pack (show uuid) /: "endpoint" /: "pools")
+    go
-        (ReqBodyJson ())
+  where
-        (Proxy :: Proxy (JsonResponse ()))
+    go = do
-        (port 8080)
+        e <- getStatus cid
-    if responseStatusCode v /= 200
+        case e of
-        then liftIO $ putStrLn "error getting funds"
+            Right (US.Pools ps) -> putStrLn $ "pools: " ++ show ps
-        else do
+            _                   -> go
-            liftIO $ threadDelay 2_000_000
+
+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
+    case fromJSON $ observableState $ cicCurrentState $ responseBody w of
-                Success (Last (Just (Right (US.Pools ps)))) -> "pools: " ++ show ps
+        Success (Last Nothing)  -> liftIO $ threadDelay 1_000_000 >> getStatus cid
-                Success (Last (Just (Left e)))              -> "error: " ++ show (e :: Text)
+        Success (Last (Just e)) -> return e
-                _                                           -> "error decoding state"
+        _                       -> liftIO $ ioError $ userError "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
 
-    readCommand :: IO Command
+callEndpoint :: ToJSON a => UUID -> String -> a -> IO ()
-    readCommand = do
+callEndpoint cid name a = handle h $ runReq defaultHttpConfig $ 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")
+        (http "127.0.0.1" /: "api"  /: "new" /: "contract" /: "instance" /: pack (show cid) /: "endpoint" /: pack name)
-        (ReqBodyJson amt)
+        (ReqBodyJson a)
         (Proxy :: Proxy (JsonResponse ()))
         (port 8080)
-    liftIO $ putStrLn $ if responseStatusCode v == 200
+    when (responseStatusCode v /= 200) $
-        then "offered swap of " ++ show amt ++ " lovelace"
+        liftIO $ ioError $ userError $ "error calling endpoint " ++ name
-        else "error offering swap"
   where
     h :: HttpException -> IO ()
-    h _ = threadDelay 1_000_000 >> offer uuid amt
+    h = ioError . userError . show
-
-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
-
-
--}

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