From 09a760ed31019af3275969c8e24620ae48a8327c Mon Sep 17 00:00:00 2001 From: paolino Date: Thu, 21 Nov 2024 22:32:19 +0000 Subject: [PATCH] Add payments page to deposit wallet UI --- lib/ui/cardano-wallet-ui.cabal | 17 + lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs | 83 ++- .../Cardano/Wallet/UI/Deposit/API/Payments.hs | 233 ++++++++ .../UI/Deposit/Handlers/Payments/Balance.hs | 36 ++ .../Deposit/Handlers/Payments/Transaction.hs | 479 +++++++++++++++ .../Wallet/UI/Deposit/Html/Pages/Page.hs | 10 + .../UI/Deposit/Html/Pages/Payments/Page.hs | 554 ++++++++++++++++++ .../src/Cardano/Wallet/UI/Deposit/Server.hs | 39 +- .../Wallet/UI/Deposit/Server/Payments/Page.hs | 194 ++++++ .../Wallet/UI/Deposit/Types/Payments.hs | 62 ++ .../Deposit/Html/Pages/Payments/PageSpec.hs | 136 +++++ 11 files changed, 1840 insertions(+), 3 deletions(-) create mode 100644 lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs create mode 100644 lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Balance.hs create mode 100644 lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.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 create mode 100644 lib/ui/test/unit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/PageSpec.hs diff --git a/lib/ui/cardano-wallet-ui.cabal b/lib/ui/cardano-wallet-ui.cabal index c8fd602ed3b..3b13a9e9c67 100644 --- a/lib/ui/cardano-wallet-ui.cabal +++ b/lib/ui/cardano-wallet-ui.cabal @@ -63,12 +63,15 @@ 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 Cardano.Wallet.UI.Deposit.Handlers.Deposits.Times Cardano.Wallet.UI.Deposit.Handlers.Deposits.TxIds Cardano.Wallet.UI.Deposit.Handlers.Lib + Cardano.Wallet.UI.Deposit.Handlers.Payments.Balance + Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction Cardano.Wallet.UI.Deposit.Handlers.Wallet Cardano.Wallet.UI.Deposit.Html.Common Cardano.Wallet.UI.Deposit.Html.Pages.About @@ -79,6 +82,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 @@ -87,7 +91,9 @@ 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.Discretization Cardano.Wallet.UI.Lib.ListOf Cardano.Wallet.UI.Lib.Pagination.Map @@ -117,6 +123,7 @@ library , base16-bytestring , bytestring , cardano-addresses + , cardano-binary , cardano-slotting , cardano-wallet , cardano-wallet-api @@ -167,17 +174,27 @@ test-suite unit build-depends: , base + , base16-bytestring + , bytestring + , cardano-crypto + , cardano-wallet-read , cardano-wallet-ui + , contra-tracer , containers , hspec , mtl , QuickCheck + , text + , temporary , time + , customer-deposit-wallet:rest + , customer-deposit-wallet:customer-deposit-wallet build-tool-depends: hspec-discover:hspec-discover type: exitcode-stdio-1.0 hs-source-dirs: test/unit main-is: unit-test.hs other-modules: + Cardano.Wallet.UI.Deposit.Html.Pages.Payments.PageSpec Cardano.Wallet.UI.Lib.DiscretizationSpec Cardano.Wallet.UI.Lib.Pagination.MapSpec diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs index aa85d150176..3f81be5e3b8 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/API.hs @@ -12,7 +12,8 @@ import Cardano.Wallet.Deposit.Pure ( Customer ) import Cardano.Wallet.Deposit.Read - ( TxId + ( Address + , TxId ) import Cardano.Wallet.Deposit.REST.Wallet.Create ( PostWalletViaMnemonic @@ -42,9 +43,17 @@ import Cardano.Wallet.UI.Deposit.API.Common import Cardano.Wallet.UI.Deposit.API.Deposits.Deposits ( DepositsParams ) +import Cardano.Wallet.UI.Deposit.API.Payments + ( AddReceiverForm + , NewReceiverValidation + , SignatureForm + ) import Control.Lens ( makePrisms ) +import Data.Text + ( Text + ) import Data.Time ( UTCTime ) @@ -67,6 +76,7 @@ import Web.FormUrlEncoded ( FromForm (..) ) +import qualified Cardano.Wallet.UI.Deposit.API.Payments as Payment import qualified Data.ByteString.Lazy as BL instance FromForm PostWalletViaMnemonic @@ -80,6 +90,7 @@ data Page | Wallet | Addresses | Deposits + | Payments makePrisms ''Page @@ -90,6 +101,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 +110,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 +121,7 @@ type Pages = :<|> "wallet" :> SessionedHtml Get :<|> "addresses" :> SessionedHtml Get :<|> "deposits" :> SessionedHtml Get + :<|> "payments" :> SessionedHtml Get -- | Data endpoints type Data = @@ -187,6 +201,49 @@ type Data = :> QueryParam "customer" Customer :> QueryParam "tx-id" TxId :> SessionedHtml Post + :<|> "payments" :> SessionedHtml Get + :<|> "payments" + :> "receiver" + :> ReqBody '[FormUrlEncoded] AddReceiverForm + :> SessionedHtml Post + :<|> "payments" + :> "receiver" + :> "delete" + :> ReqBody '[FormUrlEncoded] Payment.State + :> QueryParam "receiver-number" Address + :> SessionedHtml Post + :<|> "payments" + :> "balance" + :> "available" + :> SessionedHtml Get + :<|> "payments" + :> "receiver" + :> "address" + :> "validation" + :> ReqBody '[FormUrlEncoded] NewReceiverValidation + :> SessionedHtml Post + :<|> "payments" + :> "receiver" + :> "amount" + :> "validation" + :> ReqBody '[FormUrlEncoded] NewReceiverValidation + :> SessionedHtml Post + :<|> "modal" + :> "info" + :> QueryParam "title" Text + :> QueryParam "text" Text + :> SessionedHtml Get + :<|> "payments" + :> "sign" + :> ReqBody '[FormUrlEncoded] SignatureForm + :> SessionedHtml Post + :<|> "payments" + :> "submit" + :> ReqBody '[FormUrlEncoded] Payment.State + :> SessionedHtml Post + :<|> "payments" + :> "reset" + :> SessionedHtml Post type Home = SessionedHtml Get @@ -205,6 +262,7 @@ settingsPageLink :: Link walletPageLink :: Link addressesPageLink :: Link depositPageLink :: Link +paymentsPageLink :: Link networkInfoLink :: Link settingsGetLink :: Link settingsSseToggleLink :: Link @@ -232,6 +290,16 @@ depositsTxIdsLink :: Maybe (WithOrigin UTCTime) -> Maybe Customer -> Maybe Expand -> Link depositsTxIdsPaginatingLink :: Maybe (WithOrigin UTCTime) -> Maybe Customer -> Maybe TxId -> Link +paymentsLink :: Link +paymentsNewReceiverLink :: Link +paymentsDeleteReceiverLink :: Maybe Address -> Link +paymentsBalanceAvailableLink :: Link +paymentsReceiverAddressValidationLink :: Link +paymentsReceiverAmountValidationLink :: Link +modalLink :: Maybe Text -> Maybe Text -> Link +paymentsSignLink :: Link +paymentsSubmitLink :: Link +paymentsResetLink :: Link homePageLink :<|> aboutPageLink :<|> networkPageLink @@ -239,6 +307,7 @@ homePageLink :<|> walletPageLink :<|> addressesPageLink :<|> depositPageLink + :<|> paymentsPageLink :<|> networkInfoLink :<|> settingsGetLink :<|> settingsSseToggleLink @@ -260,5 +329,15 @@ homePageLink :<|> depositsCustomersLink :<|> depositsCustomersPaginatingLink :<|> depositsTxIdsLink - :<|> depositsTxIdsPaginatingLink = + :<|> depositsTxIdsPaginatingLink + :<|> paymentsLink + :<|> paymentsNewReceiverLink + :<|> paymentsDeleteReceiverLink + :<|> paymentsBalanceAvailableLink + :<|> paymentsReceiverAddressValidationLink + :<|> paymentsReceiverAmountValidationLink + :<|> modalLink + :<|> paymentsSignLink + :<|> paymentsSubmitLink + :<|> paymentsResetLink = 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..896a65e1b62 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/API/Payments.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Wallet.UI.Deposit.API.Payments +where + +import Prelude + +import Cardano.Wallet.Deposit.Pure.API.Address + ( encodeAddress + ) +import Cardano.Wallet.Deposit.Write + ( Address + ) +import Cardano.Wallet.UI.Deposit.Types.Payments + ( Receiver (..) + ) +import Data.Aeson + ( FromJSON (parseJSON) + , KeyValue ((.=)) + , ToJSON (toJSON) + , object + , withObject + , (.:) + ) +import Data.Map.Monoidal.Strict + ( MonoidalMap + ) +import Data.Semigroup + ( Sum (..) + ) +import Data.Text + ( Text + ) +import GHC.Generics + ( Generic + ) +import Numeric.Natural + ( Natural + ) +import Servant + ( FromHttpApiData (..) + , ToHttpApiData + ) +import Servant.API + ( ToHttpApiData (..) + ) +import Web.FormUrlEncoded + ( FromForm (..) + , parseMaybe + , parseUnique + ) + +import qualified Data.Aeson as Aeson +import qualified Data.Map.Monoidal.Strict as MonoidalMap +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as TL + +newtype NewReceiver = NewReceiver Receiver + +data AddReceiverForm + = AddReceiverForm + { newReceiver :: NewReceiver + , addReceiverState :: State + } + +instance FromForm AddReceiverForm where + fromForm form = do + newReceiver <- fromForm form + addReceiverState <- fromForm form + pure AddReceiverForm{newReceiver, addReceiverState} + +instance FromForm NewReceiver where + fromForm form = do + address <- parseUnique "new-receiver-address" form + amountDouble :: Double <- parseUnique "new-receiver-amount" form + let amount = round $ amountDouble * 1_000_000 + pure + $ NewReceiver + $ Receiver{address, amount} + +data NewReceiverValidation + = NewReceiverValidation + { addressValidation :: Maybe Text + , amountValidation :: Maybe Text + } + +instance FromForm NewReceiverValidation where + fromForm form = do + addressValidation <- parseMaybe "new-receiver-address" form + amountValidation <- parseMaybe "new-receiver-amount" form + pure $ NewReceiverValidation{addressValidation, amountValidation} + +data Transaction + = Transaction + { dataType :: Text + , description :: Text + , cborHex :: Text + } + deriving (Eq, Show) + +instance ToJSON Transaction where + toJSON Transaction{dataType, description, cborHex} = + object + [ "type" .= dataType + , "description" .= description + , "cborHex" .= cborHex + ] + +instance FromJSON Transaction where + parseJSON = withObject "Transaction" $ \o -> do + dataType <- o .: "type" + description <- o .: "description" + cborHex <- o .: "cborHex" + pure Transaction{dataType, description, cborHex} + +newtype Password = Password Text + +data SignatureForm + = SignatureForm + { signatureFormState :: State + , signaturePassword :: Password + } + +instance FromForm SignatureForm where + fromForm form = do + signatureFormState <- fromForm form + signaturePassword <- Password <$> parseUnique "passphrase" form + pure SignatureForm{signatureFormState, signaturePassword} + +data StateA t + = NoState + | Unsigned t + | Signed Transaction t + | Submitted Transaction t + deriving (Eq, Show, Generic, Functor, Foldable, Traversable) + +type State = StateA Transaction + +instance ToJSON State +instance FromJSON State + +instance FromHttpApiData State where + parseQueryParam :: Text -> Either Text State + parseQueryParam t = case Aeson.decode $ TL.encodeUtf8 $ T.fromStrict t of + Nothing -> Left "Invalid JSON for a State" + Just tx -> pure tx + +instance FromForm State where + fromForm form = do + r <- parseMaybe "payment-state" form + case r of + Nothing -> pure NoState + Just tx -> pure tx + +data Signal + = AddReceiver Receiver + | DeleteReceiver Address + | Sign Password + | Unsign + | Submit + | Reset + +type Receivers = MonoidalMap Address (Sum Natural) + +data Payment m = Payment + { unsigned :: Receivers -> m Transaction + , sign :: Transaction -> Password -> m Transaction + , submit :: Transaction -> m () + , receivers :: Transaction -> m Receivers + } + +onReceivers + :: Monad m + => Payment m + -> Transaction + -> (Receivers -> Receivers) + -> m Receivers +onReceivers Payment{receivers} tx f = do + rs <- receivers tx + pure $ f rs + +deleteReceiver + :: Monad m => Payment m -> Transaction -> Address -> m State +deleteReceiver c tx a = do + rs' <- onReceivers c tx $ \r -> + MonoidalMap.filter (> 0) + $ MonoidalMap.delete a r + if null rs' + then pure NoState + else Unsigned <$> unsigned c rs' + +addReceiver + :: Monad m => Payment m -> Transaction -> Receiver -> m State +addReceiver c tx r = do + rs' <- onReceivers c tx $ \rs -> rs <> singleReceivers r + Unsigned <$> unsigned c rs' + +singleReceivers :: Receiver -> Receivers +singleReceivers Receiver{address, amount} = + MonoidalMap.singleton address (Sum amount) + +step :: Monad m => Payment m -> State -> Signal -> m (Maybe State) +step _ _ Reset = pure $ Just NoState +step c NoState (AddReceiver receiver) = do + tx <- unsigned c (singleReceivers receiver) + pure $ Just $ Unsigned tx +step c (Unsigned utx) (AddReceiver receiver) = do + Just <$> addReceiver c utx receiver +step c (Unsigned utx) (DeleteReceiver addr) = do + Just <$> deleteReceiver c utx addr +step c (Unsigned utx) (Sign pwd) = do + stx <- sign c utx pwd + pure $ Just $ Signed utx stx +step c (Signed utx _) (AddReceiver receiver) = do + Just <$> addReceiver c utx receiver +step c (Signed utx _) (DeleteReceiver addr) = do + Just <$> deleteReceiver c utx addr +step c (Signed utx stx) Submit = do + submit c stx + pure $ Just $ Submitted utx stx +step _ _ _ = pure Nothing + +instance ToHttpApiData Address where + toUrlPiece = encodeAddress diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Balance.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Balance.hs new file mode 100644 index 00000000000..0dfc06d9b8b --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Balance.hs @@ -0,0 +1,36 @@ +module Cardano.Wallet.UI.Deposit.Handlers.Payments.Balance + ( getAvailableBalance + ) +where + +import Prelude + +import Cardano.Wallet.Deposit.REST + ( WalletResource + , availableBalance + ) +import Cardano.Wallet.Read + ( Coin (..) + , Value (..) + ) +import Cardano.Wallet.UI.Common.Layer + ( SessionLayer + ) +import Cardano.Wallet.UI.Deposit.Handlers.Lib + ( catchRunWalletResourceHtml + ) +import Servant + ( Handler + ) + +import qualified Data.ByteString.Lazy.Char8 as BL8 + +getAvailableBalance + :: SessionLayer WalletResource + -> (Coin -> html) + -> (BL8.ByteString -> html) + -> Handler html +getAvailableBalance layer render alert = + catchRunWalletResourceHtml layer alert id $ do + ValueC r _ <- availableBalance + pure $ render r diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs new file mode 100644 index 00000000000..102a4c93e27 --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Payments/Transaction.hs @@ -0,0 +1,479 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction +where + +import Prelude + +import Cardano.Binary + ( DecoderError + ) +import Cardano.Read.Ledger.Tx.CBOR + ( deserializeTx + , serializeTx + ) +import Cardano.Wallet.Deposit.IO.Network.Type + ( ErrPostTx + ) +import Cardano.Wallet.Deposit.Pure + ( CanSign + , ErrCreatePayment + , InspectTx (..) + ) +import Cardano.Wallet.Deposit.Pure.API.Address + ( NetworkTag (..) + , getNetworkTag + ) +import Cardano.Wallet.Deposit.Read + ( Address + ) +import Cardano.Wallet.Deposit.REST + ( WalletResource + , WalletResourceM + , availableBalance + , canSign + , createPayment + , inspectTx + , networkTag + , resolveCurrentEraTx + , signTx + , submitTx + ) +import Cardano.Wallet.Deposit.Write + ( Tx + , resolvedTx + ) +import Cardano.Wallet.Read + ( Coin (..) + , Value (..) + ) +import Cardano.Wallet.UI.Common.Layer + ( SessionLayer + ) +import Cardano.Wallet.UI.Deposit.API.Payments + ( NewReceiverValidation (..) + , Password (..) + , Payment (..) + , Receivers + , Signal + , State + , StateA (..) + , Transaction (..) + , step + ) +import Cardano.Wallet.UI.Deposit.Handlers.Lib + ( catchRunWalletResourceHtml + ) +import Control.Monad.Trans + ( MonadIO (..) + , lift + ) +import Control.Monad.Trans.Except + ( ExceptT (..) + , runExceptT + ) +import Data.Foldable + ( Foldable (..) + ) +import Data.Functor + ( (<&>) + ) +import Data.Semigroup + ( Sum (..) + ) +import Data.Text + ( Text + ) +import Data.Text.Class + ( ToText (..) + ) +import Data.Traversable + ( for + ) +import Servant + ( FromHttpApiData (..) + , Handler + ) + +import qualified Cardano.Wallet.Read.Tx as Read +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Base16.Lazy as BL16 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Monoidal.Strict as MonoidalMap +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +data PaymentError + = CreatePaymentError ErrCreatePayment + | DecodingError DecoderError + | StateTransitionImpossible + | PrivateKeyIsMissing + | SubmissionFailed ErrPostTx + deriving (Eq, Show) + +instance ToText PaymentError where + toText = \case + CreatePaymentError e -> "CreatePaymentError: " <> toText e + DecodingError e -> "DecodingError: " <> T.pack (show e) + StateTransitionImpossible -> "The state transition is impossible" + PrivateKeyIsMissing -> "Cannot sign without a private key" + SubmissionFailed e -> "SubmissionFailed: " <> T.pack (show e) + +extractReceivers :: InspectTx -> Receivers +extractReceivers InspectTx{otherOutputs, ourOutputs} = + fold $ do + (addr, coin) <- + otherOutputs + <> (ourOutputs <&> \(addr, _, c) -> (addr, c)) + pure $ MonoidalMap.singleton addr $ Sum $ fromIntegral coin + +mkPayment :: Payment (ExceptT PaymentError WalletResourceM) +mkPayment = + Payment + { unsigned = unsignedPayment + , sign = signPayment + , submit = submitPayment + , receivers = receiversPayment + } + +submitPayment + :: Transaction -> ExceptT PaymentError WalletResourceM () +submitPayment stx = do + let etx = deserializeTransaction stx + liftIO $ print etx + case etx of + Left e -> ExceptT $ pure $ Left $ DecodingError e + Right tx -> do + e <- do + liftIO $ print $ Read.getTxId tx + lift $ submitTx tx + case e of + Left e' -> ExceptT $ pure $ Left $ SubmissionFailed e' + Right () -> pure () + +signPayment + :: Transaction + -> Password + -> ExceptT PaymentError WalletResourceM Transaction +signPayment serializedTx (Password pwd) = do + let eUnsignedTx = deserializeTransaction serializedTx + case eUnsignedTx of + Left e -> ExceptT $ pure $ Left $ DecodingError e + Right unsignedTx -> do + mSignedTx <- lift $ signTx unsignedTx pwd + case mSignedTx of + Nothing -> ExceptT $ pure $ Left PrivateKeyIsMissing + Just signedTx -> do + pure $ serializeTransaction signedTx + +receiversPayment + :: Transaction -> ExceptT PaymentError WalletResourceM Receivers +receiversPayment stx = do + let etx = deserializeTransaction stx + case etx of + Left e -> ExceptT $ pure $ Left $ DecodingError e + Right tx -> do + rtx <- lift $ resolveCurrentEraTx tx + itx <- lift $ inspectTx rtx + pure $ extractReceivers itx + +unsignedPayment + :: Receivers -> ExceptT PaymentError WalletResourceM Transaction +unsignedPayment receivers = do + er <- lift $ createPayment $ do + (address, Sum amount) <- MonoidalMap.assocs receivers + pure (address, ValueC (CoinC $ fromIntegral amount) mempty) + case er of + Left e -> ExceptT $ pure $ Left $ CreatePaymentError e + Right rtx -> pure $ serializeTransaction $ resolvedTx rtx + +serializeTransaction :: Tx -> Transaction +serializeTransaction = + conwayEraTransactionExport + . T.decodeUtf8 + . B16.encode + . BL.toStrict + . serializeTx + +deserializeTransaction :: Transaction -> Either DecoderError Tx +deserializeTransaction = + deserializeTx + . BL16.decodeLenient + . TL.encodeUtf8 + . TL.fromStrict + . cborHex + +data PaymentHandlerResponse + = ResponseSuccess CanSign (StateA (Transaction, InspectTx)) + | ResponseExceptionPayments PaymentError + deriving (Eq, Show) + +signalHandler + :: SessionLayer WalletResource + -> (BL.ByteString -> html) + -- ^ Function to render the exception as HTML + -> ( Coin + -> PaymentHandlerResponse + -> html + ) + -> State + -> Signal + -> Handler html +signalHandler layer alert render state signal = do + catchRunWalletResourceHtml layer alert id $ do + ValueC available _ <- availableBalance + estate' <- runExceptT $ step mkPayment state signal + case estate' of + Left e -> pure $ render available $ ResponseExceptionPayments e + Right mstate -> + case mstate of + Nothing -> + pure + $ render available + $ ResponseExceptionPayments + StateTransitionImpossible + Just newState -> do + signing <- canSign + er <- for newState $ \stx -> do + let etx = deserializeTransaction stx + case etx of + Left e -> pure $ Left e + Right tx -> do + rtx <- resolveCurrentEraTx tx + itx <- inspectTx rtx + pure $ Right (stx, itx) + case sequence er of + Left e -> + pure + $ render available + $ ResponseExceptionPayments + $ DecodingError e + Right r -> do + pure + $ render available + $ ResponseSuccess signing + $ case r of + x -> x + +conwayEraTransactionExport :: Text -> Transaction +conwayEraTransactionExport cborHex = + Transaction + { dataType = "Unwitnessed Tx ConwayEra" + , description = "Ledger Cddl Format" + , cborHex + } + +data AddressValidationResponse + = ValidAddress Address Bool + | InvalidAddress Text + +data AmountValidationResponse + = ValidAmount Double Bool + | InvalidAmount Text + +tagEq :: NetworkTag -> NetworkTag -> Bool +tagEq MainnetTag MainnetTag = True +tagEq TestnetTag TestnetTag = True +tagEq _ _ = False + +showTag :: NetworkTag -> Text +showTag MainnetTag = "Mainnet" +showTag TestnetTag = "Testnet" + +receiverAddressValidation + :: SessionLayer WalletResource + -> (BL.ByteString -> html) + -> (AddressValidationResponse -> html) + -> NewReceiverValidation + -> Handler html +receiverAddressValidation layer alert render nrv = do + catchRunWalletResourceHtml layer alert id $ do + tag <- networkTag + pure $ render $ addressValidationPure tag nrv + +addressValidationPure + :: NetworkTag -> NewReceiverValidation -> AddressValidationResponse +addressValidationPure tag nrv@NewReceiverValidation{addressValidation} = + case parseUrlPiece <$> addressValidation of + Nothing -> InvalidAddress "Address cannot be empty" + Just (Left e) -> InvalidAddress $ "Invalid address: " <> e + Just (Right addr) + | getNetworkTag addr `tagEq` tag -> + ValidAddress addr + $ case amountValidationPure tag nrv of + ValidAmount _ _ -> True + _ -> False + | otherwise -> + InvalidAddress + $ "Address is not on the " + <> showTag tag + <> " network" + +receiverAmountValidation + :: SessionLayer WalletResource + -> (BL.ByteString -> html) + -> (AmountValidationResponse -> html) + -> NewReceiverValidation + -> Handler html +receiverAmountValidation layer alert render nrv = + catchRunWalletResourceHtml layer alert id $ do + tag <- networkTag + pure $ render $ amountValidationPure tag nrv + +amountValidationPure + :: NetworkTag -> NewReceiverValidation -> AmountValidationResponse +amountValidationPure tag nrv@NewReceiverValidation{amountValidation} = + case parseUrlPiece <$> amountValidation of + Nothing -> InvalidAmount "Amount cannot be empty" + Just (Left e) -> InvalidAmount $ "Invalid amount: " <> e + Just (Right amount) + | amount <= 0 -> InvalidAmount "Amount must be positive" + | otherwise -> ValidAmount amount + $ case addressValidationPure tag nrv of + ValidAddress _ _ -> True + _ -> False + +-- x = +-- Signed +-- ( Transaction +-- { dataType = "Unwitnessed Tx ConwayEra" +-- , description = "Ledger Cddl Format" +-- , cborHex = +-- "84a400d90102828258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661 413ef2da8d73008258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d7301018282581d60b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea1a498d588082581d603ba8830 12bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c1b000000e88b128f32021a00029fed03190e12a0f5f6" +-- } +-- ) +-- ( Transaction +-- { dataType = "Unwitnessed Tx ConwayEra" +-- , description = "Ledger Cddl Fo rmat" +-- , cborHex = +-- "84a400d90102828258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73008258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d7301018 282581d60b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea1a498d588082581d603ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c1b000000e88b128f32021a00029fed03190e12a1 00d90102828258202390837b235279492bcf075e3c272bff29affa11b9a8d889d4b726f596f56b835840f605c66ea76391740c413bf07c33b3388c1e30de51e95ce5779405a4aa250febc521c4bdd8f7e0bc2e0556e96247bcf 1354656911c17158b0f5b65834d4ca505825820fb5939a080736db07e626c777c47c8d27f428ab52b3d08a5b163e6988fc743b058408daf8a9a8d4a88a5af76948869cf4f346dbef620a57864a4d9514d5ba3800c0b60b9bd97 6bbb56494e5249cdaef9ba466c6c84360528ca2b7bbaf07ce02d6c0cf5f6" +-- } +-- , InspectTx +-- { ourInputs = +-- [ +-- ( TxId +-- { unTxId = +-- SafeHash +-- "8859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73" +-- } +-- , TxIx{unTxIx = 0} +-- , Coin 1234000000 +-- ) +-- , +-- ( TxId +-- { unTxId = +-- SafeHash +-- "8859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73" +-- } +-- , TxIx{unTxIx = 1} +-- , Coin 998765834015 +-- ) +-- ] +-- , otherInputs = [] +-- , change = +-- [ +-- ( Addr +-- Testnet +-- ( KeyHashObj +-- ( KeyHash +-- { unKeyHash = "3ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c" +-- } +-- ) +-- ) +-- StakeRefNull +-- , Coin 998765662002 +-- ) +-- ] +-- , ourOutputs = +-- [ +-- ( Add +-- r +-- Testnet +-- ( KeyHashObj +-- ( KeyHash +-- { unKeyHash = "b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea" +-- } +-- ) +-- ) +-- StakeRefNull +-- , 1 +-- , Coin 1234000000 +-- ) +-- ] +-- , otherOutputs = [] +-- , fee = Coin 172013 +-- } +-- ) + +-- y = +-- Submitted +-- ( Transaction +-- { dataType = "Unwitnessed Tx ConwayEra" +-- , description = "Ledger Cddl Format" +-- , cborHex = +-- "84a400d90102828258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73008258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d7301018282581d60b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea1a498d588082581d603ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c1b000000e88b128f32021a00029fed03190e12a0f5f6" +-- } +-- ) +-- ( Transaction +-- { dataType = "Unwitnessed Tx ConwayEra" +-- , description = "Ledger Cddl Format" +-- , cborHex = +-- "84a400d90102828258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73008258208859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d7301018282581d60b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea1a498d588082581d603ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c1b000000e88b128f32021a00029fed03190e12a100d90102828258202390837b235279492bcf075e3c272bff29affa11b9a8d889d4b726f596f56b835840f605c66ea76391740c413bf07c33b3388c1e30de51e95ce5779405a4aa250febc521c4bdd8f7e0bc2e0556e96247bcf1354656911c17158b0f5b65834d4ca505825820fb5939a080736db07e626c777c47c8d27f428ab52b3d08a5b163e6988fc743b058408daf8a9a8d4a88a5af76948869cf4f346dbef620a57864a4d9514d5ba3800c0b60b9bd976bbb56494e5249cdaef9ba466c6c84360528ca2b7bbaf07ce02d6c0cf5f6" +-- } +-- , InspectTx +-- { ourInputs = [] +-- , otherInputs = +-- [ +-- ( TxId +-- { unTxId = +-- SafeHash +-- "8859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73" +-- } +-- , TxIx{unTxIx = 0} +-- ) +-- , +-- ( TxId +-- { unTxId = +-- SafeHash +-- "8859a7e8e4956c5780fc50862873889c8b4eff77a8ab75a02661413ef2da8d73" +-- } +-- , TxIx{unTxIx = 1} +-- ) +-- ] +-- , change = +-- [ +-- ( Addr +-- Testnet +-- ( KeyHashObj +-- ( KeyHash +-- { unKeyHash = "3ba883012bf0d9d6ee94245c4e5671ccf4a1b0b0ba111bea2e971a3c" +-- } +-- ) +-- ) +-- StakeRefNull +-- , Coin 998765662002 +-- ) +-- ] +-- , ourOutputs = +-- [ +-- ( Addr +-- Testnet +-- ( KeyHashObj +-- ( KeyHash +-- { unKeyHash = "b396a8e776ffc5a50def5c9b9bc720ea760ffe3d9a49743fb73d91ea" +-- } +-- ) +-- ) +-- StakeRefNull +-- , 1 +-- , Coin 1234000000 +-- ) +-- ] +-- , otherOutputs = [] +-- , fee = Coin 172013 +-- } +-- ) 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..d09c121480a --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/Page.hs @@ -0,0 +1,554 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page + ( paymentsH + , paymentsElementH + -- , receiversH + -- , updateReceiversH + , availableBalanceElementH + , receiverAddressValidationH + , receiverAmountValidationH + , paymentsChangeH + -- , submitH + ) +where + +import Prelude + +import Cardano.Wallet.Deposit.Pure + ( CanSign (..) + , InspectTx (..) + ) +import Cardano.Wallet.Deposit.Pure.State.Payment.Inspect + ( transactionBalance + ) +import Cardano.Wallet.Read + ( Coin (..) + ) +import Cardano.Wallet.UI.Common.Html.Htmx + ( hxGet_ + , hxInclude_ + , hxPost_ + , hxSwapOob_ + , hxTarget_ + , hxTrigger_ + ) +import Cardano.Wallet.UI.Common.Html.Lib + ( WithCopy (..) + , linkText + , tdEnd + , thEnd + , truncatableText + ) +import Cardano.Wallet.UI.Common.Html.Modal + ( mkModalButton + ) +import Cardano.Wallet.UI.Common.Html.Pages.Lib + ( Striped (..) + , Width (..) + , addressH + , alertH + , box + , field + , record + , simpleField + , sseH + ) +import Cardano.Wallet.UI.Deposit.API + ( modalLink + , paymentsBalanceAvailableLink + , paymentsDeleteReceiverLink + , paymentsNewReceiverLink + , paymentsReceiverAddressValidationLink + , paymentsReceiverAmountValidationLink + , paymentsResetLink + , paymentsSignLink + , paymentsSubmitLink + ) +import Cardano.Wallet.UI.Deposit.API.Payments + ( Receivers + , State + , StateA (..) + , Transaction + ) +import Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction + ( AddressValidationResponse (..) + , AmountValidationResponse (..) + , PaymentHandlerResponse (..) + , extractReceivers + ) +import Cardano.Wallet.UI.Deposit.Html.Common + ( lovelaceH + , txIdH + ) +import Cardano.Wallet.UI.Type + ( WHtml + ) +import Control.Monad + ( forM_ + , when + ) +import Data.Maybe + ( fromMaybe + ) +import Data.Semigroup + ( Sum (..) + ) +import Data.Text + ( Text + ) +import Data.Text.Class + ( ToText (..) + ) +import Lucid + ( Attribute + , Html + , ToHtml (..) + , button_ + , class_ + , data_ + , div_ + , hidden_ + , i_ + , id_ + , input_ + , name_ + , placeholder_ + , span_ + , style_ + , table_ + , tbody_ + , thead_ + , tr_ + , type_ + , value_ + ) +import Servant + ( Link + ) + +import qualified Data.Aeson as Aeson +import qualified Data.Map.Monoidal.Strict as MonoidalMap +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +paymentsH :: Link -> WHtml () +paymentsH paymentsLink = do + sseH paymentsLink "payments-page" ["payments"] + +paymentsChangeH :: Coin -> PaymentHandlerResponse -> Html () +paymentsChangeH balance transaction = do + case transaction of + ResponseExceptionPayments paymentError -> do + setError + $ alertH + $ toText paymentError + ResponseSuccess canSign state -> do + setError mempty + setState [hxSwapOob_ "innerHTML"] $ fst <$> state + case state of + NoState -> do + setReceivers Nothing + setInspection Nothing + setBalance balance Nothing + Unsigned (utx, inspect) -> do + setReceivers $ Just (signatureFormH canSign, inspect) + setInspection $ Just (inspect, utx, Nothing) + setBalance balance $ Just inspect + Signed utx (stx, inspect) -> do + setReceivers $ Just (submitH, inspect) + setInspection $ Just (inspect, utx, Just stx) + setBalance balance $ Just inspect + Submitted utx (stx, inspect) -> do + setReceivers $ Just (newH, inspect) + setInspection $ Just (inspect, utx, Just stx) + setBalance balance Nothing + +setError :: Html () -> Html () +setError = div_ [id_ "transaction-error", hxSwapOob_ "innerHTML"] + +setState :: [Attribute] -> State -> Html () +setState attrs state = + div_ ([id_ "payment-state"] <> attrs) + $ input_ + [ hidden_ "" + , name_ "payment-state" + , value_ $ TL.toStrict $ TL.decodeUtf8 $ Aeson.encode state + ] + +setReceivers :: Maybe (Html (), InspectTx) -> Html () +setReceivers mInspect = + div_ [id_ "receivers", hxSwapOob_ "innerHTML"] + $ case mInspect of + Nothing -> receiversH Nothing + Just (canSign, inspect) -> do + receiversH $ Just (canSign, extractReceivers inspect) + +setInspection + :: Maybe (InspectTx, Transaction, Maybe Transaction) + -> Html () +setInspection inspect = do + div_ [id_ "transaction-inspection", hxSwapOob_ "innerHTML"] + $ foldMap transactionInspectionH inspect + +setBalance :: Coin -> Maybe InspectTx -> Html () +setBalance balance mInspect = do + div_ [id_ "available-balance", hxSwapOob_ "innerHTML"] + $ availableBalanceElementH balance + $ case mInspect of + Just inspect -> + Just + $ fromIntegral + $ transactionBalance inspect + _ -> Nothing + +newReceiverH :: Html () +newReceiverH = do + let spanFlex = span_ [class_ "d-flex"] + tbody_ [id_ "new-receiver-form"] + $ tr_ [class_ "border-top pt-2"] + $ do + tdEnd + $ spanFlex + $ do + div_ [id_ "receiver-address-validation"] mempty + input_ + [ class_ "form-control text-end" + , type_ "text" + , name_ "new-receiver-address" + , hxPost_ + $ linkText + paymentsReceiverAddressValidationLink + , hxTarget_ "#receiver-address-validation" + , hxInclude_ "#new-receiver-form" + , hxTrigger_ "input" + , placeholder_ "payment address" + ] + tdEnd + $ spanFlex + $ do + div_ [id_ "receiver-amount-validation"] mempty + input_ + [ class_ "form-control text-end" + , type_ "text" + , name_ "new-receiver-amount" + , hxPost_ + $ linkText + paymentsReceiverAmountValidationLink + , hxTarget_ "#receiver-amount-validation" + , hxInclude_ "#new-receiver-form" + , hxTrigger_ "input" + , placeholder_ "amount in ada" + ] + + tdEnd + $ spanFlex + $ button_ + [ class_ "btn w-100" + , hxPost_ $ linkText paymentsNewReceiverLink + , hxInclude_ "#payment-state , #new-receiver-form" + , hxTarget_ "#none" + , id_ "new-receiver-button" + ] + mempty + +receiversH :: Maybe (Html (), Receivers) -> Html () +receiversH m = do + div_ [class_ "d-flex justify-content-end"] $ do + table_ + [ class_ "table table-sm table-borderless table-hover striped-columns" + ] + $ do + thead_ $ do + tr_ $ do + thEnd Nothing "Address" + thEnd (Just 9) "Amount" + thEnd (Just 5) "Actions" + tbody_ [id_ "payment-state"] + $ forM_ (MonoidalMap.assocs $ foldMap snd m) + $ \(address, Sum amount) -> do + tr_ $ do + tdEnd $ do + addressH WithCopy address + + tdEnd $ lovelaceH amount + tdEnd + $ button_ + [ hxPost_ + $ linkText + $ paymentsDeleteReceiverLink + $ Just address + , hxInclude_ "#payment-state" + , hxTarget_ "#none" + , class_ "btn w-100" + ] + $ i_ [class_ "bi bi-trash"] mempty + newReceiverH + case m of + Just (h, _) -> div_ [class_ "px-2"] h + _ -> pure () + +ifNotEmpty :: (Foldable t, Monoid b) => t a -> b -> b +ifNotEmpty xs b = if null xs then mempty else b + +transactionInspectionH + :: (InspectTx, Transaction, Maybe Transaction) + -> Html () +transactionInspectionH (InspectTx{..}, utx, mstx) = do + let table = table_ [class_ "table table-sm m-0"] + div_ [class_ ""] $ do + record (Just 7) Full Striped $ do + field [] "unsigned transaction" + $ transactionCBORH "unsigned-transaction-copy" utx + case mstx of + Just stx -> + field [] "signed transaction" + $ transactionCBORH "signed-transaction-copy" stx + Nothing -> pure () + field [] "fee" + $ lovelaceH + $ fromIntegral fee + field [] "our inputs" + $ ifNotEmpty ourInputs + $ table + $ do + thead_ $ do + tr_ $ do + thEnd Nothing $ toHtml $ truncatableText WithoutCopy "" "Transaction" + thEnd (Just 4) "Index" + thEnd (Just 7) "Amount" + tbody_ + $ forM_ ourInputs + $ \(txId, txIx, CoinC amount) -> do + tr_ $ do + tdEnd $ txIdH txId + tdEnd $ toHtml $ show $ fromEnum txIx + tdEnd $ lovelaceH $ fromIntegral amount + field [] "other inputs" + $ ifNotEmpty otherInputs + $ table + $ do + thead_ $ do + tr_ $ do + thEnd Nothing $ toHtml $ truncatableText WithoutCopy "" "Transaction" + thEnd (Just 4) "Index" + tbody_ + $ forM_ otherInputs + $ \(txId, txIx) -> do + tr_ $ do + tdEnd $ txIdH txId + tdEnd $ toHtml $ show $ fromEnum txIx + field [] "change" + $ ifNotEmpty change + $ table + $ do + thead_ $ do + tr_ $ do + thEnd Nothing $ toHtml $ truncatableText WithoutCopy "" "Change Address" + thEnd (Just 7) "Amount" + tbody_ + $ forM_ change + $ \(addr, CoinC amount) -> do + tr_ $ do + tdEnd $ addressH WithCopy addr + tdEnd $ lovelaceH $ fromIntegral amount + field [] "customer outputs" + $ ifNotEmpty ourOutputs + $ table + $ do + thead_ $ do + tr_ $ do + thEnd Nothing $ toHtml $ truncatableText WithoutCopy "" "Address" + thEnd (Just 6) "Customer" + thEnd (Just 7) "Amount" + tbody_ + $ forM_ ourOutputs + $ \(addr, customer, CoinC amount) -> do + tr_ $ do + tdEnd $ addressH WithCopy addr + tdEnd $ toHtml $ show customer + tdEnd $ lovelaceH $ fromIntegral amount + field [] "other outputs" + $ ifNotEmpty otherOutputs + $ table + $ do + thead_ $ do + tr_ $ do + thEnd Nothing "Address" + thEnd (Just 7) "Amount" + tbody_ + $ forM_ otherOutputs + $ \(addr, CoinC amount) -> do + tr_ $ do + tdEnd $ addressH WithCopy addr + tdEnd $ lovelaceH $ fromIntegral amount + +transactionCBORH :: Text -> Transaction -> Html () +transactionCBORH copyName cbor = + truncatableText WithCopy copyName -- "unsigned-transaction-copy" + $ toHtml + $ Aeson.encode cbor + +signatureFormH :: CanSign -> Html () +signatureFormH = \case + CanSign -> do + div_ [class_ "d-flex justify-content-end"] $ do + div_ [class_ "input-group", style_ "max-width:35em"] $ do + -- span_ [class_ "input-group-text"] "Sign" + input_ + [ id_ "signature-password" + , class_ "form-control text-end" + , type_ "password" + , name_ "passphrase" + , placeholder_ "passphrase" + ] + button_ + [ class_ "btn btn-secondary" + , hxPost_ $ linkText paymentsSignLink + , hxTarget_ "#none" + , hxInclude_ "#signature-password, #payment-state" + ] + "Sign" + CannotSign -> "paste signed tx not implemented" + +submitH :: Html () +submitH = do + div_ [class_ "input-group d-flex justify-content-end"] $ do + -- span_ [class_ "input-group-text"] "Submit" + button_ + [ class_ "btn btn-secondary" + , hxPost_ $ linkText paymentsSubmitLink + , hxInclude_ "#payment-state" + , hxTarget_ "#none" + ] + "Submit" + +newH :: Html () +newH = do + div_ [class_ "input-group d-flex justify-content-end"] $ do + -- span_ [class_ "input-group-text"] "New transaction" + button_ + [ class_ "btn btn-secondary" + , hxPost_ $ linkText paymentsResetLink + , hxTarget_ "#none" + ] + "Reset" + +availableBalanceElementH :: Coin -> Maybe Coin -> Html () +availableBalanceElementH balance mTxBalance = + record Nothing Auto Striped $ do + simpleField "Before transaction" + $ div_ [class_ "d-flex justify-content-end"] + $ lovelaceH + $ fromIntegral balance + simpleField "Transaction balance" + $ div_ [class_ "d-flex justify-content-end"] + $ lovelaceH + $ fromIntegral + $ fromMaybe 0 mTxBalance + simpleField "After transaction" + $ div_ [class_ "d-flex justify-content-end"] + $ lovelaceH + $ fromIntegral + $ balance - fromMaybe 0 mTxBalance + +{- restoreH :: Html () +restoreH = div_ [class_ "input-group"] $ do + input_ + [ class_ "form-control" + , type_ "text" + , name_ "restore-transaction" + , placeholder_ "serialized tx" + ] + button_ + [ class_ "btn" + , hxPost_ $ linkText paymentsRestoreLink + , hxTarget_ "#receivers" + , hxInclude_ "#restoration" + ] + $ i_ [class_ "bi bi-upload"] mempty -} + +collapseBtn :: Text -> Html () +collapseBtn identifier = + button_ + [ class_ "btn" + , type_ "button" + , data_ "bs-toggle" "collapse" + , data_ + "bs-target" + $ "#" <> identifier + ] + $ i_ [class_ "bi bi-arrows-collapse"] mempty + +paymentsElementH + :: Html () +paymentsElementH = + div_ + [ class_ "row mt-3 gx-0" + ] + $ do + div_ [id_ "none"] mempty + box "New" mempty + $ do + setState [] NoState + box "Payment Receivers" mempty + $ do + div_ + [ id_ "receivers" + ] + $ receiversH Nothing + div_ [id_ "transaction-error"] mempty + div_ [id_ "copy-transaction"] mempty + box "Wallet Balance" (collapseBtn "available-balance") + $ div_ + [ class_ "collapse d-flex justify-content-end" + , id_ "available-balance" + , hxTrigger_ "load" + , hxGet_ $ linkText paymentsBalanceAvailableLink + , hxInclude_ "#payment-state" + , hxTarget_ "#available-balance" + ] + mempty + box + "Transaction Content" + (collapseBtn "transaction-inspection") + $ div_ + [ class_ "collapse" + , id_ "transaction-inspection" + ] + mempty + +{- box + "Restoration" + (collapseBtn "restoration") + $ div_ + [ class_ "collapse" + , id_ "restoration" + ] + restoreH -} + +receiverAddressValidationH :: AddressValidationResponse -> Html () +receiverAddressValidationH (ValidAddress _ m) = + div_ [id_ "new-receiver-button", hxSwapOob_ "innerHTML"] + $ when m + $ i_ [class_ "bi bi-plus-lg"] mempty +receiverAddressValidationH (InvalidAddress e) = do + validationFailedButton "Invalid Address" $ toText e + div_ [id_ "new-receiver-button"] mempty + +receiverAmountValidationH :: AmountValidationResponse -> Html () +receiverAmountValidationH (ValidAmount _ m) = do + div_ [id_ "new-receiver-button", hxSwapOob_ "innerHTML"] + $ when m + $ i_ [class_ "bi bi-plus-lg"] mempty +receiverAmountValidationH (InvalidAmount e) = do + validationFailedButton "Invalid Amount" $ toText e + div_ [id_ "new-receiver-button"] mempty + +validationFailedButton :: Text -> Text -> Html () +validationFailedButton t e = + mkModalButton + (modalLink (Just t) $ Just e) + [class_ "btn px-1"] + $ i_ [class_ "bi bi-exclamation-triangle text-danger-emphasis"] mempty diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs index 7a43fcf0294..1b71e0cc86a 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs @@ -77,7 +77,8 @@ import Cardano.Wallet.UI.Deposit.Handlers.Lib ( walletPresence ) import Cardano.Wallet.UI.Deposit.Html.Common - ( showTimeSecs + ( modalElementH + , showTimeSecs ) import Cardano.Wallet.UI.Deposit.Html.Pages.Page ( Page (..) @@ -107,6 +108,17 @@ import Cardano.Wallet.UI.Deposit.Server.Deposits.TxIds import Cardano.Wallet.UI.Deposit.Server.Lib ( renderSmoothHtml ) +import Cardano.Wallet.UI.Deposit.Server.Payments.Page + ( servePaymentsBalanceAvailable + , servePaymentsDeleteReceiver + , servePaymentsNewReceiver + , servePaymentsPage + , servePaymentsReceiverAddressValidation + , servePaymentsReceiverAmountValidation + , servePaymentsReset + , servePaymentsSign + , servePaymentsSubmit + ) import Cardano.Wallet.UI.Deposit.Server.Wallet ( serveDeleteWallet , serveDeleteWalletModal @@ -124,6 +136,9 @@ import Control.Tracer import Data.Functor ( ($>) ) +import Data.Text + ( Text + ) import Paths_cardano_wallet_ui ( getDataFileName ) @@ -159,6 +174,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 @@ -181,6 +197,27 @@ serveUI tr ul env dbDir config nid nl bs = :<|> serveDepositsCustomerPagination ul :<|> serveDepositsCustomersTxIds ul :<|> serveDepositsCustomersTxIdsPagination ul + :<|> servePaymentsPage ul + :<|> servePaymentsNewReceiver ul + :<|> servePaymentsDeleteReceiver ul + :<|> servePaymentsBalanceAvailable ul + :<|> servePaymentsReceiverAddressValidation ul + :<|> servePaymentsReceiverAmountValidation ul + :<|> serveModal ul + :<|> servePaymentsSign ul + :<|> servePaymentsSubmit ul + :<|> servePaymentsReset ul + +serveModal + :: UILayer WalletResource + -> Maybe Text + -> Maybe Text + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +serveModal ul mtitle mbody = withSessionLayer ul $ \_ -> + pure + $ renderSmoothHtml + $ modalElementH mtitle mbody 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..6b1aac3b29e --- /dev/null +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Payments/Page.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Cardano.Wallet.UI.Deposit.Server.Payments.Page + ( servePaymentsPage + , servePaymentsNewReceiver + , servePaymentsDeleteReceiver + , servePaymentsBalanceAvailable + , servePaymentsReceiverAddressValidation + , servePaymentsReceiverAmountValidation + , servePaymentsSign + , servePaymentsSubmit + , servePaymentsReset + ) +where + +import Prelude + +import Cardano.Wallet.Deposit.REST + ( WalletResource + ) +import Cardano.Wallet.Deposit.Write + ( Address + ) +import Cardano.Wallet.UI.Common.Handlers.Session + ( withSessionLayer + ) +import Cardano.Wallet.UI.Common.Html.Html + ( RawHtml (..) + , renderHtml + ) +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 + ( AddReceiverForm (..) + , NewReceiver (..) + , NewReceiverValidation + , Signal (..) + , SignatureForm (..) + , State + , StateA (..) + , signatureFormState + ) +import Cardano.Wallet.UI.Deposit.Handlers.Payments.Balance + ( getAvailableBalance + ) +import Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction + ( receiverAddressValidation + , receiverAmountValidation + , signalHandler + ) +import Cardano.Wallet.UI.Deposit.Html.Pages.Payments.Page + ( availableBalanceElementH + , paymentsChangeH + , paymentsElementH + , receiverAddressValidationH + , receiverAmountValidationH + ) +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 + pure $ renderSmoothHtml paymentsElementH + +servePaymentsNewReceiver + :: UILayer WalletResource + -> AddReceiverForm + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsNewReceiver ul (AddReceiverForm (NewReceiver receiver) state) = + withSessionLayer ul $ \layer -> do + renderHtml + <$> signalHandler + layer + alertH + paymentsChangeH + state + (AddReceiver receiver) + +servePaymentsDeleteReceiver + :: UILayer WalletResource + -> State + -> Maybe Address + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsDeleteReceiver ul state (Just receiver) = + withSessionLayer ul $ \layer -> do + renderHtml + <$> signalHandler + layer + alertH + paymentsChangeH + state + (DeleteReceiver receiver) +servePaymentsDeleteReceiver _ _ _ = + error "servePaymentsDeleteReceiver: receiver-number is required" + +servePaymentsBalanceAvailable + :: UILayer WalletResource + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsBalanceAvailable ul = withSessionLayer ul $ \layer -> do + renderSmoothHtml + <$> getAvailableBalance + layer + (`availableBalanceElementH` Nothing) + alertH + +servePaymentsReceiverAddressValidation + :: UILayer WalletResource + -> NewReceiverValidation + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsReceiverAddressValidation ul receiver = withSessionLayer ul + $ \layer -> do + renderHtml + <$> receiverAddressValidation + layer + alertH + receiverAddressValidationH + receiver + +servePaymentsReceiverAmountValidation + :: UILayer WalletResource + -> NewReceiverValidation + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsReceiverAmountValidation ul amount = withSessionLayer ul + $ \layer -> do + renderHtml + <$> receiverAmountValidation + layer + alertH + receiverAmountValidationH + amount + +servePaymentsSign + :: UILayer WalletResource + -> SignatureForm + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsSign ul SignatureForm{signatureFormState, signaturePassword} = + withSessionLayer ul $ \layer -> do + renderHtml + <$> signalHandler + layer + alertH + paymentsChangeH + signatureFormState + (Sign signaturePassword) + +servePaymentsSubmit + :: UILayer WalletResource + -> State + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsSubmit ul state = + withSessionLayer ul $ \layer -> do + renderHtml + <$> signalHandler + layer + alertH + paymentsChangeH + state + Submit + +servePaymentsReset + :: UILayer WalletResource + -> Maybe RequestCookies + -> Handler (CookieResponse RawHtml) +servePaymentsReset ul = + withSessionLayer ul $ \layer -> do + renderHtml + <$> signalHandler + layer + alertH + paymentsChangeH + NoState + Reset 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 diff --git a/lib/ui/test/unit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/PageSpec.hs b/lib/ui/test/unit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/PageSpec.hs new file mode 100644 index 00000000000..8cbba3ac91e --- /dev/null +++ b/lib/ui/test/unit/Cardano/Wallet/UI/Deposit/Html/Pages/Payments/PageSpec.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecordWildCards #-} + +module Cardano.Wallet.UI.Deposit.Html.Pages.Payments.PageSpec + ( spec + ) +where + +import Prelude + +import Cardano.Wallet.Deposit.IO + ( WalletBootEnv (WalletBootEnv) + , networkEnv + ) +import Cardano.Wallet.Deposit.IO.Network.Mock + ( newNetworkEnvMock + ) +import Cardano.Wallet.Deposit.IO.Network.Type + ( NetworkEnv + , mapBlock + , postTx + ) +import Cardano.Wallet.Deposit.IO.Resource + ( withResource + ) +import Cardano.Wallet.Deposit.Pure + ( Credentials + ) +import Cardano.Wallet.Deposit.Pure.State.Creation + ( credentialsFromMnemonics + ) +import Cardano.Wallet.Deposit.Pure.State.Payment.Inspect + ( InspectTx (..) + ) +import Cardano.Wallet.Deposit.REST + ( ErrWalletResource (..) + , WalletResourceM + , customerAddress + , initWallet + , inspectTx + , resolveCurrentEraTx + , runWalletResourceM + ) +import Cardano.Wallet.Deposit.Write + ( addTxOut + , emptyTxBody + , mkAda + , mkTx + , mkTxOut + ) +import Cardano.Wallet.UI.Deposit.API.Payments + ( unsigned + ) +import Cardano.Wallet.UI.Deposit.Handlers.Payments.Transaction + ( deserializeTransaction + , mkPayment + ) +import Control.Concurrent + ( threadDelay + ) +import Control.Monad.IO.Class + ( MonadIO (..) + ) +import Control.Tracer + ( nullTracer + ) +import System.IO.Temp + ( withSystemTempDirectory + ) +import Test.Hspec + ( Spec + , describe + , it + , shouldNotBe + ) + +import qualified Cardano.Wallet.Deposit.Read as Read +import Control.Monad.Except + ( runExceptT + ) + +fakeBootEnv :: IO (WalletBootEnv IO) +fakeBootEnv = do + net <- mapBlock Read.EraValue <$> newNetworkEnvMock + pure $ WalletBootEnv nullTracer Read.mockGenesisDataMainnet net + +credentials :: Credentials +credentials = + credentialsFromMnemonics "random seed for a testing xpub lala" mempty + +letItInitialize :: WalletResourceM () +letItInitialize = liftIO $ threadDelay 100_000 + +onSuccess :: (Show e, MonadFail m) => Either e a -> (a -> m b) -> m b +onSuccess (Left e) _ = fail $ show e +onSuccess (Right a) f = f a + +withWallet :: WalletResourceM a -> IO (Either ErrWalletResource a) +withWallet f = withResource $ runWalletResourceM f + +withInitializedWallet + :: WalletResourceM a + -> IO (Either ErrWalletResource a) +withInitializedWallet f = + withSystemTempDirectory "wallet-ui" $ \dir -> do + bootEnv <- fakeBootEnv + withWallet $ do + initWallet nullTracer bootEnv dir credentials 1 + letItInitialize + fundTheWallet (networkEnv bootEnv) + f + +fundTheWallet :: NetworkEnv IO z -> WalletResourceM () +fundTheWallet network = do + Just address <- customerAddress 0 + let tx = + mkTx + $ fst + $ addTxOut (mkTxOut address (mkAda 1_000_000)) emptyTxBody + Right () <- liftIO $ postTx network tx + pure () + +spec :: Spec +spec = do + describe "payment" $ do + it "can create a transaction with no receivers" $ do + etx <- withInitializedWallet $ do + etx <- runExceptT $ unsigned mkPayment mempty + onSuccess etx $ \tx -> do + onSuccess (deserializeTransaction tx) $ \dtx -> do + tx' <- resolveCurrentEraTx dtx + inspectTx tx' + onSuccess etx $ \InspectTx{..} -> do + change `shouldNotBe` [] + ourInputs `shouldNotBe` [] + fee `shouldNotBe` 0