From 608ad20d6b9a615ef75b8883c3bbe61679ccf8df Mon Sep 17 00:00:00 2001 From: paolino Date: Thu, 7 Nov 2024 12:12:11 +0000 Subject: [PATCH] --- lib/ui/cardano-wallet-ui.cabal | 6 +- .../Wallet/UI/Common/Html/Pages/Lib.hs | 8 +- lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs | 20 ++- .../Cardano/Wallet/UI/Deposit/API/Payments.hs | 34 ++++ .../UI/Deposit/Handlers/Deposits/Mock.hs | 2 +- .../Wallet/UI/Deposit/Html/Pages/Page.hs | 10 ++ .../UI/Deposit/Html/Pages/Payments/Page.hs | 147 ++++++++++++++++++ .../src/Cardano/Wallet/UI/Deposit/Server.hs | 7 + .../Wallet/UI/Deposit/Server/Payments/Page.hs | 68 ++++++++ .../Wallet/UI/Deposit/Types/Payments.hs | 62 ++++++++ 10 files changed, 357 insertions(+), 7 deletions(-) create mode 100644 lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs create mode 100644 lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/Page.hs create mode 100644 lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Payments/Page.hs create mode 100644 lib/ui/src/Cardano/Wallet/UI/Deposit/Types/Payments.hs diff --git a/lib/ui/cardano-wallet-ui.cabal b/lib/ui/cardano-wallet-ui.cabal index 802921c2199..40ab03595fa 100644 --- a/lib/ui/cardano-wallet-ui.cabal +++ b/lib/ui/cardano-wallet-ui.cabal @@ -63,6 +63,7 @@ library Cardano.Wallet.UI.Deposit.API.Addresses.Transactions Cardano.Wallet.UI.Deposit.API.Common Cardano.Wallet.UI.Deposit.API.Deposits.Deposits + Cardano.Wallet.UI.Deposit.API.Payments Cardano.Wallet.UI.Deposit.Handlers.Addresses Cardano.Wallet.UI.Deposit.Handlers.Addresses.Transactions Cardano.Wallet.UI.Deposit.Handlers.Deposits.Customers @@ -80,6 +81,7 @@ library Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Times Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.TxIds Cardano.Wallet.UI.Deposit.Html.Pages.Page + Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page Cardano.Wallet.UI.Deposit.Html.Pages.Wallet Cardano.Wallet.UI.Deposit.Server Cardano.Wallet.UI.Deposit.Server.Addresses @@ -88,12 +90,14 @@ library Cardano.Wallet.UI.Deposit.Server.Deposits.Times Cardano.Wallet.UI.Deposit.Server.Deposits.TxIds Cardano.Wallet.UI.Deposit.Server.Lib + Cardano.Wallet.UI.Deposit.Server.Payments.Page Cardano.Wallet.UI.Deposit.Server.Wallet + Cardano.Wallet.UI.Deposit.Types.Payments Cardano.Wallet.UI.Lib.Address Cardano.Wallet.UI.Lib.Discretization Cardano.Wallet.UI.Lib.ListOf - Cardano.Wallet.UI.Lib.Pagination.TimedSeq Cardano.Wallet.UI.Lib.Pagination.Map + Cardano.Wallet.UI.Lib.Pagination.TimedSeq Cardano.Wallet.UI.Lib.Pagination.Type Cardano.Wallet.UI.Lib.Time.Direction Cardano.Wallet.UI.Shelley.API diff --git a/lib/ui/src/Cardano/Wallet/UI/Common/Html/Pages/Lib.hs b/lib/ui/src/Cardano/Wallet/UI/Common/Html/Pages/Lib.hs index bcd7cc29848..0bb964411e3 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Common/Html/Pages/Lib.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Common/Html/Pages/Lib.hs @@ -33,6 +33,9 @@ where import Prelude +import Cardano.Wallet.Deposit.Pure.API.Address + ( encodeAddress + ) import Cardano.Wallet.Deposit.Read ( Address ) @@ -48,9 +51,6 @@ import Cardano.Wallet.UI.Common.Html.Lib , linkText , truncatableText ) -import Cardano.Wallet.UI.Lib.Address - ( encodeAddress - ) import Cardano.Wallet.UI.Lib.ListOf ( Cons (..) , ListOf @@ -274,7 +274,7 @@ showThousandDots = reverse . showThousandDots' . reverse . show a <> if null b then [] else "." <> showThousandDots' b addressH :: Monad m => WithCopy -> Address -> HtmlT m () -addressH copy addr = +addressH copy addr = do truncatableText copy ("address-text-" <> encodedAddr) $ toHtml encodedAddr where diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs index 6d869734886..b0aae5f61a1 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs @@ -67,6 +67,9 @@ import Web.FormUrlEncoded ( FromForm (..) ) +import Cardano.Wallet.UI.Deposit.API.Payments + ( NewPaymentParams + ) import qualified Data.ByteString.Lazy as BL instance FromForm PostWalletViaMenmonic @@ -80,6 +83,7 @@ data Page | Wallet | Addresses | Deposits + | Payments makePrisms ''Page @@ -90,6 +94,7 @@ instance ToHttpApiData Page where toUrlPiece Wallet = "wallet" toUrlPiece Addresses = "addresses" toUrlPiece Deposits = "deposits" + toUrlPiece Payments = "payments" instance FromHttpApiData Page where parseUrlPiece "about" = Right About @@ -98,6 +103,7 @@ instance FromHttpApiData Page where parseUrlPiece "wallet" = Right Wallet parseUrlPiece "addresses" = Right Addresses parseUrlPiece "deposits" = Right Deposits + parseUrlPiece "payments" = Right Payments parseUrlPiece _ = Left "Invalid page" -- | Pages endpoints @@ -108,6 +114,7 @@ type Pages = :<|> "wallet" :> SessionedHtml Get :<|> "addresses" :> SessionedHtml Get :<|> "deposits" :> SessionedHtml Get + :<|> "payments" :> SessionedHtml Get -- | Data endpoints type Data = @@ -190,6 +197,9 @@ type Data = :> QueryParam "customer" Customer :> QueryParam "tx-id" TxId :> SessionedHtml Post + :<|> "payments" :> SessionedHtml Get + :<|> "payments" :> "receiver" :> ReqBody '[FormUrlEncoded] NewPaymentParams + :> SessionedHtml Post type Home = SessionedHtml Get @@ -208,6 +218,8 @@ settingsPageLink :: Link walletPageLink :: Link addressesPageLink :: Link depositPageLink :: Link +paymentsPageLink :: Link + networkInfoLink :: Link settingsGetLink :: Link settingsSseToggleLink :: Link @@ -236,6 +248,8 @@ depositsTxIdsLink :: Maybe (WithOrigin UTCTime) -> Maybe Customer -> Maybe Expand -> Link depositsTxIdsPaginatingLink :: Maybe (WithOrigin UTCTime) -> Maybe Customer -> Maybe TxId -> Link +paymentsLink :: Link +paymentsNewReceiverLink :: Link homePageLink :<|> aboutPageLink :<|> networkPageLink @@ -243,6 +257,7 @@ homePageLink :<|> walletPageLink :<|> addressesPageLink :<|> depositPageLink + :<|> paymentsPageLink :<|> networkInfoLink :<|> settingsGetLink :<|> settingsSseToggleLink @@ -265,5 +280,8 @@ homePageLink :<|> depositsCustomersLink :<|> depositsCustomersPaginatingLink :<|> depositsTxIdsLink - :<|> depositsTxIdsPaginatingLink = + :<|> depositsTxIdsPaginatingLink + :<|> paymentsLink + :<|> paymentsNewReceiverLink + = allLinks (Proxy @UI) diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs new file mode 100644 index 00000000000..7cbfe09f3b3 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Wallet.UI.Deposit.API.Payments + ( NewPaymentParams (..) + ) +where + +import Prelude + +import Cardano.Wallet.UI.Deposit.Types.Payments + ( Receiver (..) + ) +import Web.FormUrlEncoded + ( FromForm (..) + , parseAll + , parseUnique + ) + +data NewPaymentParams = NewPaymentParams + { receivers :: [Receiver] + , newReceiver :: Receiver + } + deriving (Eq, Show) + +instance FromForm NewPaymentParams where + fromForm form = do + receivers <- parseAll "receiver-defined" form + address <- parseUnique "new-receiver-address" form + amount <- parseUnique "new-receiver-amount" form + let newReceiver = Receiver{address = address, amount = amount} + pure $ NewPaymentParams{receivers, newReceiver} diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Mock.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Mock.hs index 0e89cc1f056..c035d95336a 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Mock.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Deposits/Mock.hs @@ -48,7 +48,7 @@ import System.IO.Unsafe ) nMockDeposits :: Int -nMockDeposits = 100000 +nMockDeposits = 10000 type TxHistoryCache = TVar (Maybe (UTCTime, [Address], TxHistory)) diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Page.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Page.hs index e9d326d06d2..e37e1607015 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Page.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Page.hs @@ -45,6 +45,7 @@ import Cardano.Wallet.UI.Deposit.API , _Addresses , _Deposits , _Network + , _Payments , _Settings , _Wallet , aboutPageLink @@ -55,6 +56,8 @@ import Cardano.Wallet.UI.Deposit.API , navigationLink , networkInfoLink , networkPageLink + , paymentsLink + , paymentsPageLink , settingsGetLink , settingsPageLink , sseLink @@ -69,6 +72,9 @@ import Cardano.Wallet.UI.Deposit.Html.Pages.Addresses import Cardano.Wallet.UI.Deposit.Html.Pages.Deposits.Page ( depositsH ) +import Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page + ( paymentsH + ) import Cardano.Wallet.UI.Deposit.Html.Pages.Wallet ( WalletPresent , isPresent @@ -111,6 +117,7 @@ page c p = RawHtml Wallet -> walletH Addresses -> addressesH Deposits -> depositsH depositsLink + Payments -> paymentsH paymentsLink headerH :: Monad m => Page -> HtmlT m () headerH p = sseH (navigationLink $ Just p) "header" ["wallet"] @@ -126,6 +133,9 @@ headerElementH p wp = <> [ (is' _Deposits, depositPageLink, "Deposits") | isPresent wp ] + <> [ (is' _Payments, paymentsPageLink, "Payments") + | isPresent wp + ] <> [ (is' _Network, networkPageLink, "Network") , (is' _Settings, settingsPageLink, "Settings") , (is' _About, aboutPageLink, "About") diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/Page.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/Page.hs new file mode 100644 index 00000000000..3f1c68125a9 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/Page.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page + ( paymentsH + , paymentsElementH + , receiversH + ) +where + +import Prelude + +import Cardano.Wallet.Deposit.IO + ( WalletPublicIdentity (..) + ) +import Cardano.Wallet.UI.Common.Html.Htmx + ( hxInclude_ + , hxPost_ + , hxTarget_ + ) +import Cardano.Wallet.UI.Common.Html.Lib + ( AlertH + , WithCopy (..) + , linkText + , tdEnd + , thEnd + ) +import Cardano.Wallet.UI.Common.Html.Pages.Lib + ( addressH + , box + , showAdaOfLoveLace + , sseH + ) +import Cardano.Wallet.UI.Deposit.API + ( paymentsNewReceiverLink + ) +import Cardano.Wallet.UI.Deposit.Html.Pages.Wallet + ( WalletPresent (..) + , onWalletPresentH + ) +import Cardano.Wallet.UI.Deposit.Types.Payments + ( Receiver (..) + ) +import Cardano.Wallet.UI.Type + ( WHtml + ) +import Control.Monad + ( forM_ + ) +import Lucid + ( Html + , ToHtml (toHtml) + , button_ + , class_ + , div_ + , hidden_ + , id_ + , input_ + , name_ + , placeholder_ + , table_ + , tbody_ + , thead_ + , tr_ + , type_ + , value_ + ) +import Servant + ( Link + , ToHttpApiData (toUrlPiece) + ) + +paymentsH :: Link -> WHtml () +paymentsH paymentsLink = do + sseH paymentsLink "payments-page" ["wallet"] + +newReceiverH :: Html () +newReceiverH = do + div_ + [id_ "new-receiver-form"] + $ do + input_ + [ class_ "form-control" + , type_ "text" + , name_ "new-receiver-address" + , placeholder_ "Address" + ] + input_ + [ class_ "form-control" + , type_ "text" + , name_ "new-receiver-amount" + , placeholder_ "Amount" + ] + button_ + [ class_ "btn btn-primary" + , type_ "submit" + , hxPost_ $ linkText paymentsNewReceiverLink + , hxTarget_ "#receivers" + , hxInclude_ "#receivers-state , #new-receiver-form" + ] + "Add" + +settledReceiversH :: [Receiver] -> Html () +settledReceiversH rs = do + table_ [class_ "table table-striped"] $ do + thead_ $ do + tr_ $ do + thEnd Nothing "Address" + thEnd (Just 7) "Amount" + tbody_ [id_ "receivers-state"] + $ forM_ rs + $ \r@Receiver{address, amount} -> do + tr_ $ do + tdEnd $ do + addressH WithCopy address + input_ + [ hidden_ "" + , value_ $ toUrlPiece r + , name_ "receiver-defined" + ] + + tdEnd $ toHtml $ showAdaOfLoveLace amount + +receiversH + :: [Receiver] -> Html () +receiversH rs = do + settledReceiversH rs + newReceiverH + +paymentsElementH + :: AlertH + -> WalletPresent + -> Html () +paymentsElementH = onWalletPresentH $ \case + WalletPublicIdentity _xpub _customers -> + div_ + [ class_ "row mt-3 gx-0" + ] + $ do + box "New Payment" mempty + $ div_ [class_ "ms-3"] + $ do + box "Receivers" mempty + $ div_ [class_ "ms-3", id_ "receivers"] + $ receiversH [] + box "Transaction" mempty mempty + box "Payments History" mempty "To be done" diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs index b864911fa93..219a50d6c20 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs @@ -107,6 +107,10 @@ import Cardano.Wallet.UI.Deposit.Server.Deposits.TxIds import Cardano.Wallet.UI.Deposit.Server.Lib ( renderSmoothHtml ) +import Cardano.Wallet.UI.Deposit.Server.Payments.Page + ( servePaymentsNewReceiver + , servePaymentsPage + ) import Cardano.Wallet.UI.Deposit.Server.Wallet ( serveDeleteWallet , serveDeleteWalletModal @@ -159,6 +163,7 @@ serveUI tr ul env dbDir config nid nl bs = :<|> serveTabPage ul config Wallet :<|> serveTabPage ul config Addresses :<|> serveTabPage ul config Deposits + :<|> serveTabPage ul config Payments :<|> serveNetworkInformation nid nl bs :<|> serveSSESettings ul :<|> serveToggleSSE ul @@ -182,6 +187,8 @@ serveUI tr ul env dbDir config nid nl bs = :<|> serveDepositsCustomerPagination ul :<|> serveDepositsCustomersTxIds ul :<|> serveDepositsCustomersTxIdsPagination ul + :<|> servePaymentsPage ul + :<|> servePaymentsNewReceiver ul serveTabPage :: UILayer s diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Payments/Page.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Payments/Page.hs new file mode 100644 index 00000000000..0fe0acd656b --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Payments/Page.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Cardano.Wallet.UI.Deposit.Server.Payments.Page + ( servePaymentsPage + , servePaymentsNewReceiver + ) +where + +import Prelude + +import Cardano.Wallet.Deposit.REST + ( WalletResource + ) +import Cardano.Wallet.UI.Common.Handlers.Session + ( withSessionLayer + ) +import Cardano.Wallet.UI.Common.Html.Html + ( RawHtml (..) + ) +import Cardano.Wallet.UI.Common.Html.Pages.Lib + ( alertH + ) +import Cardano.Wallet.UI.Common.Layer + ( UILayer (..) + ) +import Cardano.Wallet.UI.Cookies + ( CookieResponse + , RequestCookies + ) +import Cardano.Wallet.UI.Deposit.API.Payments + ( NewPaymentParams (..) + ) +import Cardano.Wallet.UI.Deposit.Handlers.Lib + ( walletPresence + ) +import Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page + ( paymentsElementH + , receiversH + ) +import Cardano.Wallet.UI.Deposit.Server.Lib + ( renderSmoothHtml + ) +import Servant + ( Handler + ) + +servePaymentsPage + :: UILayer WalletResource + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsPage ul = withSessionLayer ul $ \layer -> do + wp <- walletPresence layer + pure + $ renderSmoothHtml + $ paymentsElementH alertH wp + +servePaymentsNewReceiver + :: UILayer WalletResource + -> NewPaymentParams + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsNewReceiver ul NewPaymentParams{receivers, newReceiver} = + withSessionLayer ul $ \layer -> do + _wp <- walletPresence layer + pure + $ renderSmoothHtml + $ receiversH + $ newReceiver : receivers diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Types/Payments.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Types/Payments.hs new file mode 100644 index 00000000000..7d22d2a4527 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Types/Payments.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Wallet.UI.Deposit.Types.Payments + ( Receiver (..) + ) +where + +import Prelude + +import Cardano.Wallet.Deposit.Pure.API.Address + ( decodeAddress + , encodeAddress + ) +import Cardano.Wallet.Deposit.Read + ( Address + ) +import Numeric.Natural + ( Natural + ) +import Web.HttpApiData + ( FromHttpApiData (parseUrlPiece) + , ToHttpApiData (toUrlPiece) + ) + +import qualified Data.Text as T + +-- | A receiver of a payment. +data Receiver = Receiver + { address :: Address + -- ^ The address of the receiver. + , amount :: Natural + -- ^ The amount of lovelace to send to the receiver. + } + deriving (Eq, Show) + +instance FromHttpApiData Receiver where + parseUrlPiece t = case T.splitOn "," t of + [addressText, amountText] -> do + amount :: Natural <- case reads (T.unpack amountText) of + [(n, "")] -> pure n + _ -> Left "Amount must be a number" + address <- parseUrlPiece addressText + pure $ Receiver{address, amount} + _ -> Left "Receiver must be in the format 'address,amount'" + +instance ToHttpApiData Receiver where + toUrlPiece Receiver{address, amount} = + T.intercalate "," + [ encodeAddress address + , T.pack $ show amount + ] + +instance FromHttpApiData Address where + parseUrlPiece t = case decodeAddress t of + Left err -> Left $ T.pack $ show err + Right address -> pure address