Skip to content

Commit

Permalink
Use the new TxHistory values in the addresses page
Browse files Browse the repository at this point in the history
  • Loading branch information
@paolino
paolino committed Oct 28, 2024
1 parent d95aed1 commit 1d4d415
Show file tree
Hide file tree
Showing 6 changed files with 97 additions and 242 deletions.
17 changes: 3 additions & 14 deletions lib/exe/lib/Cardano/Wallet/Application.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
)
Expand Down Expand Up @@ -441,19 +435,17 @@ serveWallet
)
resource
sourceOfNewTip netLayer ui
networkEnv <- liftIO newNetworkEnvMock
let uiService =
startDepositUiServer
ui
networkEnv
databaseDir'
socket
sNetwork
netLayer
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
Expand All @@ -479,7 +471,7 @@ serveWallet
fakeBootEnv
resource
pure (databaseDir', resource)
Just (databaseDir', w, _) ->
Just (databaseDir', w) ->
pure (databaseDir', w)
let depositService =
startDepositServer
Expand Down Expand Up @@ -639,11 +631,10 @@ serveWallet
socket
application
startDepositUiServer
:: forall n x
:: forall n
. ( HasSNetworkId n
)
=> UILayer WalletResource
-> NetworkEnv IO x
-> FilePath
-> Socket
-> SNetworkId n
Expand All @@ -652,7 +643,6 @@ serveWallet
-> IO ()
startDepositUiServer
ui
networkEnv
databaseDir'
socket
_proxy
Expand All @@ -664,7 +654,6 @@ serveWallet
Server.serve api
$ DepositUi.serveUI
(DepositUIApplicationLog >$< applicationTracer)
networkEnv
ui
fakeBootEnv
databaseDir'
Expand Down
1 change: 1 addition & 0 deletions lib/ui/cardano-wallet-ui.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -123,6 +123,7 @@ library
, lens
, lucid
, memory
, monoidal-containers
, mmorph
, mtl
, ntp-client
Expand Down
227 changes: 67 additions & 160 deletions lib/ui/src/Cardano/Wallet/UI/Deposit/Handlers/Addresses/Transactions.hs
View file
Original file line number Diff line number Diff line change
@@ -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 (..)
Expand All @@ -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
Expand All @@ -116,135 +100,58 @@ 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 =
utcTimeByDirection
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
Loading

0 comments on commit 1d4d415

Please sign in to comment.