Skip to content

Commit

Permalink
Swap after failure works, remove redundant front end parsing
Browse files Browse the repository at this point in the history
  • Loading branch information
@Ericson2314
Ericson2314 committed Sep 24, 2021
1 parent fe23be4 commit b881507
Show file tree
Hide file tree
Showing 3 changed files with 43 additions and 46 deletions.
34 changes: 24 additions & 10 deletions use-case-2/backend/src/Backend.hs
View file
Expand Up @@ -7,6 +7,7 @@

module Backend where

import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad.Identity
Expand Down Expand Up @@ -270,7 +271,7 @@ executeSwap :: Manager
-> String
-> (Coin AssetClass, Amount Integer)
-> (Coin AssetClass, Amount Integer)
-> IO (Either String Aeson.Value)
-> IO (Either Aeson.Value Aeson.Value)
executeSwap httpManager pool contractId (coinA, amountA) (coinB, amountB) = do
let requestUrl = "http://localhost:8080/api/new/contract/instance/" ++ contractId ++ "/endpoint/swap"
reqBody = SwapParams {
Expand Down Expand Up @@ -300,15 +301,28 @@ executeSwap httpManager pool contractId (coinA, amountA) (coinB, amountB) = do
incomingData :: ByteString <- WS.receiveData conn
let val :: Either String Aeson.Value = Aeson.eitherDecode' $ BS.fromStrict incomingData
case val of
Left err -> putMVar eitherObState $ Left err
Right obj -> do
let swapTag = obj ^. key "contents" . key "Right" . key "tag" . _String
txFeeDetails = obj ^. key "contents" . key "Right"
. key "contents" . nth 0 . key "txFee" . key "getValue" . nth 0 . nth 1 . nth 0 . _Array
aesArr = obj ^. key "contents" . key "Right"
. key "contents" . _Array
scrSize = fromMaybe (Aeson.Number 0) $ lastMay $ V.toList aesArr
if swapTag == "Swapped" then putMVar eitherObState $ Right $ (Aeson.Array txFeeDetails, scrSize) else processData
Left err -> do
putStrLn $ "executeSwap: failed to decode response body: " ++ err
processData
Right obj0 ->
case do
obj :: Aeson.Value <- obj0 ^? key "contents"
newObservableStateTag <- incomingData ^? key "tag" . _String
guard $ newObservableStateTag == "NewObservableState"
(<|>)
(fmap Left $ obj ^? key "Left")
(do
let swapTag = obj ^. key "Right" . key "tag" . _String
txFeeDetails = obj ^. key "Right"
. key "contents" . nth 0 . key "txFee" . key "getValue" . nth 0 . nth 1 . nth 0 . _Array
aesArr = obj ^. key "Right"
. key "contents" . _Array
scrSize = fromMaybe (Aeson.Number 0) $ lastMay $ V.toList aesArr
guard $ swapTag == "Swapped"
Just $ Right (Aeson.Array txFeeDetails, scrSize))
of
Just x -> putMVar eitherObState x
Nothing -> processData
fid <- forkIO processData
flip onException (killThread fid) $ do
-- retreive observable state response from result of forked thread
Expand Down
2 changes: 1 addition & 1 deletion use-case-2/common/src/Common/Api.hs
View file
Expand Up @@ -46,7 +46,7 @@ data Api :: * -> * where
-> Coin AssetClass
-> Amount Integer
-> Amount Integer
-> Api (Either String Aeson.Value)
-> Api (Either Aeson.Value Aeson.Value)

Api_Stake
:: ContractInstanceId Text
Expand Down
53 changes: 18 additions & 35 deletions use-case-2/frontend/src/Frontend/Swap.hs
View file
Expand Up @@ -71,7 +71,7 @@ swapDashboard wid = do
el "p" $ text "What would you like to swap?"
-- widget that contains the swap form
divClass "card-group mb-3 text-center" $ do
formDyn <- selectCoins wid pabDMMV
formDyn <- selectCoins wid
transactionDetails pabDMMV formDyn

selectCoins
Expand All @@ -80,9 +80,8 @@ selectCoins
, MonadIO (Performable m)
)
=> Text
-> Dynamic t (Maybe (Maybe Aeson.Value))
-> m (Dynamic t (Maybe ((PooledToken, Text), (PooledToken, Text))))
selectCoins wid pabDMMV = do
selectCoins wid = do
divClass "col" $ divClass "card mb-4 box-shadow h-100 mx-3" $ do
divClass "card-header" $ elClass "h4" "my-0 font-weight-normal" $ text "Select Coins"
divClass "card-body" $ divClass "form container" $ divClass "form-group" $ do
Expand Down Expand Up @@ -146,44 +145,27 @@ selectCoins wid pabDMMV = do
<*> (pooledTokenToCoin <$> selectionB)
<*> (toAmount <$> amountA)
<*> (toAmount <$> amountB)
-- This response returns transaction fee information, it does not return the swap response
-- TODO still, do *something* with it, to handle failure cases?
_responseVal <- requesting $ tagPromptlyDyn requestLoad swap
readyForRequestEE :: Event t (Event t ()) <- dyn $ ffor btnEnabled $ \case
True -> pure never -- waiting for request
False -> do
-- This response returns transaction fee information from the swap response
responseVal <- requestingIdentity $ tagPromptlyDyn requestLoad swap
do
let
observableStateEvent :: Event t Aeson.Value
-- TODO replace join with invalid resp error?
observableStateEvent = flip fmapMaybe (join <$> updated pabDMMV) $
\(mIncomingWebSocketData :: Maybe Aeson.Value) -> do
incomingWebSocketData <- mIncomingWebSocketData
let newObservableStateTag = incomingWebSocketData ^.. key "tag" . _String
guard $ newObservableStateTag == ["NewObservableState"]
incomingWebSocketData ^? key "contents"
observableStateEvent :: Event t (Either Aeson.Value ())
observableStateEvent = void <$> responseVal
observableStateSuccessEvent :: Event t ()
observableStateSuccessEvent = flip fmapMaybe observableStateEvent $ \(incomingWebSocketData :: Aeson.Value)
-> do
let swappedTag = incomingWebSocketData ^.. key "Right" . key "tag" . _String
guard $ swappedTag == ["Swapped"]
pure ()
observableStateFailureEvent :: Event t Aeson.Value
observableStateFailureEvent = flip fmapMaybe observableStateEvent $ \(incomingWebSocketData :: Aeson.Value)
-> incomingWebSocketData ^? key "Left"
observableStateSuccessEvent = fmapMaybe (preview _Right) observableStateEvent
-- this event will cause the success message to disappear when it occurs
vanishEvent <- delay 7 observableStateSuccessEvent
-- show success message based on new observable state
widgetHold_ blank $ ffor
(leftmost [True <$ observableStateSuccessEvent, False <$ vanishEvent]) $
\case
False -> blank
True -> elClass "p" "text-success" $ text "Success!"
widgetHold_ blank $ ffor observableStateFailureEvent $ \(errMsg :: Aeson.Value) ->
elClass "p" "text-danger" $ text $ case errMsg ^? _String of
Just t -> t
Nothing -> T.pack $ show errMsg
return $ leftmost [() <$ observableStateFailureEvent, observableStateSuccessEvent]
readyForRequest :: Event t () <- switchHold never readyForRequestEE
True -> blank
False -> elClass "p" "text-success" $ text "Success!"
widgetHold_ blank $ ffor (fmapMaybe (preview _Left) observableStateEvent) $ \errJson ->
elClass "p" "text-danger" $ text $ case errJson ^? _String of
Just errMsg -> errMsg
Nothing -> T.pack $ show errJson
let readyForRequest = () <$ responseVal
return $ ffor4 selectionA amountA selectionB amountB $ \selA amtA selB amtB -> Just ((selA, amtA), (selB, amtB))
_ -> do
elClass "p" "text-warning" $ text "There are no tokens available to swap."
Expand Down Expand Up @@ -226,7 +208,9 @@ transactionDetails pabDMMV formDyn = do
else (findSwapA coinAPoolAmount coinBPoolAmount amtA', coinBName)
_ -> Nothing
txFeeEstimateResp <- requesting $ fmap (\sca -> Api_EstimateTransactionFee sca) $ SmartContractAction_Swap <$ updated formDyn
widgetHold_ blank $ ffor (fmapMaybe id $ updated swapEstimate) $ \(estimate, eTokenName) ->
dyn_ $ ffor swapEstimate $ \case
Nothing -> blank
Just (estimate, eTokenName) ->
elClass "p" "text-info" $ text
$ "Estimated to receive "
<> (T.pack $ show estimate)
Expand Down Expand Up @@ -262,4 +246,3 @@ pollRefreshPoolBalance wid = do
-- recurring event used to poll for pool balance
pollingEvent <- tickLossyFromPostBuildTime 10
requesting_ $ (Api_CallPools (ContractInstanceId wid)) <$ (leftmost [pb, () <$ pollingEvent])

0 comments on commit b881507

Please sign in to comment.