diff --git a/use-case-2/common/common.cabal b/use-case-2/common/common.cabal index f3293a9de..fbe797f0c 100644 --- a/use-case-2/common/common.cabal +++ b/use-case-2/common/common.cabal @@ -14,10 +14,12 @@ library , mtl , obelisk-route , text + , th-abstraction , vessel exposed-modules: Common.Api Common.Route Common.Schema Common.Plutus.Contracts.Uniswap.Types + Common.Plutus.Contracts.Uniswap.Estimates ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O -fno-show-valid-hole-fits diff --git a/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs b/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs new file mode 100644 index 000000000..de7595d52 --- /dev/null +++ b/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs @@ -0,0 +1,67 @@ +{- Once GHC 8.10 is supported in Obelisk (currently only supports GHC 8.6) + - , we will be able to reference plutus and plutus-starter functions directly. + - For now, they will come from this module. This module is not necessary + - for creating smart contracts, view at your own discretion. + + - This modules is full of functions used to provide estimates for swaps, liquidity redemption, etc. +-} + +module Common.Plutus.Contracts.Uniswap.Estimates where + +import Common.Plutus.Contracts.Uniswap.Types + +traceIfFalse :: String -> Bool -> Bool +traceIfFalse _ a = if a then True else False + +checkSwap + :: Integer -- Amount A + -> Integer -- Amount B + -> Integer -- Amount A + -> Integer -- Amount B + -> Bool +checkSwap oldA oldB newA newB = + traceIfFalse "expected positive oldA" (oldA > 0) && + traceIfFalse "expected positive oldB" (oldB > 0) && + traceIfFalse "expected positive-newA" (newA > 0) && + traceIfFalse "expected positive-newB" (newB > 0) && + traceIfFalse "expected product to increase" + ((((newA * feeDen) - (inA * feeNum)) * ((newB * feeDen) - (inB * feeNum))) + >= (feeDen * feeDen * oldA * oldB)) + where + -- use max 0 just in case calculation result is less than 0 + inA = max 0 $ newA - oldA + inB = max 0 $ newB - oldB + -- The uniswap fee is 0.3%; here it is multiplied by 1000, so that the + -- on-chain code deals only in integers. + -- See: Eq (11) (Page 7.) + feeNum, feeDen :: Integer + feeNum = 3 + feeDen = 1000 + +findSwapA + :: Integer -- original total of first coin in liquidity + -> Integer -- original total of second coin in liquidity + -> Integer -- amount of first coin being swapped for second coin + -> Integer -- amount of second coin recieved +findSwapA oldA oldB inA + | ub' <= 1 = 0 + | otherwise = go 1 ub' + where + -- check if swap is valid and fee is computed correctly + cs :: Integer -> Bool + cs outB = checkSwap oldA oldB (oldA + inA) (oldB - outB) + + -- find the first integer where checkswap would be invalid + ub' :: Integer + ub' = head $ dropWhile cs [2 ^ i | i <- [0 :: Int ..]] + + -- determine amount to swap for + go :: Integer -> Integer -> Integer + go lb ub + | ub == (lb + 1) = lb + | otherwise = + let + m = div (ub + lb) 2 + in + if cs m then go m ub else go lb m + diff --git a/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Types.hs b/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Types.hs index dab0e353d..dda9cfae2 100644 --- a/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Types.hs +++ b/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Types.hs @@ -7,6 +7,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} module Common.Plutus.Contracts.Uniswap.Types where diff --git a/use-case-2/frontend/src/Frontend.hs b/use-case-2/frontend/src/Frontend.hs index f20add1e4..c6612944b 100644 --- a/use-case-2/frontend/src/Frontend.hs +++ b/use-case-2/frontend/src/Frontend.hs @@ -15,6 +15,7 @@ module Frontend where import Prelude hiding (id, (.), filter) import Control.Category +import Control.Applicative import Control.Lens import Control.Monad import Control.Monad.IO.Class (MonadIO) @@ -26,6 +27,7 @@ import qualified Data.HashMap.Lazy as HMap import Data.Semigroup (First(..)) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Read as T import qualified Data.Vector as V import Data.Vessel import Data.Vessel.Identity @@ -42,6 +44,7 @@ import Safe (headMay) import Common.Api import Common.Route import Common.Plutus.Contracts.Uniswap.Types +import Common.Plutus.Contracts.Uniswap.Estimates import Common.Schema @@ -157,6 +160,10 @@ swapDashboard :: forall t m js. (MonadRhyoliteWidget (DexV (Const SelectedCount) -> Workflow t m () swapDashboard wid = Workflow $ do navEvent <- navBar $ Just wid + pb <- getPostBuild + -- recurring event used to poll for pool balance + pollingEvent <- tickLossyFromPostBuildTime 10 + requesting_ $ (Api_CallPools (ContractInstanceId wid)) <$ (leftmost [pb, () <$ pollingEvent]) let portfolioEv = flip ffilter navEvent $ \navEv -> navEv == Dashboard_Portfolio poolEv = flip ffilter navEvent $ \navEv -> navEv == Dashboard_Pool _ <- divClass "p-5 mb-4 bg-light rounded-5" $ do @@ -231,6 +238,39 @@ swapDashboard wid = Workflow $ do let newObservableStateTag = incomingWebSocketData ^.. key "tag" . _String failureMessageTag = incomingWebSocketData ^.. key "contents" . key "Left" . _String newObservableStateTag == ["NewObservableState"] && failureMessageTag /= [""] + -- Pools is used to get information about liquidity pools and token pairs to provide swap estimations + poolsEvent = flip ffilter (_webSocket_recv ws) $ \(mIncomingWebSocketData :: Maybe Aeson.Value) -> case mIncomingWebSocketData of + Nothing -> False + Just incomingWebSocketData -> do + let observableStateTag = incomingWebSocketData ^.. key "tag" . _String + poolsTag = incomingWebSocketData ^.. key "contents" . key "Right" . key "tag" . _String + observableStateTag == ["NewObservableState"] && poolsTag == ["Pools"] + dynPoolMap <- holdDyn Map.empty $ ffor poolsEvent $ \mIncomingPoolsWebSocketData -> do + let poolDetails = case mIncomingPoolsWebSocketData of + Nothing -> V.empty + Just poolsWebSocketData -> poolsWebSocketData ^. key "contents" . key "Right" . key "contents" . _Array + parseLiquidityTokensToMap poolDetails + -- Determine what amount will be received after + let swapInput = ffor2 amountA amountB $ \a b -> (a,b) + ffor4 a b c d f = liftA3 f a b c <*> d + swapEstimate = ffor4 selectionA selectionB swapInput dynPoolMap $ \selA selB (amtA, amtB) poolMap -> do + let ((coinAName, coinAPoolAmount), (coinBName, coinBPoolAmount)) = fromMaybe (("", 0), ("", 0)) + $ fmap snd + $ headMay + $ Map.elems + $ Map.filter (\(_,((tknameA,_), (tknameB, _))) + -> tknameA == (_pooledToken_name selA) && tknameB == (_pooledToken_name selB)) poolMap + (amtA',_) :: (Integer, Text) <- T.decimal amtA + (amtB',_) :: (Integer, Text) <- T.decimal amtB + let (swapAmount, estimatedTkName) = if amtA' == 0 then (amtB',coinAName) else (amtA',coinBName) + return $ (findSwapA coinAPoolAmount coinBPoolAmount swapAmount, estimatedTkName) + -- display estimated funds to be received during swap and the token name to be received + divClass "p-3 mt-2" $ widgetHold_ blank $ ffor (updated swapEstimate) $ \case + Left err -> elClass "p" "text-danger" $ text $ T.pack $ show err + Right (estimate, eTokenName) -> elClass "p" "text-info" $ text + $ "In this transaction you will receive " + <> (T.pack $ show estimate) + <> " " <> (T.pack $ show $ if "" == eTokenName then "ADA" else eTokenName) -- this event will cause the success message to disappear when it occurs vanishEvent <- delay 7 observableStateSuccessEvent -- show success message based on new observable state @@ -349,7 +389,7 @@ poolDashboard wid = Workflow $ do let mLiquidityInfo = Map.lookup tokenName poolMap case mLiquidityInfo of Nothing -> blank - Just (lqTotal, (tokenNameA,tokenNameB)) -> do + Just (lqTotal, ((tokenNameA, _),(tokenNameB,_))) -> do let lqPercentage :: Double = ((fromIntegral tokenBalance) / (fromIntegral lqTotal)) * 100 el "p" $ text $ "Token Name: " <> (T.pack $ show tokenName) @@ -560,15 +600,18 @@ parseTokensToMap cd = mconcat $ catMaybes $ V.toList $ ffor cd $ \case _ -> Nothing _ -> Just Map.empty -parseLiquidityTokensToMap :: V.Vector Aeson.Value -> Map.Map Text (Integer, (Text, Text)) -- (LiquidityAmount, (CoinA, CoinB)) +-- returns Map of TokenName (LiquidityAmount, ((CoinA, CoinAPoolAmount), (CoinB, CoinBPoolAmount))) +parseLiquidityTokensToMap :: V.Vector Aeson.Value -> Map.Map Text (Integer, ((Text,Integer), (Text, Integer))) parseLiquidityTokensToMap cd = mconcat $ catMaybes $ V.toList $ ffor cd $ \case Aeson.Array xs -> case V.toList xs of coinA:coinB:(Aeson.Array liquidityCoin):_-> case V.toList liquidityCoin of (Aeson.Object obj):(Aeson.Number lqAmount):_ -> case HMap.toList obj of (_, Aeson.String lqTokenName):_ -> do let tna = coinA ^. nth 0 . key "unAssetClass" . values . key "unTokenName" . _String + tnaPool = fromMaybe 0 $ coinA ^? nth 1 . _Integer tnb = coinB ^. nth 0 . key "unAssetClass" . values . key "unTokenName" . _String - Just $ Map.singleton lqTokenName ((fromMaybe 0 $ lqAmount ^? _Integer), (tna,tnb)) + tnbPool = fromMaybe 0 $ coinB ^? nth 1 . _Integer + Just $ Map.singleton lqTokenName ((fromMaybe 0 $ lqAmount ^? _Integer), ((tna, tnaPool),(tnb, tnbPool))) _ -> Nothing _ -> Nothing _ -> Nothing