diff --git a/lib/exe/lib/Cardano/Wallet/Application.hs b/lib/exe/lib/Cardano/Wallet/Application.hs index aa591d8dddd..842f5673913 100644 --- a/lib/exe/lib/Cardano/Wallet/Application.hs +++ b/lib/exe/lib/Cardano/Wallet/Application.hs @@ -95,12 +95,6 @@ import Cardano.Wallet.DB.Layer import Cardano.Wallet.DB.Sqlite.Migration.Old ( DefaultFieldValues (..) ) -import Cardano.Wallet.Deposit.IO.Network.Mock - ( newNetworkEnvMock - ) -import Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv - ) import Cardano.Wallet.Deposit.IO.Resource ( withResource ) @@ -441,11 +435,9 @@ serveWallet ) resource sourceOfNewTip netLayer ui - networkEnv <- liftIO newNetworkEnvMock let uiService = startDepositUiServer ui - networkEnv databaseDir' socket sNetwork @@ -453,7 +445,7 @@ serveWallet blockchainSource ContT $ \k -> withAsync uiService $ \_ -> k () - pure $ Just (databaseDir', resource, networkEnv) + pure $ Just (databaseDir', resource) case eDepositSocket of Left err -> do lift $ trace $ MsgServerStartupError err @@ -479,7 +471,7 @@ serveWallet fakeBootEnv resource pure (databaseDir', resource) - Just (databaseDir', w, _) -> + Just (databaseDir', w) -> pure (databaseDir', w) let depositService = startDepositServer @@ -639,11 +631,10 @@ serveWallet socket application startDepositUiServer - :: forall n x + :: forall n . ( HasSNetworkId n ) => UILayer WalletResource - -> NetworkEnv IO x -> FilePath -> Socket -> SNetworkId n @@ -652,7 +643,6 @@ serveWallet -> IO () startDepositUiServer ui - networkEnv databaseDir' socket _proxy @@ -664,7 +654,6 @@ serveWallet Server.serve api $ DepositUi.serveUI (DepositUIApplicationLog >$< applicationTracer) - networkEnv ui fakeBootEnv databaseDir' diff --git a/lib/ui/cardano-wallet-ui.cabal b/lib/ui/cardano-wallet-ui.cabal index cb422d1761a..e10764ce783 100644 --- a/lib/ui/cardano-wallet-ui.cabal +++ b/lib/ui/cardano-wallet-ui.cabal @@ -123,6 +123,7 @@ library , lens , lucid , memory + , monoidal-containers , mmorph , mtl , ntp-client diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs index 065d6fba1ea..e5995a6f3f6 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs @@ -1,41 +1,30 @@ -{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} module Cardano.Wallet.UI.Deposit.Handlers.Addresses.Transactions where -import Prelude - -import Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv - , slotsToUTCTimes +import Prelude hiding + ( lookup ) + import Cardano.Wallet.Deposit.Pure - ( Customer - , TxSummary (..) - , ValueTransfer (ValueTransfer) + ( ValueTransfer (..) ) import Cardano.Wallet.Deposit.Read - ( Slot + ( Address + , Slot ) import Cardano.Wallet.Deposit.REST ( WalletResource , customerAddress ) -import Cardano.Wallet.Deposit.Time - ( unsafeSlotOfUTCTime - ) import Cardano.Wallet.Read - ( Coin - , SlotNo (..) + ( TxId , WithOrigin (..) - , slotFromChainPoint - , txIdFromHash - ) -import Cardano.Wallet.Read.Hash - ( hashFromStringAsHex ) import Cardano.Wallet.UI.Common.Layer ( SessionLayer (..) @@ -52,61 +41,56 @@ import Cardano.Wallet.UI.Lib.Time.Direction , sortByDirection , utcTimeByDirection ) -import Control.Monad - ( replicateM - ) -import Control.Monad.IO.Class - ( MonadIO (..) + +import Cardano.Wallet.Deposit.Map + ( Map (..) + , W + , forgetPatch + , lookup + , openMap + , unPatch ) import Data.Foldable - ( toList + ( fold ) -import Data.Function - ( on +import Data.Monoid + ( First (..) ) -import Data.List - ( sortBy +import Data.Ord + ( Down (..) ) -import Data.Map.Strict - ( Map +import Servant + ( Handler ) -import Data.Maybe - ( fromJust + +import Cardano.Wallet.Deposit.Pure.API.TxHistory + ( DownTime + , TxHistory (..) ) -import Data.Time - ( UTCTime (..) - , getCurrentTime +import Cardano.Wallet.UI.Deposit.Handlers.Deposits.Mock + ( getMockHistory ) -import Servant - ( Handler +import Data.Bifunctor + ( first ) -import System.Random.Stateful - ( StatefulGen - , UniformRange (..) - , mkStdGen - , runStateGen_ +import Data.Time + ( UTCTime ) -import qualified Cardano.Wallet.Deposit.REST as REST -import qualified Cardano.Wallet.Read as Read import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set +import qualified Data.Map.Monoidal.Strict as MonoidalMap getCustomerHistory - :: NetworkEnv IO a - -> SessionLayer WalletResource + :: SessionLayer WalletResource -> ( Bool -> TransactionHistoryParams - -> Map Slot (WithOrigin UTCTime) - -> [TxSummary] + -> [(WithOrigin UTCTime, (Slot, TxId, ValueTransfer))] -> html ) -> (BL.ByteString -> html) -> TransactionHistoryParams -> Handler html getCustomerHistory - network layer render alert @@ -116,32 +100,37 @@ getCustomerHistory case r of Nothing -> pure $ alert "Address not discovered" Just _ -> do - h <- REST.getCustomerHistory txHistoryCustomer - (b, summaries) <- - liftIO - $ fakeData txHistoryCustomer . toList - $ h - let slots = - Set.fromList - $ slotFromChainPoint - . txChainPoint - <$> summaries - times <- liftIO $ slotsToUTCTimes network slots + h <- byCustomer <$> getMockHistory pure - $ render b params times - $ filterByParams params times summaries + $ render True params + $ filterByParams params + $ convert + $ lookup txHistoryCustomer h + +convert + :: Maybe + (Map '[W (First Address) DownTime, W (First Slot) TxId] ValueTransfer) + -> [(DownTime, (Slot, TxId, ValueTransfer))] +convert = concatMap f . MonoidalMap.assocs . openMap . forgetPatch . fold + where + f :: (DownTime, Map '[W (First Slot) TxId] ValueTransfer) + -> [(DownTime, (Slot, TxId, ValueTransfer))] + f (time, txs) = do + (txId, Value (First (Just slot) , value) ) + <- MonoidalMap.assocs . openMap . unPatch $ txs + pure (time, (slot, txId, value)) filterByParams :: TransactionHistoryParams - -> Map Slot (WithOrigin UTCTime) - -> [TxSummary] - -> [TxSummary] -filterByParams TransactionHistoryParams{..} times = - sortByDirection txHistorySorting txChainPoint + -> [(DownTime, (Slot, TxId, ValueTransfer))] + -> [(WithOrigin UTCTime, (Slot, TxId, ValueTransfer))] +filterByParams TransactionHistoryParams{..} = + sortByDirection txHistorySorting fst . filterByDirection txHistorySorting startTime matchUTCTime + . fmap (first getDown) . filterByTransfer where startTime = @@ -149,102 +138,20 @@ filterByParams TransactionHistoryParams{..} times = txHistorySorting txHistoryStartYear txHistoryStartMonth - matchUTCTime :: TxSummary -> Match UTCTime - matchUTCTime TxSummaryC{txChainPoint = cp} = + matchUTCTime (time, (_, _, _)) = do - let slot :: Slot = slotFromChainPoint cp - case Map.lookup slot times of - Just (At t) -> Match t - Just Origin -> DirectionMatch - _ -> NoMatch + case time of + At t -> Match t + Origin -> DirectionMatch filterByTransfer = case (txHistoryReceived, txHistorySpent) of (True, False) -> filter - ( \TxSummaryC{txTransfer = ValueTransfer _ received} -> + ( \(_, (_, _, ValueTransfer{received})) -> received /= mempty ) (False, True) -> filter - ( \TxSummaryC{txTransfer = ValueTransfer spent _} -> + ( \(_, (_, _, ValueTransfer{spent})) -> spent /= mempty ) _ -> id - --- fake data generation until DB is implemented - -fakeData :: Customer -> [TxSummary] -> IO (Bool, [TxSummary]) -fakeData c [] = do - now <- getCurrentTime - pure - $ (True,) - $ sortBy - (on compare $ \(TxSummaryC _ cp _) -> cp) - $ txSummaryG now (fromIntegral c) -fakeData _c xs = pure (False, xs) - -unsafeMkTxId :: String -> Read.TxId -unsafeMkTxId = txIdFromHash . fromJust . hashFromStringAsHex - -hexOfInt :: Int -> Char -hexOfInt n = "0123456789abcdef" !! (n `mod` 16) - -headerHash :: StatefulGen g m => g -> m [Char] -headerHash g = replicateM 64 $ hexOfInt <$> uniformRM (0, 15) g - -randomValue :: StatefulGen g f => g -> Read.Coin -> f Read.Value -randomValue g l = Read.ValueC <$> uniformRM (0, l) g <*> pure mempty - -maxLovelaces :: Coin -maxLovelaces = 1_000_000_000 - -createSpent :: StatefulGen g f => g -> Int -> f Read.Value -createSpent g r = randomValue g l - where - l = if r >= 0 && r < 5 || r == 11 then maxLovelaces else 0 - -createReceived :: StatefulGen g f => g -> Int -> f Read.Value -createReceived g r = randomValue g l - where - l = if r >= 5 && r <= 11 then maxLovelaces else 0 - -valueTransferG :: StatefulGen g m => g -> m ValueTransfer -valueTransferG g = do - spentOrReceived <- uniformRM (0, 11) g - spent <- createSpent g spentOrReceived - received <- createReceived g spentOrReceived - pure $ ValueTransfer spent received - -txSummaryG :: UTCTime -> Int -> [TxSummary] -txSummaryG now c = runStateGen_ pureGen $ \g -> do - ns <- uniformRM (1, 200) g - replicateM ns $ do - txId <- txIdR g - cp <- chainPointR g - value <- valueTransferG g - pure $ TxSummaryC txId cp value - where - pureGen = mkStdGen c - - chainPointR g = do - case unsafeSlotOfUTCTime now of - Origin -> pure Read.GenesisPoint - At (SlotNo slotNo) -> do - slotInt :: Int <- uniformRM (-1, fromIntegral slotNo) g - r <- hashFromStringAsHex <$> headerHash g - case r of - Just h -> do - pure - $ if slotInt == -1 - then Read.GenesisPoint - else - Read.BlockPoint - (SlotNo $ fromIntegral slotInt) - h - Nothing -> error "chainPointR: invalid hash" -txIdR :: StatefulGen g m => g -> m Read.TxId -txIdR g = do - ls <- - fmap (concatMap $ replicate 8) - $ replicateM 8 - $ hexOfInt <$> uniformRM (0, 15) g - pure $ unsafeMkTxId ls diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses/Transactions.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses/Transactions.hs index cd7176653ad..163aa5c1eec 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses/Transactions.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Html/Pages/Addresses/Transactions.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -12,23 +11,15 @@ where import Prelude import Cardano.Wallet.Deposit.Pure - ( TxSummary (..) + ( ValueTransfer , received , spent ) -import Cardano.Wallet.Read.Hash - ( hashToStringAsHex - ) -import Cardano.Wallet.Read.Tx - ( hashFromTxId - ) import Cardano.Wallet.UI.Common.Html.Lib - ( WithCopy (..) - , linkText + ( linkText , overlayFakeDataH , tdEnd , thEnd - , truncatableText ) import Cardano.Wallet.UI.Common.Html.Pages.Lib ( Striped (..) @@ -67,7 +58,6 @@ import Lucid , style_ , table_ , tbody_ - , td_ , thead_ , tr_ , type_ @@ -76,26 +66,23 @@ import Lucid import Cardano.Wallet.Deposit.Read ( Slot - , WithOrigin (..) - ) -import Data.Map.Strict - ( Map - ) -import Data.Text - ( Text + , TxId + , WithOrigin ) - import Cardano.Wallet.UI.Common.Html.Htmx ( hxInclude_ , hxPost_ , hxTarget_ , hxTrigger_ ) -import Cardano.Wallet.UI.Deposit.Server.Lib - ( showTime +import Cardano.Wallet.UI.Deposit.Html.Common + ( slotH + , timeH + , txIdH + , withOriginH ) -import Data.Text.Class - ( ToText (..) +import Data.Text + ( Text ) import Data.Time ( UTCTime (..) @@ -106,20 +93,8 @@ import Numeric ) import qualified Cardano.Wallet.Read as Read -import qualified Data.Map.Strict as Map import qualified Data.Text.Class as T -chainPointToUTCH - :: Map Slot (WithOrigin UTCTime) - -> Read.ChainPoint - -> Html () -chainPointToUTCH - times - cp = case Map.lookup (Read.slotFromChainPoint cp) times of - Just (At t) -> toHtml $ showTime t - Just Origin -> toHtml ("Genesis" :: Text) - Nothing -> toHtml ("Unknown" :: Text) - chainPointToSlotH :: Read.ChainPoint -> Html () @@ -136,42 +111,35 @@ valueH (Read.ValueC (Read.CoinC c) _) = do txSummaryH :: TransactionHistoryParams - -> Map Slot (WithOrigin UTCTime) - -> (Int, TxSummary) + -> (WithOrigin UTCTime, (Slot, TxId, ValueTransfer)) -> Html () txSummaryH TransactionHistoryParams{..} - times - (index, TxSummaryC{txSummarized, txChainPoint, txTransfer}) = do + (time, (slot, txId, value)) = do tr_ [scope_ "row"] $ do when txHistorySlot $ tdEnd - $ chainPointToSlotH txChainPoint + $ slotH slot when txHistoryUTC $ tdEnd - $ chainPointToUTCH times txChainPoint + $ withOriginH timeH time when txHistoryReceived $ tdEnd $ valueH - $ received txTransfer + $ received value when txHistorySpent $ tdEnd $ valueH - $ spent txTransfer - td_ [scope_ "col", class_ "flex-fill align-bottom"] - $ truncatableText WithCopy ("tx-id-text-" <> toText index) - $ toHtml - $ hashToStringAsHex - $ hashFromTxId txSummarized + $ spent value + tdEnd $ txIdH txId customerHistoryH :: Monad m => Bool -> TransactionHistoryParams - -> Map Slot (WithOrigin UTCTime) - -> [TxSummary] + -> [(WithOrigin UTCTime,(Slot, TxId, ValueTransfer))] -> HtmlT m () -customerHistoryH fake params@TransactionHistoryParams{..} times txs = +customerHistoryH fake params@TransactionHistoryParams{..} txs = fakeOverlay $ do table_ [ class_ @@ -196,8 +164,7 @@ customerHistoryH fake params@TransactionHistoryParams{..} times txs = $ thEnd (Just 7) "Withdrawal" thEnd Nothing "Id" tbody_ - $ mapM_ (toHtml . txSummaryH params times) - $ zip [0 ..] txs + $ mapM_ (toHtml . txSummaryH params) txs where fakeOverlay = if fake then overlayFakeDataH fakeDataBackgroundLink else id diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs index 41e02c02b1c..589820452e0 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs @@ -21,9 +21,6 @@ import Cardano.Wallet.Api.Types import Cardano.Wallet.Deposit.IO ( WalletBootEnv ) -import Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv - ) import Cardano.Wallet.Deposit.REST ( WalletResource ) @@ -127,10 +124,9 @@ import qualified Cardano.Read.Ledger.Block.Block as Read import qualified Data.ByteString.Lazy as BL serveUI - :: forall n x + :: forall n . HasSNetworkId n => Tracer IO String - -> NetworkEnv IO x -> UILayer WalletResource -> WalletBootEnv IO -> FilePath @@ -139,7 +135,7 @@ serveUI -> NetworkLayer IO Read.ConsensusBlock -> BlockchainSource -> Server UI -serveUI tr network ul env dbDir config nid nl bs = +serveUI tr ul env dbDir config nid nl bs = serveTabPage ul config Wallet :<|> serveTabPage ul config About :<|> serveTabPage ul config Network @@ -161,7 +157,7 @@ serveUI tr network ul env dbDir config nid nl bs = :<|> serveGetAddress ul :<|> serveAddressesPage ul :<|> serveNavigation ul - :<|> serveCustomerHistory network ul + :<|> serveCustomerHistory ul serveTabPage :: UILayer s diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Addresses.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Addresses.hs index 072617bc541..4704dc333f3 100644 --- a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Addresses.hs +++ b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Addresses.hs @@ -7,9 +7,6 @@ where import Prelude -import Cardano.Wallet.Deposit.IO.Network.Type - ( NetworkEnv - ) import Cardano.Wallet.Deposit.Pure ( Customer ) @@ -62,16 +59,14 @@ import Servant ) serveCustomerHistory - :: NetworkEnv IO a - -> UILayer WalletResource + :: UILayer WalletResource -> TransactionHistoryParams -> Maybe RequestCookies -> Handler (CookieResponse RawHtml) -serveCustomerHistory network ul params = do +serveCustomerHistory ul params = do withSessionLayer ul $ \layer -> renderSmoothHtml <$> getCustomerHistory - network layer customerHistoryH alertH