getting funds

code/week10/app/Uniswap.hs

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

code/week10/app/uniswap-client.hs

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

code/week10/app/uniswap-pab.hs

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

code/week10/plutus-pioneer-program-week10.cabal

@@ -66,6 +66,7 @@ executable uniswap-client
                      , plutus-ledger
                      , plutus-pab
                      , plutus-use-cases
+                     , prettyprinter
                      , req ^>= 3.9.0
                      , text
                      , uuid