From 7e32ad66c16417b500036daed61811de07a38971 Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Fri, 10 Aug 2018 13:45:22 +0200 Subject: [PATCH 01/14] [CO-347] Adding stubs to Handler and LegacyHandler This commit adds stubs to legacy and new-wallet, histogram and bar datatypes are accomodated, one-pass many-aggregates functionality is added --- wallet-new/cardano-sl-wallet-new.cabal | 3 + .../Wallet/API/V1/Handlers/Internal.hs | 49 +++++++++++ .../Cardano/Wallet/API/V1/Handlers/Wallets.hs | 13 ++- .../Wallet/API/V1/LegacyHandlers/Wallets.hs | 15 +++- wallet-new/src/Cardano/Wallet/API/V1/Types.hs | 82 +++++++++++++++++++ .../src/Cardano/Wallet/API/V1/Wallets.hs | 3 + wallet-new/src/Cardano/Wallet/Client.hs | 4 + wallet-new/src/Cardano/Wallet/Client/Http.hs | 3 + 8 files changed, 169 insertions(+), 3 deletions(-) create mode 100644 wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index 38baa1770ff..706567ea068 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -42,6 +42,7 @@ library Cardano.Wallet.API.V1.Handlers Cardano.Wallet.API.V1.Handlers.Accounts Cardano.Wallet.API.V1.Handlers.Addresses + Cardano.Wallet.API.V1.Handlers.Internal Cardano.Wallet.API.V1.Handlers.Transactions Cardano.Wallet.API.V1.Handlers.Wallets Cardano.Wallet.API.V1.Info @@ -179,6 +180,7 @@ library , http-types , ixset-typed , json-sop + , foldl , lens , log-warper , memory @@ -195,6 +197,7 @@ library , stm , safecopy , safe-exceptions + , scientific , serokell-util , servant , servant-client diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs new file mode 100644 index 00000000000..0298fd7e954 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs @@ -0,0 +1,49 @@ +module Cardano.Wallet.API.V1.Handlers.Internal + ( computeUtxoStatistics + ) where + + +import Prelude + +import Cardano.Wallet.API.V1.Types + +import qualified Control.Foldl as L +import Data.Map.Strict as MS +import qualified Data.Text as T + +computeUtxoStatistics :: [Integer] -> UtxoStatistics +computeUtxoStatistics xs = L.fold (summarizeUtxoStatistics $ generateBounds Log10) xs + +-- | Using foldl library enable as to capture a number of aggregations in one pass. This thanks to L.Fold being an Applicative +summarizeUtxoStatistics :: [Integer] -> L.Fold Integer UtxoStatistics +summarizeUtxoStatistics bounds = UtxoStatistics + <$> populateBuckets bounds + <*> L.sum + +-- | Buckets boundaries can be constructed in different way +data BoundType = Log10 | Haphazard + +generateBounds :: BoundType -> [Integer] +generateBounds bType = + case bType of + Log10 -> (zipWith (\ten toPower -> ten^toPower :: Integer) (repeat (10::Integer)) [(1::Integer)..16]) ++ [45 * (10^(15::Integer))] + Haphazard -> [10, 100, 1000, 10000] + + +populateBuckets :: [Integer] -> L.Fold Integer [HistogramBar] +populateBuckets bounds = + case bounds of + (x:_) -> L.Fold (addCountInBuckets x) (initalizeMap bounds) (fmap (\pair -> HistogramBarCount (T.pack $ show $ fst pair, snd pair) ) . MS.toList) + _ -> error "populateBuckets has to be powered with nonempty bounds" + where + initalizeMap :: [Integer] -> MS.Map Integer Integer + initalizeMap b = MS.fromList $ zip b (repeat 0) + retrieveProperBound :: (Ord a) => [a] -> a -> a -> a + retrieveProperBound [] _ prev = prev + retrieveProperBound (x:xs) stake _ = + if (stake > x) then + retrieveProperBound xs stake x + else + x + addCountInBuckets :: Integer -> MS.Map Integer Integer -> Integer -> MS.Map Integer Integer + addCountInBuckets firstElem acc entry = MS.adjust (+1) (retrieveProperBound bounds entry firstElem) acc diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs index f5a17e3b6dd..6148b0e6718 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs @@ -4,6 +4,7 @@ import Universum import Cardano.Wallet.API.Request import Cardano.Wallet.API.Response +import Cardano.Wallet.API.V1.Handlers.Internal (computeUtxoStatistics) import Cardano.Wallet.API.V1.Types as V1 import qualified Cardano.Wallet.API.V1.Wallets as Wallets @@ -15,6 +16,10 @@ import qualified Data.IxSet.Typed as IxSet import Servant +import qualified Control.Foldl as L +import Data.Map.Strict as MS +import qualified Data.Text as T + -- | All the @Servant@ handlers for wallet-specific operations. handlers :: PassiveWalletLayer IO -> ServerT Wallets.API Handler handlers pwl = newWallet pwl @@ -23,7 +28,7 @@ handlers pwl = newWallet pwl :<|> deleteWallet pwl :<|> getWallet pwl :<|> updateWallet pwl - + :<|> getUtxoStatistics pwl -- | Creates a new or restores an existing @wallet@ given a 'NewWallet' payload. -- Returns to the client the representation of the created or restored @@ -97,3 +102,9 @@ updateWallet pwl wid walletUpdateRequest = do case res of Left e -> throwM e Right w -> return $ single w + +getUtxoStatistics :: PassiveWalletLayer IO + -> WalletId + -> Handler (WalletResponse UtxoStatistics) +getUtxoStatistics pwl wid = do + return $ single (computeUtxoStatistics [1::Integer,2,3,10,20,30,101,1001,10000]) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs index 7972e24f415..b3e8fe3d260 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs @@ -17,6 +17,7 @@ import qualified Pos.Wallet.Web.State.Storage as V0 import Cardano.Wallet.API.Request import Cardano.Wallet.API.Response import Cardano.Wallet.API.V1.Errors +import Cardano.Wallet.API.V1.Handlers.Internal (computeUtxoStatistics) import Cardano.Wallet.API.V1.Migration import Cardano.Wallet.API.V1.Types as V1 import qualified Cardano.Wallet.API.V1.Wallets as Wallets @@ -32,6 +33,7 @@ import Pos.Wallet.Web.Methods.Logic (MonadWalletLogic, import Pos.Wallet.Web.Tracking.Types (SyncQueue) import Servant + -- | All the @Servant@ handlers for wallet-specific operations. handlers :: HasConfigurations => ServerT Wallets.API MonadV1 @@ -41,7 +43,7 @@ handlers = newWallet :<|> deleteWallet :<|> getWallet :<|> updateWallet - + :<|> getUtxoStatistics -- | Pure function which returns whether or not the underlying node is -- \"synced enough\" to allow wallet creation/restoration. The notion of @@ -115,7 +117,7 @@ listWallets params fops sops = do ws <- V0.askWalletSnapshot currentDepth <- V0.networkChainDifficulty respondWith params fops sops (IxSet.fromList <$> do - (V0.getWalletsWithInfo ws >>= (migrate @_ @[V1.Wallet] . map (\(w, i) -> (w,i,currentDepth))))) + (V0.getWalletsWithInfo ws >>= (migrate @_ @[V1.Wallet] . Universum.map (\(w, i) -> (w,i,currentDepth))))) updatePassword :: ( MonadWalletLogic ctx m @@ -185,3 +187,12 @@ updateWallet wid WalletUpdate{..} = do -- reacquire the snapshot because we did an update ws' <- V0.askWalletSnapshot addWalletInfo ws' updated + +-- | Gets Utxo statistics for a wallet. +-- | Stub, not calling data layer yet. +getUtxoStatistics + :: (MonadWalletLogic ctx m) + => WalletId + -> m (WalletResponse UtxoStatistics) +getUtxoStatistics wid = do + return $ single (computeUtxoStatistics [1::Integer,2,3,10,20,30,101]) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs index d7c05af42f1..f42cdd22939 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs @@ -37,6 +37,8 @@ module Cardano.Wallet.API.V1.Types ( , WalletId (..) , WalletOperation (..) , SpendingPassword + , UtxoStatistics (..) + , HistogramBar (..) -- * Addresses , AddressValidity (..) -- * Accounts @@ -101,7 +103,9 @@ import Data.Aeson.TH as A import Data.Aeson.Types (toJSONKeyText, typeMismatch) import qualified Data.Char as C import Data.Default (Default (def)) +import qualified Data.HashMap.Strict as HMS import qualified Data.IxSet.Typed as IxSet +import Data.Scientific (floatingOrInteger) import Data.Swagger hiding (Example, example) import qualified Data.Swagger as S import Data.Swagger.Declare (Declare, look) @@ -852,6 +856,82 @@ instance BuildableSafeGen Wallet where instance Buildable [Wallet] where build = bprint listJson + + +-------------------------------------------------------------------------------- +-- Utxo statistics +-------------------------------------------------------------------------------- + +-- | Utxo statistics for the wallet. +-- | Histogram is composed of bars that represent the bucket. The bucket is tagged by upper bound of a given bucket. +-- | The bar value corresponds to the number of stakes +-- | In the future the bar value could be different things: +-- | (a) sum of stakes in a bucket +-- | (b) avg or std of stake in a bucket +-- | (c) topN buckets +-- | to name a few +newtype HistogramBar = HistogramBarCount (Text, Integer) deriving (Show, Eq, Ord, Generic) + +instance FromJSON HistogramBar where + parseJSON (Object v) = + case (HMS.size v, HMS.keys v, HMS.elems v) of + (1, [key], [Number val]) -> + case floatingOrInteger val of + Left (_ :: Double) -> empty + Right integer -> return $ HistogramBarCount (key, integer) + _ -> empty + parseJSON _ = empty + +instance ToJSON HistogramBar where + toJSON (HistogramBarCount (bound, stake)) = object [bound .= stake] + +instance ToSchema HistogramBar where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + +instance Arbitrary HistogramBar where + arbitrary = + let possibleBuckets = fmap show $ (zipWith (\ten toPower -> ten^toPower :: Integer) (repeat (10::Integer)) [(1::Integer)..16]) ++ [45 * (10^(15::Integer))] + possibleBars = zipWith (\key value -> HistogramBarCount (key, value)) possibleBuckets [0..] + in elements possibleBars + +deriveSafeBuildable ''HistogramBar +instance BuildableSafeGen HistogramBar where + buildSafeGen _ (HistogramBarCount pair) = + bprint build pair + + +data UtxoStatistics = UtxoStatistics + { theHistogram :: ![HistogramBar] + , theAllStakes :: !Integer + } deriving (Show, Eq, Generic, Ord) + +deriveJSON Serokell.defaultOptions ''UtxoStatistics + +instance ToSchema UtxoStatistics where + declareNamedSchema = + genericSchemaDroppingPrefix "the" (\(--^) props -> props + & ("histogram" --^ "Utxo histogram for a given wallet.") + & ("allStakes" --^ "All Utxo stakes for a given wallet.") + ) + +instance Arbitrary UtxoStatistics where + arbitrary = UtxoStatistics <$> arbitrary + <*> arbitrary + +instance Buildable [HistogramBar] where + build = + bprint listJson + + +deriveSafeBuildable ''UtxoStatistics +instance BuildableSafeGen UtxoStatistics where + buildSafeGen _ UtxoStatistics{..} = bprint ("{" + %" histogram="%build + %" allStakes="%build + %" }") + theHistogram + theAllStakes + -------------------------------------------------------------------------------- -- Addresses -------------------------------------------------------------------------------- @@ -2017,6 +2097,8 @@ instance Example NodeId instance Example ShieldedRedemptionCode instance Example (V1 Core.PassPhrase) instance Example (V1 Core.Coin) +instance Example HistogramBar +instance Example UtxoStatistics -- | We have a specific 'Example' instance for @'V1' 'Address'@ because we want -- to control the length of the examples. It is possible for the encoded length diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/Wallets.hs index 19fa8559524..6b5901a2b13 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Wallets.hs @@ -37,4 +37,7 @@ type API = Tags '["Wallets"] :> :> Summary "Update the Wallet identified by the given walletId." :> ReqBody '[ValidJSON] (Update Wallet) :> Put '[ValidJSON] (WalletResponse Wallet) + :<|> "wallets" :> CaptureWalletId :> "statistics" :> "utxos" + :> Summary "Returns Utxo statistics for the Wallet identified by the given walletId." + :> Get '[ValidJSON] (WalletResponse UtxoStatistics) ) diff --git a/wallet-new/src/Cardano/Wallet/Client.hs b/wallet-new/src/Cardano/Wallet/Client.hs index eaf4b9bd48c..d2a7d46b85d 100644 --- a/wallet-new/src/Cardano/Wallet/Client.hs +++ b/wallet-new/src/Cardano/Wallet/Client.hs @@ -88,6 +88,8 @@ data WalletClient m :: WalletId -> Resp m Wallet , updateWallet :: WalletId -> Update Wallet -> Resp m Wallet + , getUtxoStatistics + :: WalletId -> Resp m UtxoStatistics -- account endpoints , deleteAccount :: WalletId -> AccountIndex -> m (Either ClientError ()) @@ -211,6 +213,8 @@ hoistClient phi wc = WalletClient phi . getWallet wc , updateWallet = \x -> phi . updateWallet wc x + , getUtxoStatistics = + phi . getUtxoStatistics wc , deleteAccount = \x -> phi . deleteAccount wc x , getAccount = diff --git a/wallet-new/src/Cardano/Wallet/Client/Http.hs b/wallet-new/src/Cardano/Wallet/Client/Http.hs index 386a6d8fe26..ca05548a219 100644 --- a/wallet-new/src/Cardano/Wallet/Client/Http.hs +++ b/wallet-new/src/Cardano/Wallet/Client/Http.hs @@ -105,6 +105,8 @@ mkHttpClient baseUrl manager = WalletClient = run . getWalletR , updateWallet = \x -> run . updateWalletR x + , getUtxoStatistics + = run . getUtxoStatisticsR -- account endpoints , deleteAccount = \x -> unNoContent . run . deleteAccountR x @@ -165,6 +167,7 @@ mkHttpClient baseUrl manager = WalletClient :<|> deleteWalletR :<|> getWalletR :<|> updateWalletR + :<|> getUtxoStatisticsR = walletsAPI deleteAccountR From 824b69cbcbd33b0ba97ff90b7f234d8f22536c20 Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Mon, 13 Aug 2018 13:08:41 +0200 Subject: [PATCH 02/14] [CO-347] Adding WalletLayer implementation of getUtxos Kernel level implementation of WalletLayer is added, Legacy is not supported. The implementation is used in Handlers of V1 API. Refactoring from Integer to Word64 is done --- .../Wallet/API/V1/Handlers/Internal.hs | 16 ++++++----- .../Cardano/Wallet/API/V1/Handlers/Wallets.hs | 23 ++++++++++++---- .../Wallet/API/V1/LegacyHandlers/Wallets.hs | 2 +- wallet-new/src/Cardano/Wallet/API/V1/Types.hs | 9 ++++--- .../src/Cardano/Wallet/WalletLayer/Kernel.hs | 5 ++++ .../Wallet/WalletLayer/Kernel/Wallets.hs | 27 ++++++++++++++++--- .../src/Cardano/Wallet/WalletLayer/Legacy.hs | 2 ++ .../src/Cardano/Wallet/WalletLayer/Types.hs | 27 +++++++++++++++++++ 8 files changed, 91 insertions(+), 20 deletions(-) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs index 0298fd7e954..ed73c1198fd 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs @@ -10,12 +10,14 @@ import Cardano.Wallet.API.V1.Types import qualified Control.Foldl as L import Data.Map.Strict as MS import qualified Data.Text as T +import Data.Word -computeUtxoStatistics :: [Integer] -> UtxoStatistics + +computeUtxoStatistics :: [Word64] -> UtxoStatistics computeUtxoStatistics xs = L.fold (summarizeUtxoStatistics $ generateBounds Log10) xs -- | Using foldl library enable as to capture a number of aggregations in one pass. This thanks to L.Fold being an Applicative -summarizeUtxoStatistics :: [Integer] -> L.Fold Integer UtxoStatistics +summarizeUtxoStatistics :: [Word64] -> L.Fold Word64 UtxoStatistics summarizeUtxoStatistics bounds = UtxoStatistics <$> populateBuckets bounds <*> L.sum @@ -23,20 +25,20 @@ summarizeUtxoStatistics bounds = UtxoStatistics -- | Buckets boundaries can be constructed in different way data BoundType = Log10 | Haphazard -generateBounds :: BoundType -> [Integer] +generateBounds :: BoundType -> [Word64] generateBounds bType = case bType of - Log10 -> (zipWith (\ten toPower -> ten^toPower :: Integer) (repeat (10::Integer)) [(1::Integer)..16]) ++ [45 * (10^(15::Integer))] + Log10 -> (zipWith (\ten toPower -> ten^toPower :: Word64) (repeat (10::Word64)) [(1::Word64)..16]) ++ [45 * (10^(15::Word64))] Haphazard -> [10, 100, 1000, 10000] -populateBuckets :: [Integer] -> L.Fold Integer [HistogramBar] +populateBuckets :: [Word64] -> L.Fold Word64 [HistogramBar] populateBuckets bounds = case bounds of (x:_) -> L.Fold (addCountInBuckets x) (initalizeMap bounds) (fmap (\pair -> HistogramBarCount (T.pack $ show $ fst pair, snd pair) ) . MS.toList) _ -> error "populateBuckets has to be powered with nonempty bounds" where - initalizeMap :: [Integer] -> MS.Map Integer Integer + initalizeMap :: [Word64] -> MS.Map Word64 Word64 initalizeMap b = MS.fromList $ zip b (repeat 0) retrieveProperBound :: (Ord a) => [a] -> a -> a -> a retrieveProperBound [] _ prev = prev @@ -45,5 +47,5 @@ populateBuckets bounds = retrieveProperBound xs stake x else x - addCountInBuckets :: Integer -> MS.Map Integer Integer -> Integer -> MS.Map Integer Integer + addCountInBuckets :: Word64 -> MS.Map Word64 Word64 -> Word64 -> MS.Map Word64 Word64 addCountInBuckets firstElem acc entry = MS.adjust (+1) (retrieveProperBound bounds entry firstElem) acc diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs index 6148b0e6718..6ed959e2462 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs @@ -13,13 +13,13 @@ import qualified Cardano.Wallet.WalletLayer.Types as WalletLayer import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as KernelIxSet import qualified Data.IxSet.Typed as IxSet +import Pos.Chain.Txp (Utxo) +import Pos.Core.Common (Coin (..)) +import Pos.Core.Txp (TxOut (..), TxOutAux (..)) +import qualified Data.Map.Strict as M (elems) import Servant -import qualified Control.Foldl as L -import Data.Map.Strict as MS -import qualified Data.Text as T - -- | All the @Servant@ handlers for wallet-specific operations. handlers :: PassiveWalletLayer IO -> ServerT Wallets.API Handler handlers pwl = newWallet pwl @@ -107,4 +107,17 @@ getUtxoStatistics :: PassiveWalletLayer IO -> WalletId -> Handler (WalletResponse UtxoStatistics) getUtxoStatistics pwl wid = do - return $ single (computeUtxoStatistics [1::Integer,2,3,10,20,30,101,1001,10000]) + res <- liftIO $ WalletLayer.getUtxos pwl wid + case res of + Left e -> throwM e + Right w -> + let + extractValue :: TxOutAux -> Word64 + extractValue = getCoin . txOutValue . toaOut + utxosCoinValuesForAllAccounts :: [(Account, Utxo)] -> [Word64] + utxosCoinValuesForAllAccounts pairs = + concat $ map (\pair -> map extractValue (M.elems $ snd pair) ) pairs + in do + return $ single (computeUtxoStatistics $ utxosCoinValuesForAllAccounts w) + + --return $ single (computeUtxoStatistics [1::Integer,2,3,10,20,30,101,1001,10000]) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs index b3e8fe3d260..2c188261927 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs @@ -195,4 +195,4 @@ getUtxoStatistics => WalletId -> m (WalletResponse UtxoStatistics) getUtxoStatistics wid = do - return $ single (computeUtxoStatistics [1::Integer,2,3,10,20,30,101]) + return $ single (computeUtxoStatistics [1::Word64,2,3,10,20,30,101]) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs index f42cdd22939..0b41f961d2d 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs @@ -39,6 +39,7 @@ module Cardano.Wallet.API.V1.Types ( , SpendingPassword , UtxoStatistics (..) , HistogramBar (..) + --, AccountUtxo (..) -- * Addresses , AddressValidity (..) -- * Accounts @@ -144,6 +145,7 @@ import Cardano.Wallet.Util (showApiUtcTime) import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as BS import qualified Data.Map.Strict as Map +--import Pos.Chain.Txp (Utxo) import qualified Pos.Client.Txp.Util as Core import Pos.Core (addressF) import qualified Pos.Core as Core @@ -870,7 +872,7 @@ instance Buildable [Wallet] where -- | (b) avg or std of stake in a bucket -- | (c) topN buckets -- | to name a few -newtype HistogramBar = HistogramBarCount (Text, Integer) deriving (Show, Eq, Ord, Generic) +newtype HistogramBar = HistogramBarCount (Text, Word64) deriving (Show, Eq, Ord, Generic) instance FromJSON HistogramBar where parseJSON (Object v) = @@ -890,7 +892,7 @@ instance ToSchema HistogramBar where instance Arbitrary HistogramBar where arbitrary = - let possibleBuckets = fmap show $ (zipWith (\ten toPower -> ten^toPower :: Integer) (repeat (10::Integer)) [(1::Integer)..16]) ++ [45 * (10^(15::Integer))] + let possibleBuckets = fmap show $ (zipWith (\ten toPower -> ten^toPower :: Word64) (repeat (10::Word64)) [(1::Word64)..16]) ++ [45 * (10^(15::Word64))] possibleBars = zipWith (\key value -> HistogramBarCount (key, value)) possibleBuckets [0..] in elements possibleBars @@ -902,7 +904,7 @@ instance BuildableSafeGen HistogramBar where data UtxoStatistics = UtxoStatistics { theHistogram :: ![HistogramBar] - , theAllStakes :: !Integer + , theAllStakes :: !Word64 } deriving (Show, Eq, Generic, Ord) deriveJSON Serokell.defaultOptions ''UtxoStatistics @@ -2099,6 +2101,7 @@ instance Example (V1 Core.PassPhrase) instance Example (V1 Core.Coin) instance Example HistogramBar instance Example UtxoStatistics +--instance Example AccountUtxo -- | We have a specific 'Example' instance for @'V1' 'Address'@ because we want -- to control the length of the examples. It is possible for the encoded length diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs index 1f3b2d02b24..ba26d984034 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs @@ -102,6 +102,11 @@ bracketPassiveWallet logFunction keystore rocksDB f = , _pwlCreateAddress = Addresses.createAddress wallet , _pwlGetAddresses = error "Not implemented!" + , _pwlGetUtxos = + \walletId -> do + snapshot <- liftIO (Kernel.getWalletSnapshot wallet) + return (Wallets.getWalletUtxos snapshot walletId) + , _pwlApplyBlocks = invokeIO . Actions.ApplyBlocks , _pwlRollbackBlocks = invokeIO . Actions.RollbackBlocks } diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs index a53f9f46aa0..cc4452d2478 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs @@ -5,6 +5,7 @@ module Cardano.Wallet.WalletLayer.Kernel.Wallets ( , deleteWallet , getWallet , getWallets + , getWalletUtxos ) where import Universum @@ -14,6 +15,7 @@ import Data.Coerce (coerce) import Data.Time.Units (Second) import Formatting (build, sformat) +import Pos.Chain.Txp (Utxo) import Pos.Core (decodeTextAddress, mkCoin) import Pos.Crypto.Signing @@ -25,7 +27,7 @@ import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD import Cardano.Wallet.Kernel.DB.HdWallet.Read (readAllHdRoots, readHdRoot) import Cardano.Wallet.Kernel.DB.InDb (InDb (..), fromDb) -import Cardano.Wallet.Kernel.DB.Read (hdWallets) +import Cardano.Wallet.Kernel.DB.Read (accountUtxo, hdWallets) import Cardano.Wallet.Kernel.DB.Util.IxSet (IxSet) import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet import Cardano.Wallet.Kernel.Types (WalletId (..)) @@ -33,9 +35,11 @@ import Cardano.Wallet.Kernel.Util.Core (getCurrentTimestamp) import qualified Cardano.Wallet.Kernel.Wallets as Kernel import Cardano.Wallet.WalletLayer.ExecutionTimeLimit (limitExecutionTimeTo) +import Cardano.Wallet.WalletLayer.Kernel.Accounts (getAccounts) import Cardano.Wallet.WalletLayer.Types (CreateWalletError (..), - DeleteWalletError (..), GetWalletError (..), - UpdateWalletError (..), UpdateWalletPasswordError (..)) + DeleteWalletError (..), GetUtxosError (..), + GetWalletError (..), UpdateWalletError (..), + UpdateWalletPasswordError (..)) createWallet :: MonadIO m => Kernel.PassiveWallet @@ -159,6 +163,22 @@ getWallets db = let allRoots = readAllHdRoots (hdWallets db) in IxSet.fromList . map (toV1Wallet db) . IxSet.toList $ allRoots + +-- | Gets Utxos per account of a wallet. +getWalletUtxos :: Kernel.DB + -> V1.WalletId + -> Either GetUtxosError [(V1.Account, Utxo)] +getWalletUtxos db (V1.WalletId wId) = + case decodeTextAddress wId of + Left _ -> Left (GetWalletUtxosWalletIdDecodingFailed wId) + Right rootAddr -> do + case getAccounts db (V1.WalletId wId) of + Left accountsError -> Left (GetUtxosErrorFromGetAccountsError accountsError) + Right accountsIxSet -> + let hdRootId = HD.HdRootId . InDb $ rootAddr + hdAccountId accountIndex = HD.HdAccountId hdRootId (HD.HdAccountIx accountIndex) + in Right ( map (\acc -> (acc, accountUtxo db (hdAccountId $ V1.accIndex acc) ) ) $ IxSet.toList accountsIxSet ) + {------------------------------------------------------------------------------ General utility functions on the wallets. ------------------------------------------------------------------------------} @@ -196,4 +216,3 @@ toV1Wallet db hdRoot = fromV1AssuranceLevel :: V1.AssuranceLevel -> HD.AssuranceLevel fromV1AssuranceLevel V1.NormalAssurance = HD.AssuranceLevelNormal fromV1AssuranceLevel V1.StrictAssurance = HD.AssuranceLevelStrict - diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Legacy.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Legacy.hs index 576be059aae..0ed125fc421 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Legacy.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Legacy.hs @@ -94,6 +94,8 @@ bracketPassiveWallet = , _pwlCreateAddress = pwlCreateAddress , _pwlGetAddresses = pwlGetAddresses + , _pwlGetUtxos = error "Method not implemented for legacy handler" + , _pwlApplyBlocks = pwlApplyBlocks , _pwlRollbackBlocks = pwlRollbackBlocks } diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Types.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Types.hs index b544955d9ed..c99799df334 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Types.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Types.hs @@ -17,6 +17,7 @@ module Cardano.Wallet.WalletLayer.Types , createAddress , getAddresses + , getUtxos , applyBlocks , rollbackBlocks -- * Errors @@ -34,6 +35,7 @@ module Cardano.Wallet.WalletLayer.Types , GetAccountsError(..) , DeleteAccountError(..) , UpdateAccountError(..) + , GetUtxosError(..) ) where import qualified Prelude @@ -64,6 +66,7 @@ import Cardano.Wallet.Kernel.CoinSelection.FromGeneric (ExpenseRegulation, InputGrouping) import Pos.Chain.Block (Blund) +import Pos.Chain.Txp (Utxo) import Pos.Core (Coin) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Txp (Tx) @@ -120,6 +123,23 @@ instance Buildable GetWalletError where build (GetWalletWalletIdDecodingFailed txt) = bprint ("GetWalletWalletIdDecodingFailed " % build) txt +data GetUtxosError = + GetWalletUtxosWalletIdDecodingFailed Text + | GetUtxosErrorFromGetAccountsError GetAccountsError + deriving Eq + +instance Show GetUtxosError where + show = formatToString build + +instance Exception GetUtxosError + +instance Buildable GetUtxosError where + build (GetUtxosErrorFromGetAccountsError getAccountsError) = + bprint build getAccountsError + build (GetWalletUtxosWalletIdDecodingFailed txt) = + bprint ("GetWalletUtxosWalletIdDecodingFailed " % build) txt + + data UpdateWalletError = UpdateWalletError (V1 Kernel.UnknownHdRoot) | UpdateWalletErrorNotFound WalletId @@ -352,6 +372,8 @@ data PassiveWalletLayer m = PassiveWalletLayer , _pwlCreateAddress :: NewAddress -> m (Either CreateAddressError Address) , _pwlGetAddresses :: WalletId -> m [Address] + -- * utxos + , _pwlGetUtxos :: WalletId -> m (Either GetUtxosError [(Account, Utxo)]) -- * core API , _pwlApplyBlocks :: OldestFirst NE Blund -> m () , _pwlRollbackBlocks :: NewestFirst NE Blund -> m () @@ -430,6 +452,11 @@ createAddress pwl = pwl ^. pwlCreateAddress getAddresses :: forall m. PassiveWalletLayer m -> WalletId -> m [Address] getAddresses pwl = pwl ^. pwlGetAddresses +getUtxos :: forall m. PassiveWalletLayer m + -> WalletId + -> m (Either GetUtxosError [(Account, Utxo)]) +getUtxos pwl = pwl ^. pwlGetUtxos + applyBlocks :: forall m. PassiveWalletLayer m -> OldestFirst NE Blund -> m () applyBlocks pwl = pwl ^. pwlApplyBlocks From 6c48d35fba52f14aee661da14f2be9c708f9b254 Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Wed, 15 Aug 2018 01:01:21 +0200 Subject: [PATCH 03/14] [CO-347] Adding integration tests and other improvements Added integration test for Wallets and Transactions (here commented until migration to Handler happens). Added ToSchema instance needed to pass swagger integration tests. Decided to use [(Account, Utxo)] type in WalletLayer as it can be useful if the method is extended for account parameters. WalletLayers quickcheck required to add several instances as a consequence --- pkgs/default.nix | 6 + wallet-new/cardano-sl-wallet-new.cabal | 1 + wallet-new/integration/TransactionSpecs.hs | 31 ++++ wallet-new/integration/WalletSpecs.hs | 11 ++ .../Wallet/API/V1/Handlers/Internal.hs | 4 +- .../Cardano/Wallet/API/V1/Handlers/Wallets.hs | 4 +- .../Wallet/API/V1/LegacyHandlers/Wallets.hs | 6 +- .../src/Cardano/Wallet/API/V1/Swagger.hs | 56 +++++++- wallet-new/src/Cardano/Wallet/API/V1/Types.hs | 135 +++++++++++++++--- .../Cardano/Wallet/WalletLayer/QuickCheck.hs | 38 ++++- 10 files changed, 253 insertions(+), 39 deletions(-) diff --git a/pkgs/default.nix b/pkgs/default.nix index 56e37aba3b1..33e8652e335 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -17774,8 +17774,10 @@ license = stdenv.lib.licenses.mit; , directory , exceptions , filepath +, foldl , formatting , gauge +, generic-arbitrary , generics-sop , hedgehog , hspec @@ -17803,6 +17805,7 @@ license = stdenv.lib.licenses.mit; , retry , safe-exceptions , safecopy +, scientific , serokell-util , servant , servant-client @@ -17883,6 +17886,7 @@ data-default data-default-class directory exceptions +foldl formatting generics-sop http-api-data @@ -17905,6 +17909,7 @@ resourcet retry safe-exceptions safecopy +scientific serokell-util servant servant-client @@ -17997,6 +18002,7 @@ data-default directory filepath formatting +generic-arbitrary hedgehog hspec ixset-typed diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index 706567ea068..da5e1fd7bd4 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -577,6 +577,7 @@ test-suite wallet-new-specs , formatting , hedgehog , hspec + , generic-arbitrary , lens , QuickCheck , quickcheck-instances diff --git a/wallet-new/integration/TransactionSpecs.hs b/wallet-new/integration/TransactionSpecs.hs index 3e1955d5e71..09fa444ec07 100644 --- a/wallet-new/integration/TransactionSpecs.hs +++ b/wallet-new/integration/TransactionSpecs.hs @@ -187,3 +187,34 @@ transactionSpecs wRef wc = do etxn <- postTransaction wc payment void $ etxn `shouldPrism` _Left +{-- Uncomment when new Client is Handler based rather than LegacyHandler based + it "posted transactions gives rise to nonempty Utxo histogram" $ do + genesis <- genesisWallet wc + (fromAcct, _) <- firstAccountAndId wc genesis + + wallet <- sampleWallet wRef wc + (_, toAddr) <- firstAccountAndId wc wallet + + let payment val = Payment + { pmtSource = PaymentSource + { psWalletId = walId genesis + , psAccountIndex = accIndex fromAcct + } + , pmtDestinations = pure PaymentDistribution + { pdAddress = addrId toAddr + , pdAmount = V1 (Core.mkCoin val) + } + , pmtGroupingPolicy = Nothing + , pmtSpendingPassword = Nothing + } + + void $ postTransaction wc (payment 1) + threadDelay 120000000 + eresp1 <- getUtxoStatistics wc (walId wallet) + utxoStatistics1 <- fmap wrData eresp1 `shouldPrism` _Right + let possibleBuckets = fmap show $ (zipWith (\ten toPower -> ten^toPower :: Word64) (repeat (10::Word64)) [(1::Word64)..16]) ++ [45 * (10^(15::Word64))] + let histogram1 = zipWith (\key value -> HistogramBarCount (key, value)) possibleBuckets ([1::Word64] ++ (repeat 0)) + let allStakes1 = 1 + utxoStatistics1 `shouldBe` UtxoStatistics histogram1 allStakes1 + +--} diff --git a/wallet-new/integration/WalletSpecs.hs b/wallet-new/integration/WalletSpecs.hs index 5d881f88a08..eaab05b29f9 100644 --- a/wallet-new/integration/WalletSpecs.hs +++ b/wallet-new/integration/WalletSpecs.hs @@ -53,6 +53,17 @@ walletSpecs _ wc = do } eresp `shouldPrism_` _Right + + it "creating wallet gives rise to an empty Utxo histogram" $ do + newWallet <- randomWallet CreateWallet + wallet <- createWalletCheck wc newWallet + + eresp <- getUtxoStatistics wc (walId wallet) + utxoStatistics <- fmap wrData eresp `shouldPrism` _Right + let possibleBuckets = fmap show $ ( map (\toPower -> 10^toPower :: Word64) [(1::Word64)..16] ) ++ [45 * (10^(15::Word64))] + let histogram = map (\ x -> curry HistogramBarCount x 0) possibleBuckets + let allStakes = 0 + utxoStatistics `shouldBe` UtxoStatistics histogram allStakes where testWalletAlreadyExists action = do newWallet1 <- randomWallet action diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs index ed73c1198fd..ee6bf402d0d 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs @@ -8,7 +8,7 @@ import Prelude import Cardano.Wallet.API.V1.Types import qualified Control.Foldl as L -import Data.Map.Strict as MS +import qualified Data.Map.Strict as MS import qualified Data.Text as T import Data.Word @@ -28,7 +28,7 @@ data BoundType = Log10 | Haphazard generateBounds :: BoundType -> [Word64] generateBounds bType = case bType of - Log10 -> (zipWith (\ten toPower -> ten^toPower :: Word64) (repeat (10::Word64)) [(1::Word64)..16]) ++ [45 * (10^(15::Word64))] + Log10 -> ( map (\toPower -> 10^toPower :: Word64) [(1::Word64)..16] ) ++ [45 * (10^(15::Word64))] Haphazard -> [10, 100, 1000, 10000] diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs index 6ed959e2462..e89c38696cc 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs @@ -116,8 +116,6 @@ getUtxoStatistics pwl wid = do extractValue = getCoin . txOutValue . toaOut utxosCoinValuesForAllAccounts :: [(Account, Utxo)] -> [Word64] utxosCoinValuesForAllAccounts pairs = - concat $ map (\pair -> map extractValue (M.elems $ snd pair) ) pairs + concatMap (\pair -> map extractValue (M.elems $ snd pair) ) pairs in do return $ single (computeUtxoStatistics $ utxosCoinValuesForAllAccounts w) - - --return $ single (computeUtxoStatistics [1::Integer,2,3,10,20,30,101,1001,10000]) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs index 2c188261927..663647ca355 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs @@ -189,10 +189,10 @@ updateWallet wid WalletUpdate{..} = do addWalletInfo ws' updated -- | Gets Utxo statistics for a wallet. --- | Stub, not calling data layer yet. +-- | Stub, not calling data layer. getUtxoStatistics :: (MonadWalletLogic ctx m) => WalletId -> m (WalletResponse UtxoStatistics) -getUtxoStatistics wid = do - return $ single (computeUtxoStatistics [1::Word64,2,3,10,20,30,101]) +getUtxoStatistics _ = do + return $ single (computeUtxoStatistics []) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs b/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs index c61ca68fe56..56392895b81 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs @@ -47,7 +47,8 @@ import Servant (Handler, QueryFlag, ServantErr (..), Server) import Servant.API.Sub import Servant.Swagger import Servant.Swagger.UI (SwaggerSchemaUI') -import Servant.Swagger.UI.ReDoc (redocSchemaUIServer) +import Servant.Swagger.UI.Core (swaggerSchemaUIServerImpl) +import Servant.Swagger.UI.ReDoc (redocFiles) import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Random @@ -733,8 +734,8 @@ curl -X POST \ --cacert ./scripts/tls-files/ca.crt \ --cert ./scripts/tls-files/client.pem \ -d '{ - "walletId": "Ae2tdPwUPE...V3AVTnqGZ4", - "accountIndex": 2147483648 + "walletId": "Ae2tdPwUPE...V3AVTnqGZ4", + "accountIndex": 2147483648 }' ``` @@ -829,6 +830,24 @@ curl -X GET 'https://127.0.0.1:8090/api/v1/transactions?wallet_id=Ae2tdPwU...3AV --cert ./scripts/tls-files/client.pem ``` + +Getting Utxo statistics +--------------------------------- + +You can get Utxo statistics of a given wallet using + [`GET /api/v1/wallets/{{walletId}}/statistics/utxos`](#tag/Accounts%2Fpaths%2F~1api~1v1~1wallets~1{walletId}~1statistics~1utxos%2Fget) +``` +curl -X GET \ + https://127.0.0.1:8090/api/v1/wallets/Ae2tdPwUPE...8V3AVTnqGZ/statistics/utxos \ + -H 'Accept: application/json;charset=utf-8' \ + --cacert ./scripts/tls-files/ca.crt \ + --cert ./scripts/tls-files/client.pem +``` + +```json +$readUtxoStatistics +``` + Make sure to carefully read the section about [Pagination](#section/Pagination) to fully leverage the API capabilities. |] @@ -843,13 +862,40 @@ leverage the API capabilities. readFees = decodeUtf8 $ encodePretty $ genExample @(WalletResponse EstimatedFees) readNodeInfo = decodeUtf8 $ encodePretty $ genExample @(WalletResponse NodeInfo) readTransactions = decodeUtf8 $ encodePretty $ genExample @(WalletResponse [Transaction]) - + readUtxoStatistics = decodeUtf8 $ encodePretty $ genExample @(WalletResponse UtxoStatistics) -- | Provide an alternative UI (ReDoc) for rendering Swagger documentation. swaggerSchemaUIServer :: (Server api ~ Handler Swagger) => Swagger -> Server (SwaggerSchemaUI' dir api) -swaggerSchemaUIServer = redocSchemaUIServer +swaggerSchemaUIServer = + swaggerSchemaUIServerImpl redocIndexTemplate redocFiles + where + redocIndexTemplate :: Text + redocIndexTemplate = [text| + + + + ReDoc + + + + + + + + + +|] -- -- The API diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs index 0b41f961d2d..a030ea46fc8 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs @@ -145,7 +145,6 @@ import Cardano.Wallet.Util (showApiUtcTime) import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as BS import qualified Data.Map.Strict as Map ---import Pos.Chain.Txp (Utxo) import qualified Pos.Client.Txp.Util as Core import Pos.Core (addressF) import qualified Pos.Core as Core @@ -874,26 +873,13 @@ instance Buildable [Wallet] where -- | to name a few newtype HistogramBar = HistogramBarCount (Text, Word64) deriving (Show, Eq, Ord, Generic) -instance FromJSON HistogramBar where - parseJSON (Object v) = - case (HMS.size v, HMS.keys v, HMS.elems v) of - (1, [key], [Number val]) -> - case floatingOrInteger val of - Left (_ :: Double) -> empty - Right integer -> return $ HistogramBarCount (key, integer) - _ -> empty - parseJSON _ = empty - -instance ToJSON HistogramBar where - toJSON (HistogramBarCount (bound, stake)) = object [bound .= stake] - instance ToSchema HistogramBar where declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions instance Arbitrary HistogramBar where arbitrary = let possibleBuckets = fmap show $ (zipWith (\ten toPower -> ten^toPower :: Word64) (repeat (10::Word64)) [(1::Word64)..16]) ++ [45 * (10^(15::Word64))] - possibleBars = zipWith (\key value -> HistogramBarCount (key, value)) possibleBuckets [0..] + possibleBars = zipWith (curry HistogramBarCount) possibleBuckets [0..] in elements possibleBars deriveSafeBuildable ''HistogramBar @@ -905,16 +891,121 @@ instance BuildableSafeGen HistogramBar where data UtxoStatistics = UtxoStatistics { theHistogram :: ![HistogramBar] , theAllStakes :: !Word64 - } deriving (Show, Eq, Generic, Ord) + } deriving (Show, Generic, Ord) + +toMap :: [HistogramBar] -> Map Text Word64 +toMap = Map.fromList . map (\(HistogramBarCount (key, val)) -> (key,val)) + +instance Eq UtxoStatistics where + (UtxoStatistics h s) == (UtxoStatistics h' s') = s == s' && toMap h == toMap h' -deriveJSON Serokell.defaultOptions ''UtxoStatistics +instance ToJSON UtxoStatistics where + toJSON (UtxoStatistics bars allStakes) = + let histogramObject = Object . HMS.fromList . map extractBarKey + extractBarKey (HistogramBarCount (bound, stake)) = bound .= stake + in object [ "histogram" .= histogramObject bars + , "allStakes" .= allStakes ] + +instance FromJSON UtxoStatistics where + parseJSON (Object v) = + let histogramListM = case HMS.lookup "histogram" v of + Nothing -> empty + Just (Object bars) -> do + let constructHistogram (key, Number val) = + case floatingOrInteger val of + Left (_ :: Double) -> HistogramBarCount ("0", 0 :: Word64) + Right integer -> HistogramBarCount (key, integer) + constructHistogram _ = HistogramBarCount ("0", 0 :: Word64) + return $ map constructHistogram $ HMS.toList bars + Just _ -> empty + in UtxoStatistics <$> histogramListM + <*> v .: "allStakes" + parseJSON _ = empty instance ToSchema UtxoStatistics where - declareNamedSchema = - genericSchemaDroppingPrefix "the" (\(--^) props -> props - & ("histogram" --^ "Utxo histogram for a given wallet.") - & ("allStakes" --^ "All Utxo stakes for a given wallet.") - ) + declareNamedSchema _ = + pure $ NamedSchema (Just "UtxoStatistics") $ mempty + & type_ .~ SwaggerObject + & required .~ ["histogram", "allStakes"] + & properties .~ (mempty + & at "histogram" ?~ Inline (mempty + & type_ .~ SwaggerObject + & properties .~ (mempty + & at "10" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "100" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "1000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "10000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "100000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "1000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "10000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "100000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "1000000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "10000000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "100000000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "1000000000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "10000000000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "100000000000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "1000000000000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "10000000000000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + & at "45000000000000000" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + ) + ) + & at "allStakes" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + ) instance Arbitrary UtxoStatistics where arbitrary = UtxoStatistics <$> arbitrary diff --git a/wallet-new/test/Cardano/Wallet/WalletLayer/QuickCheck.hs b/wallet-new/test/Cardano/Wallet/WalletLayer/QuickCheck.hs index 77156990c30..a58865bcf58 100644 --- a/wallet-new/test/Cardano/Wallet/WalletLayer/QuickCheck.hs +++ b/wallet-new/test/Cardano/Wallet/WalletLayer/QuickCheck.hs @@ -13,15 +13,19 @@ import Cardano.Wallet.Orphans.Arbitrary () import Cardano.Wallet.WalletLayer.Types (ActiveWalletLayer (..), CreateAccountError (..), DeleteAccountError (..), DeleteWalletError (..), GetAccountError (..), - GetAccountsError (..), GetWalletError (..), - PassiveWalletLayer (..), UpdateAccountError (..), - UpdateWalletError (..), UpdateWalletPasswordError (..)) + GetAccountsError (..), GetUtxosError (..), + GetWalletError (..), PassiveWalletLayer (..), + UpdateAccountError (..), UpdateWalletError (..), + UpdateWalletPasswordError (..)) import Cardano.Wallet.API.V1.Types (V1 (..)) import qualified Cardano.Wallet.Kernel.Accounts as Kernel +import Pos.Core.Txp (TxIn (..), TxOut, TxOutAux) import Pos.Core () -import Test.QuickCheck (Arbitrary, arbitrary, generate, oneof) +import Test.QuickCheck (Arbitrary (..), Gen, arbitrary, choose, + generate, genericShrink, oneof, scale) +import Test.QuickCheck.Arbitrary.Generic (genericArbitrary) -- | Initialize the passive wallet. -- The passive wallet cannot send new transactions. @@ -51,6 +55,8 @@ bracketPassiveWallet = , _pwlCreateAddress = \_ -> liftedGen , _pwlGetAddresses = \_ -> liftedGen + , _pwlGetUtxos = \_ -> liftedGen + , _pwlApplyBlocks = \_ -> liftedGen , _pwlRollbackBlocks = \_ -> liftedGen } @@ -132,3 +138,27 @@ instance Arbitrary DeleteWalletError where instance Arbitrary UpdateWalletError where arbitrary = oneof [ UpdateWalletWalletIdDecodingFailed <$> arbitrary ] + + +instance Arbitrary GetUtxosError where + arbitrary = oneof [ GetWalletUtxosWalletIdDecodingFailed <$> arbitrary + , GetUtxosErrorFromGetAccountsError <$> arbitrary + ] + +genTxIn :: Gen TxIn +genTxIn = oneof + [ TxInUtxo <$> arbitrary <*> arbitrary + , TxInUnknown <$> choose (1, 255) <*> scale (min 150) arbitrary + ] + +instance Arbitrary TxIn where + arbitrary = genTxIn + shrink = genericShrink + +instance Arbitrary TxOutAux where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary TxOut where + arbitrary = genericArbitrary + shrink = genericShrink From 6d31f9f77ed957438c57b60de5f1d9218e69f785 Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Fri, 17 Aug 2018 15:25:38 +0200 Subject: [PATCH 04/14] [CO-347] Review improvements --- wallet-new/cardano-sl-wallet-new.cabal | 2 +- wallet-new/integration/TransactionSpecs.hs | 26 ++- wallet-new/integration/WalletSpecs.hs | 7 +- .../Wallet/API/V1/Handlers/Internal.hs | 51 ----- .../Cardano/Wallet/API/V1/Handlers/Wallets.hs | 18 +- .../Wallet/API/V1/LegacyHandlers/Wallets.hs | 5 +- .../src/Cardano/Wallet/API/V1/Swagger.hs | 32 +-- wallet-new/src/Cardano/Wallet/API/V1/Types.hs | 179 +--------------- .../Cardano/Wallet/Types/UtxoStatistics.hs | 191 ++++++++++++++++++ .../Wallet/WalletLayer/Kernel/Wallets.hs | 1 + .../Cardano/Wallet/WalletLayer/QuickCheck.hs | 15 +- 11 files changed, 235 insertions(+), 292 deletions(-) delete mode 100644 wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs create mode 100644 wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index da5e1fd7bd4..084d5dbbb14 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -42,7 +42,6 @@ library Cardano.Wallet.API.V1.Handlers Cardano.Wallet.API.V1.Handlers.Accounts Cardano.Wallet.API.V1.Handlers.Addresses - Cardano.Wallet.API.V1.Handlers.Internal Cardano.Wallet.API.V1.Handlers.Transactions Cardano.Wallet.API.V1.Handlers.Wallets Cardano.Wallet.API.V1.Info @@ -119,6 +118,7 @@ library Cardano.Wallet.Server.CLI Cardano.Wallet.Server.Plugins Cardano.Wallet.TypeLits + Cardano.Wallet.Types.UtxoStatistics Cardano.Wallet.Client Cardano.Wallet.Client.Http diff --git a/wallet-new/integration/TransactionSpecs.hs b/wallet-new/integration/TransactionSpecs.hs index 09fa444ec07..c2f49063746 100644 --- a/wallet-new/integration/TransactionSpecs.hs +++ b/wallet-new/integration/TransactionSpecs.hs @@ -8,6 +8,7 @@ import Universum import Cardano.Wallet.API.V1.Errors hiding (describe) import Cardano.Wallet.Client.Http import Control.Lens +import qualified Data.List.NonEmpty as NL import qualified Pos.Core as Core import Test.Hspec @@ -187,8 +188,8 @@ transactionSpecs wRef wc = do etxn <- postTransaction wc payment void $ etxn `shouldPrism` _Left -{-- Uncomment when new Client is Handler based rather than LegacyHandler based - it "posted transactions gives rise to nonempty Utxo histogram" $ do + + xit "posted transactions gives rise to nonempty Utxo histogram" $ do genesis <- genesisWallet wc (fromAcct, _) <- firstAccountAndId wc genesis @@ -208,13 +209,18 @@ transactionSpecs wRef wc = do , pmtSpendingPassword = Nothing } + let possibleBuckets = fmap show $ (generateBounds Log10) + + eresp0 <- getUtxoStatistics wc (walId wallet) + utxoStatistics0 <- fmap wrData eresp0 `shouldPrism` _Right + let histogram0 = NL.zipWith HistogramBarCount possibleBuckets (NL.repeat 0) + let allStakes0 = 0 + utxoStatistics0 `shouldBe` UtxoStatistics (NL.toList histogram0) allStakes0 + void $ postTransaction wc (payment 1) threadDelay 120000000 - eresp1 <- getUtxoStatistics wc (walId wallet) - utxoStatistics1 <- fmap wrData eresp1 `shouldPrism` _Right - let possibleBuckets = fmap show $ (zipWith (\ten toPower -> ten^toPower :: Word64) (repeat (10::Word64)) [(1::Word64)..16]) ++ [45 * (10^(15::Word64))] - let histogram1 = zipWith (\key value -> HistogramBarCount (key, value)) possibleBuckets ([1::Word64] ++ (repeat 0)) - let allStakes1 = 1 - utxoStatistics1 `shouldBe` UtxoStatistics histogram1 allStakes1 - ---} + eresp <- getUtxoStatistics wc (walId wallet) + utxoStatistics <- fmap wrData eresp `shouldPrism` _Right + let histogram = NL.zipWith HistogramBarCount possibleBuckets (NL.cons (1::Word64) (NL.repeat 0) ) + let allStakes = 1 + utxoStatistics `shouldBe` UtxoStatistics (NL.toList histogram) allStakes diff --git a/wallet-new/integration/WalletSpecs.hs b/wallet-new/integration/WalletSpecs.hs index eaab05b29f9..c8c42a7451b 100644 --- a/wallet-new/integration/WalletSpecs.hs +++ b/wallet-new/integration/WalletSpecs.hs @@ -9,6 +9,7 @@ import Cardano.Wallet.API.V1.Errors (WalletError (WalletAlreadyExists)) import Cardano.Wallet.Client.Http import Control.Lens +import qualified Data.List.NonEmpty as NL import Test.Hspec import Util @@ -60,10 +61,10 @@ walletSpecs _ wc = do eresp <- getUtxoStatistics wc (walId wallet) utxoStatistics <- fmap wrData eresp `shouldPrism` _Right - let possibleBuckets = fmap show $ ( map (\toPower -> 10^toPower :: Word64) [(1::Word64)..16] ) ++ [45 * (10^(15::Word64))] - let histogram = map (\ x -> curry HistogramBarCount x 0) possibleBuckets + let possibleBuckets = fmap show $ (generateBounds Log10) + let histogram = map (\x -> HistogramBarCount x 0) possibleBuckets let allStakes = 0 - utxoStatistics `shouldBe` UtxoStatistics histogram allStakes + utxoStatistics `shouldBe` UtxoStatistics (NL.toList histogram) allStakes where testWalletAlreadyExists action = do newWallet1 <- randomWallet action diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs deleted file mode 100644 index ee6bf402d0d..00000000000 --- a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Internal.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Cardano.Wallet.API.V1.Handlers.Internal - ( computeUtxoStatistics - ) where - - -import Prelude - -import Cardano.Wallet.API.V1.Types - -import qualified Control.Foldl as L -import qualified Data.Map.Strict as MS -import qualified Data.Text as T -import Data.Word - - -computeUtxoStatistics :: [Word64] -> UtxoStatistics -computeUtxoStatistics xs = L.fold (summarizeUtxoStatistics $ generateBounds Log10) xs - --- | Using foldl library enable as to capture a number of aggregations in one pass. This thanks to L.Fold being an Applicative -summarizeUtxoStatistics :: [Word64] -> L.Fold Word64 UtxoStatistics -summarizeUtxoStatistics bounds = UtxoStatistics - <$> populateBuckets bounds - <*> L.sum - --- | Buckets boundaries can be constructed in different way -data BoundType = Log10 | Haphazard - -generateBounds :: BoundType -> [Word64] -generateBounds bType = - case bType of - Log10 -> ( map (\toPower -> 10^toPower :: Word64) [(1::Word64)..16] ) ++ [45 * (10^(15::Word64))] - Haphazard -> [10, 100, 1000, 10000] - - -populateBuckets :: [Word64] -> L.Fold Word64 [HistogramBar] -populateBuckets bounds = - case bounds of - (x:_) -> L.Fold (addCountInBuckets x) (initalizeMap bounds) (fmap (\pair -> HistogramBarCount (T.pack $ show $ fst pair, snd pair) ) . MS.toList) - _ -> error "populateBuckets has to be powered with nonempty bounds" - where - initalizeMap :: [Word64] -> MS.Map Word64 Word64 - initalizeMap b = MS.fromList $ zip b (repeat 0) - retrieveProperBound :: (Ord a) => [a] -> a -> a -> a - retrieveProperBound [] _ prev = prev - retrieveProperBound (x:xs) stake _ = - if (stake > x) then - retrieveProperBound xs stake x - else - x - addCountInBuckets :: Word64 -> MS.Map Word64 Word64 -> Word64 -> MS.Map Word64 Word64 - addCountInBuckets firstElem acc entry = MS.adjust (+1) (retrieveProperBound bounds entry firstElem) acc diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs index e89c38696cc..177ec3abd82 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs @@ -4,7 +4,6 @@ import Universum import Cardano.Wallet.API.Request import Cardano.Wallet.API.Response -import Cardano.Wallet.API.V1.Handlers.Internal (computeUtxoStatistics) import Cardano.Wallet.API.V1.Types as V1 import qualified Cardano.Wallet.API.V1.Wallets as Wallets @@ -103,19 +102,18 @@ updateWallet pwl wid walletUpdateRequest = do Left e -> throwM e Right w -> return $ single w -getUtxoStatistics :: PassiveWalletLayer IO - -> WalletId - -> Handler (WalletResponse UtxoStatistics) +getUtxoStatistics + :: PassiveWalletLayer IO + -> WalletId + -> Handler (WalletResponse UtxoStatistics) getUtxoStatistics pwl wid = do res <- liftIO $ WalletLayer.getUtxos pwl wid case res of Left e -> throwM e - Right w -> - let - extractValue :: TxOutAux -> Word64 + Right w -> do + let extractValue :: TxOutAux -> Word64 extractValue = getCoin . txOutValue . toaOut - utxosCoinValuesForAllAccounts :: [(Account, Utxo)] -> [Word64] + let utxosCoinValuesForAllAccounts :: [(Account, Utxo)] -> [Word64] utxosCoinValuesForAllAccounts pairs = concatMap (\pair -> map extractValue (M.elems $ snd pair) ) pairs - in do - return $ single (computeUtxoStatistics $ utxosCoinValuesForAllAccounts w) + return $ single (V1.computeUtxoStatistics $ utxosCoinValuesForAllAccounts w) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs index 663647ca355..060a151bd8d 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs @@ -17,7 +17,6 @@ import qualified Pos.Wallet.Web.State.Storage as V0 import Cardano.Wallet.API.Request import Cardano.Wallet.API.Response import Cardano.Wallet.API.V1.Errors -import Cardano.Wallet.API.V1.Handlers.Internal (computeUtxoStatistics) import Cardano.Wallet.API.V1.Migration import Cardano.Wallet.API.V1.Types as V1 import qualified Cardano.Wallet.API.V1.Wallets as Wallets @@ -117,7 +116,7 @@ listWallets params fops sops = do ws <- V0.askWalletSnapshot currentDepth <- V0.networkChainDifficulty respondWith params fops sops (IxSet.fromList <$> do - (V0.getWalletsWithInfo ws >>= (migrate @_ @[V1.Wallet] . Universum.map (\(w, i) -> (w,i,currentDepth))))) + (V0.getWalletsWithInfo ws >>= (migrate @_ @[V1.Wallet] . map (\(w, i) -> (w,i,currentDepth))))) updatePassword :: ( MonadWalletLogic ctx m @@ -195,4 +194,4 @@ getUtxoStatistics => WalletId -> m (WalletResponse UtxoStatistics) getUtxoStatistics _ = do - return $ single (computeUtxoStatistics []) + return $ single (V1.computeUtxoStatistics []) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs b/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs index 56392895b81..33347f9809b 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Swagger.hs @@ -47,8 +47,7 @@ import Servant (Handler, QueryFlag, ServantErr (..), Server) import Servant.API.Sub import Servant.Swagger import Servant.Swagger.UI (SwaggerSchemaUI') -import Servant.Swagger.UI.Core (swaggerSchemaUIServerImpl) -import Servant.Swagger.UI.ReDoc (redocFiles) +import Servant.Swagger.UI.ReDoc (redocSchemaUIServer) import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Random @@ -868,34 +867,7 @@ leverage the API capabilities. swaggerSchemaUIServer :: (Server api ~ Handler Swagger) => Swagger -> Server (SwaggerSchemaUI' dir api) -swaggerSchemaUIServer = - swaggerSchemaUIServerImpl redocIndexTemplate redocFiles - where - redocIndexTemplate :: Text - redocIndexTemplate = [text| - - - - ReDoc - - - - - - - - - -|] +swaggerSchemaUIServer = redocSchemaUIServer -- -- The API diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs index a030ea46fc8..4dba860b2f6 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs @@ -37,9 +37,6 @@ module Cardano.Wallet.API.V1.Types ( , WalletId (..) , WalletOperation (..) , SpendingPassword - , UtxoStatistics (..) - , HistogramBar (..) - --, AccountUtxo (..) -- * Addresses , AddressValidity (..) -- * Accounts @@ -90,6 +87,9 @@ module Cardano.Wallet.API.V1.Types ( , CaptureAccountId -- * Core re-exports , Core.Address + + , module Cardano.Wallet.Types.UtxoStatistics + ) where import Universum @@ -104,9 +104,7 @@ import Data.Aeson.TH as A import Data.Aeson.Types (toJSONKeyText, typeMismatch) import qualified Data.Char as C import Data.Default (Default (def)) -import qualified Data.HashMap.Strict as HMS import qualified Data.IxSet.Typed as IxSet -import Data.Scientific (floatingOrInteger) import Data.Swagger hiding (Example, example) import qualified Data.Swagger as S import Data.Swagger.Declare (Declare, look) @@ -134,6 +132,7 @@ import Cardano.Wallet.API.Types.UnitOfMeasure (MeasuredIn (..), import Cardano.Wallet.Kernel.DB.Util.IxSet (HasPrimKey (..), IndicesOf, OrdByPrimKey, ixFun, ixList) import Cardano.Wallet.Orphans.Aeson () +import Cardano.Wallet.Types.UtxoStatistics -- V0 logic import Pos.Util.Mnemonic (Mnemonic) @@ -858,173 +857,6 @@ instance Buildable [Wallet] where build = bprint listJson - --------------------------------------------------------------------------------- --- Utxo statistics --------------------------------------------------------------------------------- - --- | Utxo statistics for the wallet. --- | Histogram is composed of bars that represent the bucket. The bucket is tagged by upper bound of a given bucket. --- | The bar value corresponds to the number of stakes --- | In the future the bar value could be different things: --- | (a) sum of stakes in a bucket --- | (b) avg or std of stake in a bucket --- | (c) topN buckets --- | to name a few -newtype HistogramBar = HistogramBarCount (Text, Word64) deriving (Show, Eq, Ord, Generic) - -instance ToSchema HistogramBar where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - -instance Arbitrary HistogramBar where - arbitrary = - let possibleBuckets = fmap show $ (zipWith (\ten toPower -> ten^toPower :: Word64) (repeat (10::Word64)) [(1::Word64)..16]) ++ [45 * (10^(15::Word64))] - possibleBars = zipWith (curry HistogramBarCount) possibleBuckets [0..] - in elements possibleBars - -deriveSafeBuildable ''HistogramBar -instance BuildableSafeGen HistogramBar where - buildSafeGen _ (HistogramBarCount pair) = - bprint build pair - - -data UtxoStatistics = UtxoStatistics - { theHistogram :: ![HistogramBar] - , theAllStakes :: !Word64 - } deriving (Show, Generic, Ord) - -toMap :: [HistogramBar] -> Map Text Word64 -toMap = Map.fromList . map (\(HistogramBarCount (key, val)) -> (key,val)) - -instance Eq UtxoStatistics where - (UtxoStatistics h s) == (UtxoStatistics h' s') = s == s' && toMap h == toMap h' - -instance ToJSON UtxoStatistics where - toJSON (UtxoStatistics bars allStakes) = - let histogramObject = Object . HMS.fromList . map extractBarKey - extractBarKey (HistogramBarCount (bound, stake)) = bound .= stake - in object [ "histogram" .= histogramObject bars - , "allStakes" .= allStakes ] - -instance FromJSON UtxoStatistics where - parseJSON (Object v) = - let histogramListM = case HMS.lookup "histogram" v of - Nothing -> empty - Just (Object bars) -> do - let constructHistogram (key, Number val) = - case floatingOrInteger val of - Left (_ :: Double) -> HistogramBarCount ("0", 0 :: Word64) - Right integer -> HistogramBarCount (key, integer) - constructHistogram _ = HistogramBarCount ("0", 0 :: Word64) - return $ map constructHistogram $ HMS.toList bars - Just _ -> empty - in UtxoStatistics <$> histogramListM - <*> v .: "allStakes" - parseJSON _ = empty - -instance ToSchema UtxoStatistics where - declareNamedSchema _ = - pure $ NamedSchema (Just "UtxoStatistics") $ mempty - & type_ .~ SwaggerObject - & required .~ ["histogram", "allStakes"] - & properties .~ (mempty - & at "histogram" ?~ Inline (mempty - & type_ .~ SwaggerObject - & properties .~ (mempty - & at "10" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "100" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "1000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "10000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "100000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "1000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "10000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "100000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "1000000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "10000000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "100000000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "1000000000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "10000000000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "100000000000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "1000000000000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "10000000000000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - & at "45000000000000000" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - ) - ) - & at "allStakes" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) - ) - -instance Arbitrary UtxoStatistics where - arbitrary = UtxoStatistics <$> arbitrary - <*> arbitrary - -instance Buildable [HistogramBar] where - build = - bprint listJson - - -deriveSafeBuildable ''UtxoStatistics -instance BuildableSafeGen UtxoStatistics where - buildSafeGen _ UtxoStatistics{..} = bprint ("{" - %" histogram="%build - %" allStakes="%build - %" }") - theHistogram - theAllStakes - -------------------------------------------------------------------------------- -- Addresses -------------------------------------------------------------------------------- @@ -2190,9 +2022,6 @@ instance Example NodeId instance Example ShieldedRedemptionCode instance Example (V1 Core.PassPhrase) instance Example (V1 Core.Coin) -instance Example HistogramBar -instance Example UtxoStatistics ---instance Example AccountUtxo -- | We have a specific 'Example' instance for @'V1' 'Address'@ because we want -- to control the length of the examples. It is possible for the encoded length diff --git a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs new file mode 100644 index 00000000000..23f5b71ecad --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Cardano.Wallet.Types.UtxoStatistics + ( computeUtxoStatistics + , UtxoStatistics (..) + , HistogramBar (..) + , BoundType (..) + , generateBounds + ) where + + +import Universum + +import qualified Control.Foldl as L +import Control.Lens (at, (?~)) +import Data.Aeson +import qualified Data.HashMap.Strict as HMS +import qualified Data.List.NonEmpty as NL +import qualified Data.Map.Strict as Map +import Data.Scientific (floatingOrInteger) +import Data.Swagger hiding (Example, example) +import qualified Data.Text as T +import Data.Word (Word64) +import Formatting (bprint, build, (%)) +import qualified Formatting.Buildable +import Serokell.Util (listJson) +import Test.QuickCheck + +import Cardano.Wallet.API.V1.Swagger.Example (Example) +import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), + deriveSafeBuildable) + + +-- Utxo statistics for the wallet. +-- Histogram is composed of bars that represent the bucket. The bucket is tagged by upper bound of a given bucket. +-- The bar value corresponds to the number of stakes +-- In the future the bar value could be different things: +-- (a) sum of stakes in a bucket +-- (b) avg or std of stake in a bucket +-- (c) topN buckets +-- to name a few +data HistogramBar = HistogramBarCount + { bucketName :: !Text + , bucketUpperBound :: !Word64 + } deriving (Show, Eq, Ord, Generic) + +-- Buckets boundaries can be constructed in different way +data BoundType = Log10 | Haphazard + +generateBounds :: BoundType -> NonEmpty Word64 +generateBounds bType = + let (^!) :: Word64 -> Word64 -> Word64 + (^!) = (^) + in case bType of + Log10 -> NL.fromList $ ( map (\toPower -> 10 ^! toPower) [1..16] ) ++ [45 * (10 ^! 15)] + Haphazard -> NL.fromList [10, 100, 1000, 10000] + +instance Arbitrary HistogramBar where + arbitrary = + let possibleBuckets = fmap show (generateBounds Log10) + possibleBars = NL.zipWith HistogramBarCount possibleBuckets (NL.fromList [0..]) + in elements (NL.toList possibleBars) + + +deriveSafeBuildable ''HistogramBar +instance BuildableSafeGen HistogramBar where + buildSafeGen _ HistogramBarCount{..} = + bprint ("{" + %" name="%build + %" upperBound="%build + %" }") + bucketName + bucketUpperBound + + +data UtxoStatistics = UtxoStatistics + { theHistogram :: ![HistogramBar] + , theAllStakes :: !Word64 + } deriving (Show, Generic, Ord) + +toMap :: [HistogramBar] -> Map Text Word64 +toMap = Map.fromList . map (\(HistogramBarCount key val) -> (key,val)) + +instance Eq UtxoStatistics where + (UtxoStatistics h s) == (UtxoStatistics h' s') = s == s' && toMap h == toMap h' + +instance ToJSON UtxoStatistics where + toJSON (UtxoStatistics bars allStakes) = + let histogramObject = Object . HMS.fromList . map extractBarKey + extractBarKey (HistogramBarCount bound stake) = bound .= stake + in object [ "histogram" .= histogramObject bars + , "allStakes" .= allStakes ] + +instance FromJSON UtxoStatistics where + parseJSON (Object v) = + let histogramListM = case HMS.lookup "histogram" v of + Nothing -> empty + Just (Object bars) -> do + let constructHistogram (key, Number val) = + case floatingOrInteger val of + Left (_ :: Double) -> error "UtxoStatistics FromJson not integer" + Right integer -> if integer >= 0 then + HistogramBarCount key integer + else + error "UtxoStatistics FromJson not positive integer" + constructHistogram _ = error "UtxoStatistics FromJson" + return $ map constructHistogram $ HMS.toList bars + Just _ -> empty + in UtxoStatistics <$> histogramListM + <*> v .: "allStakes" + parseJSON _ = empty + +instance ToSchema UtxoStatistics where + declareNamedSchema _ = do + wordRef <- declareSchemaRef (Proxy :: Proxy Word64) + pure $ NamedSchema (Just "UtxoStatistics") $ mempty + & type_ .~ SwaggerObject + & required .~ ["histogram", "allStakes"] + & properties .~ (mempty + & at "histogram" ?~ Inline (mempty + & type_ .~ SwaggerObject + & properties .~ (mempty + & at "10" ?~ wordRef + & at "100" ?~ wordRef + & at "1000" ?~ wordRef + & at "10000" ?~ wordRef + & at "100000" ?~ wordRef + & at "1000000" ?~ wordRef + & at "10000000" ?~ wordRef + & at "100000000" ?~ wordRef + & at "1000000000" ?~ wordRef + & at "10000000000" ?~ wordRef + & at "100000000000" ?~ wordRef + & at "1000000000000" ?~ wordRef + & at "10000000000000" ?~ wordRef + & at "100000000000000" ?~ wordRef + & at "1000000000000000" ?~ wordRef + & at "10000000000000000" ?~ wordRef + & at "45000000000000000" ?~ wordRef + ) + ) + & at "allStakes" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) + ) + +instance Arbitrary UtxoStatistics where + arbitrary = UtxoStatistics <$> arbitrary + <*> arbitrary + +instance Buildable [HistogramBar] where + build = + bprint listJson + + +deriveSafeBuildable ''UtxoStatistics +instance BuildableSafeGen UtxoStatistics where + buildSafeGen _ UtxoStatistics{..} = bprint ("{" + %" histogram="%build + %" allStakes="%build + %" }") + theHistogram + theAllStakes + +instance Example HistogramBar +instance Example UtxoStatistics + + +computeUtxoStatistics :: [Word64] -> UtxoStatistics +computeUtxoStatistics xs = L.fold (summarizeUtxoStatistics $ generateBounds Log10) xs + +-- Using foldl library enable as to capture a number of aggregations in one pass. This thanks to L.Fold being an Applicative +summarizeUtxoStatistics :: NonEmpty Word64 -> L.Fold Word64 UtxoStatistics +summarizeUtxoStatistics bounds = + UtxoStatistics + <$> populateBuckets bounds + <*> L.sum + +populateBuckets :: NonEmpty Word64 -> L.Fold Word64 [HistogramBar] +populateBuckets bounds = + L.Fold (addCountInBuckets $ head bounds) (initalizeMap bounds) + (fmap (\(x1, x2) -> HistogramBarCount (T.pack $ show x1) x2) . Map.toList) + where + initalizeMap :: NonEmpty Word64 -> Map.Map Word64 Word64 + initalizeMap b = Map.fromList $ NL.toList $ NL.zip b (NL.repeat 0) + addCountInBuckets :: Word64 -> Map.Map Word64 Word64 -> Word64 -> Map.Map Word64 Word64 + addCountInBuckets thefirst acc entry = + case Map.lookupGE entry acc of + Just (k, v) -> Map.insert k (v+1) acc + Nothing -> Map.adjust (+1) thefirst acc diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs index cc4452d2478..603d3c5c104 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs @@ -41,6 +41,7 @@ import Cardano.Wallet.WalletLayer.Types (CreateWalletError (..), GetWalletError (..), UpdateWalletError (..), UpdateWalletPasswordError (..)) + createWallet :: MonadIO m => Kernel.PassiveWallet -> V1.NewWallet diff --git a/wallet-new/test/Cardano/Wallet/WalletLayer/QuickCheck.hs b/wallet-new/test/Cardano/Wallet/WalletLayer/QuickCheck.hs index a58865bcf58..132f4f8832e 100644 --- a/wallet-new/test/Cardano/Wallet/WalletLayer/QuickCheck.hs +++ b/wallet-new/test/Cardano/Wallet/WalletLayer/QuickCheck.hs @@ -23,8 +23,8 @@ import qualified Cardano.Wallet.Kernel.Accounts as Kernel import Pos.Core.Txp (TxIn (..), TxOut, TxOutAux) import Pos.Core () -import Test.QuickCheck (Arbitrary (..), Gen, arbitrary, choose, - generate, genericShrink, oneof, scale) +import Test.QuickCheck (Arbitrary (..), arbitrary, choose, generate, + genericShrink, oneof, scale) import Test.QuickCheck.Arbitrary.Generic (genericArbitrary) -- | Initialize the passive wallet. @@ -145,14 +145,11 @@ instance Arbitrary GetUtxosError where , GetUtxosErrorFromGetAccountsError <$> arbitrary ] -genTxIn :: Gen TxIn -genTxIn = oneof - [ TxInUtxo <$> arbitrary <*> arbitrary - , TxInUnknown <$> choose (1, 255) <*> scale (min 150) arbitrary - ] - instance Arbitrary TxIn where - arbitrary = genTxIn + arbitrary = oneof + [ TxInUtxo <$> arbitrary <*> arbitrary + , TxInUnknown <$> choose (1, 255) <*> scale (min 150) arbitrary + ] shrink = genericShrink instance Arbitrary TxOutAux where From ac7681cce61d87d18e7481aef774b613fba30c3c Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Sat, 18 Aug 2018 11:08:07 +0200 Subject: [PATCH 05/14] [CO-347] Further corrections and get rid of scientific --- pkgs/default.nix | 2 -- wallet-new/cardano-sl-wallet-new.cabal | 1 - wallet-new/integration/WalletSpecs.hs | 2 +- .../Cardano/Wallet/Types/UtxoStatistics.hs | 33 +++++++------------ 4 files changed, 12 insertions(+), 26 deletions(-) diff --git a/pkgs/default.nix b/pkgs/default.nix index 33e8652e335..03b1beec623 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -17805,7 +17805,6 @@ license = stdenv.lib.licenses.mit; , retry , safe-exceptions , safecopy -, scientific , serokell-util , servant , servant-client @@ -17909,7 +17908,6 @@ resourcet retry safe-exceptions safecopy -scientific serokell-util servant servant-client diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index 084d5dbbb14..29daec822e5 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -197,7 +197,6 @@ library , stm , safecopy , safe-exceptions - , scientific , serokell-util , servant , servant-client diff --git a/wallet-new/integration/WalletSpecs.hs b/wallet-new/integration/WalletSpecs.hs index c8c42a7451b..886cab37f3b 100644 --- a/wallet-new/integration/WalletSpecs.hs +++ b/wallet-new/integration/WalletSpecs.hs @@ -61,7 +61,7 @@ walletSpecs _ wc = do eresp <- getUtxoStatistics wc (walId wallet) utxoStatistics <- fmap wrData eresp `shouldPrism` _Right - let possibleBuckets = fmap show $ (generateBounds Log10) + let possibleBuckets = show <$> generateBounds Log10 let histogram = map (\x -> HistogramBarCount x 0) possibleBuckets let allStakes = 0 utxoStatistics `shouldBe` UtxoStatistics (NL.toList histogram) allStakes diff --git a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs index 23f5b71ecad..5778c23f15a 100644 --- a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs +++ b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs @@ -14,10 +14,10 @@ import Universum import qualified Control.Foldl as L import Control.Lens (at, (?~)) import Data.Aeson +import Data.Aeson.Types (Parser) import qualified Data.HashMap.Strict as HMS import qualified Data.List.NonEmpty as NL import qualified Data.Map.Strict as Map -import Data.Scientific (floatingOrInteger) import Data.Swagger hiding (Example, example) import qualified Data.Text as T import Data.Word (Word64) @@ -56,10 +56,10 @@ generateBounds bType = Haphazard -> NL.fromList [10, 100, 1000, 10000] instance Arbitrary HistogramBar where - arbitrary = - let possibleBuckets = fmap show (generateBounds Log10) - possibleBars = NL.zipWith HistogramBarCount possibleBuckets (NL.fromList [0..]) - in elements (NL.toList possibleBars) + arbitrary = do + possiblenames <- elements $ map show (NL.toList $ generateBounds Log10) + bound <- arbitrary + pure (HistogramBarCount possiblenames bound) deriveSafeBuildable ''HistogramBar @@ -92,23 +92,12 @@ instance ToJSON UtxoStatistics where , "allStakes" .= allStakes ] instance FromJSON UtxoStatistics where - parseJSON (Object v) = - let histogramListM = case HMS.lookup "histogram" v of - Nothing -> empty - Just (Object bars) -> do - let constructHistogram (key, Number val) = - case floatingOrInteger val of - Left (_ :: Double) -> error "UtxoStatistics FromJson not integer" - Right integer -> if integer >= 0 then - HistogramBarCount key integer - else - error "UtxoStatistics FromJson not positive integer" - constructHistogram _ = error "UtxoStatistics FromJson" - return $ map constructHistogram $ HMS.toList bars - Just _ -> empty - in UtxoStatistics <$> histogramListM - <*> v .: "allStakes" - parseJSON _ = empty + parseJSON = withObject "UtxoStatistics" $ \o -> do + histo <- o .: "histogram" :: Parser (HashMap Text Word64) + let constructHistogram = uncurry HistogramBarCount + let histoBars = map constructHistogram $ HMS.toList histo + stakes <- o .: "allStakes" + pure $ UtxoStatistics histoBars stakes instance ToSchema UtxoStatistics where declareNamedSchema _ = do From d23d8faec10544232c7e3e90ec8d376adbf7a7ed Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Sat, 18 Aug 2018 17:03:27 +0200 Subject: [PATCH 06/14] [CO-347] Pandering to hlint needs and improving on error handling to Utxo statistics --- .../Cardano/Wallet/Types/UtxoStatistics.hs | 47 +++++++++++++++++-- 1 file changed, 43 insertions(+), 4 deletions(-) diff --git a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs index 5778c23f15a..5915a65f2dc 100644 --- a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs +++ b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} module Cardano.Wallet.Types.UtxoStatistics ( computeUtxoStatistics @@ -18,7 +19,7 @@ import Data.Aeson.Types (Parser) import qualified Data.HashMap.Strict as HMS import qualified Data.List.NonEmpty as NL import qualified Data.Map.Strict as Map -import Data.Swagger hiding (Example, example) +import Data.Swagger hiding (Example) import qualified Data.Text as T import Data.Word (Word64) import Formatting (bprint, build, (%)) @@ -94,10 +95,48 @@ instance ToJSON UtxoStatistics where instance FromJSON UtxoStatistics where parseJSON = withObject "UtxoStatistics" $ \o -> do histo <- o .: "histogram" :: Parser (HashMap Text Word64) - let constructHistogram = uncurry HistogramBarCount - let histoBars = map constructHistogram $ HMS.toList histo stakes <- o .: "allStakes" - pure $ UtxoStatistics histoBars stakes + case validateUtxoStatistics histo stakes of + Right (histogram, allStakes) -> do + let constructHistogram = uncurry HistogramBarCount + let histoBars = map constructHistogram $ HMS.toList histogram + pure $ UtxoStatistics histoBars allStakes + Left err -> fail $ "Failed to parse UtxoStatistics: " <> show err + +data UtxoStatisticsError + = ErrHistogramEmpty + | ErrHistogramNamesInvalid + | ErrHistogramUpperBoundsNegative + | ErrAllStakesNegative + deriving (Show) + +validateUtxoStatistics :: HashMap Text Word64 -> Word64 -> Either UtxoStatisticsError (HashMap Text Word64, Word64) +validateUtxoStatistics histogram allStakes + | histogramBinNumCond histogram = Left ErrHistogramEmpty + | histogramKeysCond histogram = Left ErrHistogramNamesInvalid + | histogramValsCond histogram = Left ErrHistogramUpperBoundsNegative + | allStakesCond allStakes = Left ErrAllStakesNegative + | otherwise = Right (histogram, allStakes) + where + histogramBinNumCond histo = (length $ HMS.keys histo) <= 0 + validateKeys = any (\key -> notElem key $ map show (NL.toList $ generateBounds Log10) ) + histogramKeysCond = validateKeys . HMS.keys + validateVals = any (< 0) + histogramValsCond = validateVals . HMS.elems + allStakesCond = (< 0) + + +instance Buildable UtxoStatisticsError where + build = \case + ErrHistogramEmpty -> + bprint "Utxo statistics histogram cannot be empty of bins" + ErrHistogramNamesInvalid -> + bprint "All names of Utxo statistics histogram have to be valid" + ErrHistogramUpperBoundsNegative -> + bprint "All upper bounds of Utxo statistics histogram have to be nonnegative" + ErrAllStakesNegative -> + bprint "Utxo statistics allStakes has to be nonnegative" + instance ToSchema UtxoStatistics where declareNamedSchema _ = do From b8727e1b535478e17e3568418f0ae4f29a965a47 Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Mon, 20 Aug 2018 08:26:18 +0200 Subject: [PATCH 07/14] [CO-347] Reading improvements, adding new error and smart constructor --- wallet-new/integration/TransactionSpecs.hs | 13 +- wallet-new/integration/WalletSpecs.hs | 8 +- .../Cardano/Wallet/Types/UtxoStatistics.hs | 146 +++++++++++------- 3 files changed, 105 insertions(+), 62 deletions(-) diff --git a/wallet-new/integration/TransactionSpecs.hs b/wallet-new/integration/TransactionSpecs.hs index c2f49063746..b16d6835070 100644 --- a/wallet-new/integration/TransactionSpecs.hs +++ b/wallet-new/integration/TransactionSpecs.hs @@ -9,6 +9,7 @@ import Cardano.Wallet.API.V1.Errors hiding (describe) import Cardano.Wallet.Client.Http import Control.Lens import qualified Data.List.NonEmpty as NL +import qualified Data.Map.Strict as Map import qualified Pos.Core as Core import Test.Hspec @@ -209,18 +210,20 @@ transactionSpecs wRef wc = do , pmtSpendingPassword = Nothing } - let possibleBuckets = fmap show $ (generateBounds Log10) + let possibleBuckets = NL.toList $ generateBounds Log10 eresp0 <- getUtxoStatistics wc (walId wallet) utxoStatistics0 <- fmap wrData eresp0 `shouldPrism` _Right - let histogram0 = NL.zipWith HistogramBarCount possibleBuckets (NL.repeat 0) + let histogram0 = Map.fromList $ zip possibleBuckets (repeat 0) let allStakes0 = 0 - utxoStatistics0 `shouldBe` UtxoStatistics (NL.toList histogram0) allStakes0 + utxoStatistics0Expected <- mkUtxoStatistics histogram0 allStakes0 `shouldPrism` _Right + utxoStatistics0 `shouldBe` utxoStatistics0Expected void $ postTransaction wc (payment 1) threadDelay 120000000 eresp <- getUtxoStatistics wc (walId wallet) utxoStatistics <- fmap wrData eresp `shouldPrism` _Right - let histogram = NL.zipWith HistogramBarCount possibleBuckets (NL.cons (1::Word64) (NL.repeat 0) ) + let histogram = Map.fromList $ zip possibleBuckets (cons (1::Word64) (repeat 0)) let allStakes = 1 - utxoStatistics `shouldBe` UtxoStatistics (NL.toList histogram) allStakes + utxoStatisticsExpected <- mkUtxoStatistics histogram allStakes `shouldPrism` _Right + utxoStatistics `shouldBe` utxoStatisticsExpected diff --git a/wallet-new/integration/WalletSpecs.hs b/wallet-new/integration/WalletSpecs.hs index 886cab37f3b..267a53222bf 100644 --- a/wallet-new/integration/WalletSpecs.hs +++ b/wallet-new/integration/WalletSpecs.hs @@ -10,6 +10,7 @@ import Cardano.Wallet.API.V1.Errors import Cardano.Wallet.Client.Http import Control.Lens import qualified Data.List.NonEmpty as NL +import qualified Data.Map.Strict as Map import Test.Hspec import Util @@ -61,10 +62,11 @@ walletSpecs _ wc = do eresp <- getUtxoStatistics wc (walId wallet) utxoStatistics <- fmap wrData eresp `shouldPrism` _Right - let possibleBuckets = show <$> generateBounds Log10 - let histogram = map (\x -> HistogramBarCount x 0) possibleBuckets + let possibleBuckets = NL.toList $ generateBounds Log10 + let histogram = Map.fromList $ zip possibleBuckets (repeat 0) let allStakes = 0 - utxoStatistics `shouldBe` UtxoStatistics (NL.toList histogram) allStakes + utxoStatisticsExpected <- mkUtxoStatistics histogram allStakes `shouldPrism` _Right + utxoStatistics `shouldBe` utxoStatisticsExpected where testWalletAlreadyExists action = do newWallet1 <- randomWallet action diff --git a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs index 5915a65f2dc..3d9e7df932c 100644 --- a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs +++ b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + module Cardano.Wallet.Types.UtxoStatistics ( computeUtxoStatistics - , UtxoStatistics (..) - , HistogramBar (..) + , UtxoStatistics + , mkUtxoStatistics , BoundType (..) , generateBounds ) where @@ -20,12 +22,11 @@ import qualified Data.HashMap.Strict as HMS import qualified Data.List.NonEmpty as NL import qualified Data.Map.Strict as Map import Data.Swagger hiding (Example) -import qualified Data.Text as T import Data.Word (Word64) -import Formatting (bprint, build, (%)) +import Formatting (bprint, build, formatToString, (%)) import qualified Formatting.Buildable import Serokell.Util (listJson) -import Test.QuickCheck +import Test.QuickCheck (Arbitrary (..), arbitrary, elements, suchThat) import Cardano.Wallet.API.V1.Swagger.Example (Example) import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), @@ -41,8 +42,8 @@ import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), -- (c) topN buckets -- to name a few data HistogramBar = HistogramBarCount - { bucketName :: !Text - , bucketUpperBound :: !Word64 + { bucketUpperBound :: !Word64 + , bucketCount :: !Word64 } deriving (Show, Eq, Ord, Generic) -- Buckets boundaries can be constructed in different way @@ -58,8 +59,8 @@ generateBounds bType = instance Arbitrary HistogramBar where arbitrary = do - possiblenames <- elements $ map show (NL.toList $ generateBounds Log10) - bound <- arbitrary + possiblenames <- elements (NL.toList $ generateBounds Log10) + bound <- arbitrary `suchThat` (>= 0) pure (HistogramBarCount possiblenames bound) @@ -67,11 +68,11 @@ deriveSafeBuildable ''HistogramBar instance BuildableSafeGen HistogramBar where buildSafeGen _ HistogramBarCount{..} = bprint ("{" - %" name="%build %" upperBound="%build + %" count="%build %" }") - bucketName bucketUpperBound + bucketCount data UtxoStatistics = UtxoStatistics @@ -79,7 +80,39 @@ data UtxoStatistics = UtxoStatistics , theAllStakes :: !Word64 } deriving (Show, Generic, Ord) -toMap :: [HistogramBar] -> Map Text Word64 + +mkUtxoStatistics + :: Map Word64 Word64 + -> Word64 + -> Either UtxoStatisticsError UtxoStatistics +mkUtxoStatistics histogram allStakes = do + let (histoKeys, histoElems) = (Map.keys histogram, Map.elems histogram) + let acceptedKeys = NL.toList $ generateBounds Log10 + let (minPossibleValue, maxPossibleValue) = getPossibleBounds histogram + let constructHistogram = uncurry HistogramBarCount + let histoBars = map constructHistogram $ Map.toList histogram + + when (length histoKeys <= 0) $ + Left ErrHistogramEmpty + when (any (flip notElem acceptedKeys) histoKeys) $ + Left ErrHistogramNamesInvalid + when (any (< 0) histoElems) $ + Left ErrHistogramUpperBoundsNegative + when (allStakes < 0) $ + Left ErrAllStakesNegative + when (allStakes < minPossibleValue && allStakes > maxPossibleValue) $ + Left ErrAllStakesValueNotCompatibleWithHistogram + + pure UtxoStatistics + { theHistogram = histoBars + , theAllStakes = allStakes + } + +eitherToParser :: Buildable a => Either a b -> Parser b +eitherToParser = + either (fail . formatToString build) pure + +toMap :: [HistogramBar] -> Map Word64 Word64 toMap = Map.fromList . map (\(HistogramBarCount key val) -> (key,val)) instance Eq UtxoStatistics where @@ -88,42 +121,40 @@ instance Eq UtxoStatistics where instance ToJSON UtxoStatistics where toJSON (UtxoStatistics bars allStakes) = let histogramObject = Object . HMS.fromList . map extractBarKey - extractBarKey (HistogramBarCount bound stake) = bound .= stake + extractBarKey (HistogramBarCount bound stake) = (show bound) .= stake in object [ "histogram" .= histogramObject bars , "allStakes" .= allStakes ] instance FromJSON UtxoStatistics where parseJSON = withObject "UtxoStatistics" $ \o -> do - histo <- o .: "histogram" :: Parser (HashMap Text Word64) + histo <- o .: "histogram" :: Parser (Map Word64 Word64) stakes <- o .: "allStakes" - case validateUtxoStatistics histo stakes of - Right (histogram, allStakes) -> do - let constructHistogram = uncurry HistogramBarCount - let histoBars = map constructHistogram $ HMS.toList histogram - pure $ UtxoStatistics histoBars allStakes - Left err -> fail $ "Failed to parse UtxoStatistics: " <> show err + eitherToParser $ mkUtxoStatistics histo stakes + data UtxoStatisticsError = ErrHistogramEmpty | ErrHistogramNamesInvalid | ErrHistogramUpperBoundsNegative | ErrAllStakesNegative + | ErrAllStakesValueNotCompatibleWithHistogram deriving (Show) -validateUtxoStatistics :: HashMap Text Word64 -> Word64 -> Either UtxoStatisticsError (HashMap Text Word64, Word64) -validateUtxoStatistics histogram allStakes - | histogramBinNumCond histogram = Left ErrHistogramEmpty - | histogramKeysCond histogram = Left ErrHistogramNamesInvalid - | histogramValsCond histogram = Left ErrHistogramUpperBoundsNegative - | allStakesCond allStakes = Left ErrAllStakesNegative - | otherwise = Right (histogram, allStakes) + +getPossibleBounds :: Map Word64 Word64 -> (Word64, Word64) +getPossibleBounds histogram = + (calculatePossibleBound fst, calculatePossibleBound snd) where - histogramBinNumCond histo = (length $ HMS.keys histo) <= 0 - validateKeys = any (\key -> notElem key $ map show (NL.toList $ generateBounds Log10) ) - histogramKeysCond = validateKeys . HMS.keys - validateVals = any (< 0) - histogramValsCond = validateVals . HMS.elems - allStakesCond = (< 0) + createBracketPairs :: Num a => [a] -> [(a,a)] + createBracketPairs (reverse -> (x:xs)) = zip (map (+1) $ reverse (xs ++ [0])) (reverse (x:xs)) + createBracketPairs _ = [] + matching fromPair (key,value) = + map ( (*value) . fromPair ) . filter (\(_,upper) -> key == upper) + acceptedKeys = NL.toList $ generateBounds Log10 + calculatePossibleBound fromPair = + sum . + concatMap (\pair -> matching fromPair pair $ createBracketPairs acceptedKeys) $ + Map.toList histogram instance Buildable UtxoStatisticsError where @@ -136,7 +167,8 @@ instance Buildable UtxoStatisticsError where bprint "All upper bounds of Utxo statistics histogram have to be nonnegative" ErrAllStakesNegative -> bprint "Utxo statistics allStakes has to be nonnegative" - + ErrAllStakesValueNotCompatibleWithHistogram -> + bprint "Utxo statistics allStakes has value that is not possible given histogram distribution" instance ToSchema UtxoStatistics where declareNamedSchema _ = do @@ -176,7 +208,14 @@ instance ToSchema UtxoStatistics where instance Arbitrary UtxoStatistics where arbitrary = UtxoStatistics <$> arbitrary <*> arbitrary - +-- This code goes into nonstoping computation when checking swagger integration of WalletResponse UtxoStatistics +{-- do + histogram <- arbitrary + let (minPossibleValue, maxPossibleValue) = getPossibleBounds histogram + let histoBars = map (uncurry HistogramBarCount) $ Map.toList histogram + allStakes <- arbitrary `suchThat` (\s -> s >= minPossibleValue && s <= maxPossibleValue) + return $ UtxoStatistics histoBars allStakes +--} instance Buildable [HistogramBar] where build = bprint listJson @@ -196,24 +235,23 @@ instance Example UtxoStatistics computeUtxoStatistics :: [Word64] -> UtxoStatistics -computeUtxoStatistics xs = L.fold (summarizeUtxoStatistics $ generateBounds Log10) xs - --- Using foldl library enable as to capture a number of aggregations in one pass. This thanks to L.Fold being an Applicative -summarizeUtxoStatistics :: NonEmpty Word64 -> L.Fold Word64 UtxoStatistics -summarizeUtxoStatistics bounds = - UtxoStatistics - <$> populateBuckets bounds +computeUtxoStatistics = L.fold $ UtxoStatistics + <$> foldBuckets (generateBounds Log10) <*> L.sum -populateBuckets :: NonEmpty Word64 -> L.Fold Word64 [HistogramBar] -populateBuckets bounds = - L.Fold (addCountInBuckets $ head bounds) (initalizeMap bounds) - (fmap (\(x1, x2) -> HistogramBarCount (T.pack $ show x1) x2) . Map.toList) - where - initalizeMap :: NonEmpty Word64 -> Map.Map Word64 Word64 - initalizeMap b = Map.fromList $ NL.toList $ NL.zip b (NL.repeat 0) - addCountInBuckets :: Word64 -> Map.Map Word64 Word64 -> Word64 -> Map.Map Word64 Word64 - addCountInBuckets thefirst acc entry = - case Map.lookupGE entry acc of - Just (k, v) -> Map.insert k (v+1) acc - Nothing -> Map.adjust (+1) thefirst acc +foldBuckets :: NonEmpty Word64 -> L.Fold Word64 [HistogramBar] +foldBuckets bounds = + let + step :: Map Word64 Word64 -> Word64 -> Map Word64 Word64 + step x a = + case Map.lookupGE a x of + Just (k, v) -> Map.insert k (v+1) x + Nothing -> Map.adjust (+1) (head bounds) x + initial :: Map Word64 Word64 + initial = + Map.fromList $ zip (NL.toList bounds) (repeat 0) + extract :: Map Word64 Word64 -> [HistogramBar] + extract = + map (uncurry HistogramBarCount) . Map.toList + in + L.Fold step initial extract From 1a663ad0c21ed56c72960ba663140658748af061 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 20 Aug 2018 15:32:17 +0200 Subject: [PATCH 08/14] [CO-347] Remove a few redundant dependencies from wallet & wallet-new This was done using weeder and is for now necessary for the CI to kick in. We are starting to reach a critical point in terms of dependencies and this kind of solution might not work anymore in the future. There's a PR opened about doing something against these 'arguments list too long'. :finger_crossed: --- wallet-new/cardano-sl-wallet-new.cabal | 3 --- wallet/cardano-sl-wallet.cabal | 15 --------------- 2 files changed, 18 deletions(-) diff --git a/wallet-new/cardano-sl-wallet-new.cabal b/wallet-new/cardano-sl-wallet-new.cabal index 29daec822e5..26b2bf8b392 100755 --- a/wallet-new/cardano-sl-wallet-new.cabal +++ b/wallet-new/cardano-sl-wallet-new.cabal @@ -162,7 +162,6 @@ library , cardano-sl-node-ipc , cardano-sl-util , cardano-sl-wallet - , cardano-sl-wallet-test , conduit , connection , containers @@ -487,7 +486,6 @@ test-suite wallet-unit-tests , data-default , formatting , hspec - , ixset-typed , lens , log-warper , mtl @@ -623,7 +621,6 @@ benchmark cardano-sl-wallet-new-bench , bytestring , cardano-sl-client , cardano-sl-core - , cardano-sl-db , cardano-sl-wallet , cassava , connection diff --git a/wallet/cardano-sl-wallet.cabal b/wallet/cardano-sl-wallet.cabal index 8e4c4af08e1..69fb03d37d8 100644 --- a/wallet/cardano-sl-wallet.cabal +++ b/wallet/cardano-sl-wallet.cabal @@ -236,27 +236,17 @@ test-suite cardano-wallet-test type: exitcode-stdio-1.0 build-depends: base - , MonadRandom , QuickCheck - , aeson - , bytestring - , cardano-crypto , cardano-sl , cardano-sl-chain , cardano-sl-client , cardano-sl-core - , cardano-sl-core-test , cardano-sl-crypto - , cardano-sl-crypto-test , cardano-sl-db , cardano-sl-generator , cardano-sl-infra , cardano-sl-util - , cardano-sl-util-test - , cardano-sl-wallet - , containers , data-default - , deepseq , ekg-core , ether , formatting @@ -264,14 +254,9 @@ test-suite cardano-wallet-test , lens , log-warper , mtl - , safe-exceptions - , safecopy - , serokell-util >= 0.1.3.4 - , servant-server , stm , formatting , universum >= 0.1.11 - , unordered-containers hs-source-dirs: test default-language: Haskell2010 From 3dd925f9a669b643d4d8344848f98f49d5fb2baa Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Mon, 20 Aug 2018 13:43:53 +0200 Subject: [PATCH 09/14] [CO-347] Improvements on UtxoStatistics arbitrary instance --- .../Cardano/Wallet/Types/UtxoStatistics.hs | 31 +++++++++---------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs index 3d9e7df932c..cc25b6f6bf1 100644 --- a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs +++ b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs @@ -26,7 +26,8 @@ import Data.Word (Word64) import Formatting (bprint, build, formatToString, (%)) import qualified Formatting.Buildable import Serokell.Util (listJson) -import Test.QuickCheck (Arbitrary (..), arbitrary, elements, suchThat) +import Test.QuickCheck (Arbitrary (..), arbitrary, choose, elements, + infiniteListOf, shuffle) import Cardano.Wallet.API.V1.Swagger.Example (Example) import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), @@ -59,9 +60,9 @@ generateBounds bType = instance Arbitrary HistogramBar where arbitrary = do - possiblenames <- elements (NL.toList $ generateBounds Log10) - bound <- arbitrary `suchThat` (>= 0) - pure (HistogramBarCount possiblenames bound) + upperBound <- elements (NL.toList $ generateBounds Log10) + count <- arbitrary + pure (HistogramBarCount upperBound count) deriveSafeBuildable ''HistogramBar @@ -112,11 +113,11 @@ eitherToParser :: Buildable a => Either a b -> Parser b eitherToParser = either (fail . formatToString build) pure -toMap :: [HistogramBar] -> Map Word64 Word64 -toMap = Map.fromList . map (\(HistogramBarCount key val) -> (key,val)) +sorted :: [HistogramBar] -> [HistogramBar] +sorted = sortOn (\(HistogramBarCount key _) -> key) instance Eq UtxoStatistics where - (UtxoStatistics h s) == (UtxoStatistics h' s') = s == s' && toMap h == toMap h' + (UtxoStatistics h s) == (UtxoStatistics h' s') = s == s' && sorted h == sorted h' instance ToJSON UtxoStatistics where toJSON (UtxoStatistics bars allStakes) = @@ -206,16 +207,14 @@ instance ToSchema UtxoStatistics where ) instance Arbitrary UtxoStatistics where - arbitrary = UtxoStatistics <$> arbitrary - <*> arbitrary --- This code goes into nonstoping computation when checking swagger integration of WalletResponse UtxoStatistics -{-- do - histogram <- arbitrary - let (minPossibleValue, maxPossibleValue) = getPossibleBounds histogram - let histoBars = map (uncurry HistogramBarCount) $ Map.toList histogram - allStakes <- arbitrary `suchThat` (\s -> s >= minPossibleValue && s <= maxPossibleValue) + arbitrary = do + upperBounds <- shuffle (NL.toList $ generateBounds Log10) + counts <- infiniteListOf arbitrary + let histogram = zip upperBounds counts + let histoBars = map (uncurry HistogramBarCount) histogram + allStakes <- choose (getPossibleBounds $ Map.fromList histogram) return $ UtxoStatistics histoBars allStakes ---} + instance Buildable [HistogramBar] where build = bprint listJson From a3600048b4f1c7724e423b8fd57780a7909e915a Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 20 Aug 2018 16:53:01 +0200 Subject: [PATCH 10/14] [CO-347] Re-organize UtxoStatistics API to expose only minimal API - We do not expose type internals and provide one smart constructor for that purpose (computeUtxoStatistics) - Same for the 'BoundType' which should actually be part of the API if we intend to use it, making it an opaque type with exposed constructors allow for easy extension and maintainability - Reviewed a bit errors to make constructors a bit less specified in favor of constructor with arg - Added 'BoundType' as 'boundType' to the JSON representation - Made Aeson & Swagger imports explicit! --- wallet-new/integration/TransactionSpecs.hs | 15 +- wallet-new/integration/WalletSpecs.hs | 9 +- .../Cardano/Wallet/API/V1/Handlers/Wallets.hs | 6 +- .../Wallet/API/V1/LegacyHandlers/Wallets.hs | 4 +- .../Cardano/Wallet/Types/UtxoStatistics.hs | 385 ++++++++++-------- 5 files changed, 228 insertions(+), 191 deletions(-) diff --git a/wallet-new/integration/TransactionSpecs.hs b/wallet-new/integration/TransactionSpecs.hs index b16d6835070..aeb7f0671fb 100644 --- a/wallet-new/integration/TransactionSpecs.hs +++ b/wallet-new/integration/TransactionSpecs.hs @@ -8,8 +8,6 @@ import Universum import Cardano.Wallet.API.V1.Errors hiding (describe) import Cardano.Wallet.Client.Http import Control.Lens -import qualified Data.List.NonEmpty as NL -import qualified Data.Map.Strict as Map import qualified Pos.Core as Core import Test.Hspec @@ -26,7 +24,7 @@ ppShowT :: Show a => a -> Text ppShowT = fromString . ppShow transactionSpecs :: WalletRef -> WalletClient IO -> Spec -transactionSpecs wRef wc = do +transactionSpecs wRef wc = describe "Transactions" $ do it "posted transactions appear in the index" $ do genesis <- genesisWallet wc @@ -210,20 +208,15 @@ transactionSpecs wRef wc = do , pmtSpendingPassword = Nothing } - let possibleBuckets = NL.toList $ generateBounds Log10 - eresp0 <- getUtxoStatistics wc (walId wallet) utxoStatistics0 <- fmap wrData eresp0 `shouldPrism` _Right - let histogram0 = Map.fromList $ zip possibleBuckets (repeat 0) - let allStakes0 = 0 - utxoStatistics0Expected <- mkUtxoStatistics histogram0 allStakes0 `shouldPrism` _Right + let utxoStatistics0Expected = computeUtxoStatistics log10 [] utxoStatistics0 `shouldBe` utxoStatistics0Expected void $ postTransaction wc (payment 1) threadDelay 120000000 + eresp <- getUtxoStatistics wc (walId wallet) utxoStatistics <- fmap wrData eresp `shouldPrism` _Right - let histogram = Map.fromList $ zip possibleBuckets (cons (1::Word64) (repeat 0)) - let allStakes = 1 - utxoStatisticsExpected <- mkUtxoStatistics histogram allStakes `shouldPrism` _Right + let utxoStatisticsExpected = computeUtxoStatistics log10 [1] utxoStatistics `shouldBe` utxoStatisticsExpected diff --git a/wallet-new/integration/WalletSpecs.hs b/wallet-new/integration/WalletSpecs.hs index 267a53222bf..87bfd85612c 100644 --- a/wallet-new/integration/WalletSpecs.hs +++ b/wallet-new/integration/WalletSpecs.hs @@ -9,15 +9,13 @@ import Cardano.Wallet.API.V1.Errors (WalletError (WalletAlreadyExists)) import Cardano.Wallet.Client.Http import Control.Lens -import qualified Data.List.NonEmpty as NL -import qualified Data.Map.Strict as Map import Test.Hspec import Util walletSpecs :: WalletRef -> WalletClient IO -> Spec -walletSpecs _ wc = do +walletSpecs _ wc = describe "Wallets" $ do it "Creating a wallet makes it available." $ do newWallet <- randomWallet CreateWallet @@ -62,10 +60,7 @@ walletSpecs _ wc = do eresp <- getUtxoStatistics wc (walId wallet) utxoStatistics <- fmap wrData eresp `shouldPrism` _Right - let possibleBuckets = NL.toList $ generateBounds Log10 - let histogram = Map.fromList $ zip possibleBuckets (repeat 0) - let allStakes = 0 - utxoStatisticsExpected <- mkUtxoStatistics histogram allStakes `shouldPrism` _Right + let utxoStatisticsExpected = computeUtxoStatistics log10 [] utxoStatistics `shouldBe` utxoStatisticsExpected where testWalletAlreadyExists action = do diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs index 177ec3abd82..109935d28ba 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs @@ -114,6 +114,6 @@ getUtxoStatistics pwl wid = do let extractValue :: TxOutAux -> Word64 extractValue = getCoin . txOutValue . toaOut let utxosCoinValuesForAllAccounts :: [(Account, Utxo)] -> [Word64] - utxosCoinValuesForAllAccounts pairs = - concatMap (\pair -> map extractValue (M.elems $ snd pair) ) pairs - return $ single (V1.computeUtxoStatistics $ utxosCoinValuesForAllAccounts w) + utxosCoinValuesForAllAccounts = + concatMap (\pair -> map extractValue (M.elems $ snd pair) ) + return $ single (V1.computeUtxoStatistics V1.log10 $ utxosCoinValuesForAllAccounts w) diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs index 060a151bd8d..0e9f9b36610 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs @@ -193,5 +193,5 @@ getUtxoStatistics :: (MonadWalletLogic ctx m) => WalletId -> m (WalletResponse UtxoStatistics) -getUtxoStatistics _ = do - return $ single (V1.computeUtxoStatistics []) +getUtxoStatistics _ = + return $ single (V1.computeUtxoStatistics V1.log10 []) diff --git a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs index cc25b6f6bf1..f26183b2323 100644 --- a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs +++ b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs @@ -2,29 +2,33 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} - module Cardano.Wallet.Types.UtxoStatistics - ( computeUtxoStatistics - , UtxoStatistics - , mkUtxoStatistics - , BoundType (..) - , generateBounds + ( -- * Types + UtxoStatistics + , BoundType + , UtxoStatisticsError(..) + + -- * Constructing 'UtxoStatistics' + , computeUtxoStatistics + + -- * Constructing 'BoundType' + , log10 ) where import Universum -import qualified Control.Foldl as L import Control.Lens (at, (?~)) -import Data.Aeson +import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (..), + genericParseJSON, genericToJSON, object, withObject, (.:), + (.=)) import Data.Aeson.Types (Parser) -import qualified Data.HashMap.Strict as HMS -import qualified Data.List.NonEmpty as NL -import qualified Data.Map.Strict as Map -import Data.Swagger hiding (Example) +import Data.Swagger (NamedSchema (..), Referenced (..), + SwaggerType (..), ToSchema (..), declareSchemaRef, + genericDeclareNamedSchema, minimum_, properties, required, + type_) import Data.Word (Word64) import Formatting (bprint, build, formatToString, (%)) -import qualified Formatting.Buildable import Serokell.Util (listJson) import Test.QuickCheck (Arbitrary (..), arbitrary, choose, elements, infiniteListOf, shuffle) @@ -33,151 +37,119 @@ import Cardano.Wallet.API.V1.Swagger.Example (Example) import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), deriveSafeBuildable) +import qualified Control.Foldl as L +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HMS +import qualified Data.List.NonEmpty as NL +import qualified Data.Map.Strict as Map +import qualified Data.Swagger as Swagger +import qualified Formatting.Buildable --- Utxo statistics for the wallet. --- Histogram is composed of bars that represent the bucket. The bucket is tagged by upper bound of a given bucket. --- The bar value corresponds to the number of stakes --- In the future the bar value could be different things: --- (a) sum of stakes in a bucket --- (b) avg or std of stake in a bucket --- (c) topN buckets --- to name a few -data HistogramBar = HistogramBarCount - { bucketUpperBound :: !Word64 - , bucketCount :: !Word64 - } deriving (Show, Eq, Ord, Generic) - --- Buckets boundaries can be constructed in different way -data BoundType = Log10 | Haphazard - -generateBounds :: BoundType -> NonEmpty Word64 -generateBounds bType = - let (^!) :: Word64 -> Word64 -> Word64 - (^!) = (^) - in case bType of - Log10 -> NL.fromList $ ( map (\toPower -> 10 ^! toPower) [1..16] ) ++ [45 * (10 ^! 15)] - Haphazard -> NL.fromList [10, 100, 1000, 10000] - -instance Arbitrary HistogramBar where - arbitrary = do - upperBound <- elements (NL.toList $ generateBounds Log10) - count <- arbitrary - pure (HistogramBarCount upperBound count) - - -deriveSafeBuildable ''HistogramBar -instance BuildableSafeGen HistogramBar where - buildSafeGen _ HistogramBarCount{..} = - bprint ("{" - %" upperBound="%build - %" count="%build - %" }") - bucketUpperBound - bucketCount +-- +-- TYPES +-- data UtxoStatistics = UtxoStatistics { theHistogram :: ![HistogramBar] , theAllStakes :: !Word64 } deriving (Show, Generic, Ord) +data UtxoStatisticsError + = ErrEmptyHistogram + | ErrInvalidBounds !Text + | ErrInvalidTotalStakes !Text + deriving (Eq, Show, Read, Generic) -mkUtxoStatistics - :: Map Word64 Word64 - -> Word64 - -> Either UtxoStatisticsError UtxoStatistics -mkUtxoStatistics histogram allStakes = do - let (histoKeys, histoElems) = (Map.keys histogram, Map.elems histogram) - let acceptedKeys = NL.toList $ generateBounds Log10 - let (minPossibleValue, maxPossibleValue) = getPossibleBounds histogram - let constructHistogram = uncurry HistogramBarCount - let histoBars = map constructHistogram $ Map.toList histogram +-- Buckets boundaries can be constructed in different ways +data BoundType = Log10 deriving (Eq, Show, Read, Generic) - when (length histoKeys <= 0) $ - Left ErrHistogramEmpty - when (any (flip notElem acceptedKeys) histoKeys) $ - Left ErrHistogramNamesInvalid - when (any (< 0) histoElems) $ - Left ErrHistogramUpperBoundsNegative - when (allStakes < 0) $ - Left ErrAllStakesNegative - when (allStakes < minPossibleValue && allStakes > maxPossibleValue) $ - Left ErrAllStakesValueNotCompatibleWithHistogram +instance ToJSON BoundType where + toJSON = genericToJSON aesonEnumOpts - pure UtxoStatistics - { theHistogram = histoBars - , theAllStakes = allStakes - } +instance FromJSON BoundType where + parseJSON = genericParseJSON aesonEnumOpts -eitherToParser :: Buildable a => Either a b -> Parser b -eitherToParser = - either (fail . formatToString build) pure +instance ToSchema BoundType where + declareNamedSchema = genericDeclareNamedSchema Swagger.defaultSchemaOptions -sorted :: [HistogramBar] -> [HistogramBar] -sorted = sortOn (\(HistogramBarCount key _) -> key) +instance Buildable UtxoStatisticsError where + build = \case + ErrEmptyHistogram -> + bprint "Utxo statistics histogram cannot be empty." + ErrInvalidBounds err -> + bprint ("Utxo statistics have invalid bounds: "%build%".") err + ErrInvalidTotalStakes err -> + bprint ("Utxo statistics have invalid total stakes: "%build%".") err instance Eq UtxoStatistics where - (UtxoStatistics h s) == (UtxoStatistics h' s') = s == s' && sorted h == sorted h' + (UtxoStatistics h s) == (UtxoStatistics h' s') = + s == s' && sorted h == sorted h' + where + sorted :: [HistogramBar] -> [HistogramBar] + sorted = sortOn (\(HistogramBarCount key _) -> key) instance ToJSON UtxoStatistics where toJSON (UtxoStatistics bars allStakes) = - let histogramObject = Object . HMS.fromList . map extractBarKey - extractBarKey (HistogramBarCount bound stake) = (show bound) .= stake - in object [ "histogram" .= histogramObject bars - , "allStakes" .= allStakes ] + let + histogramObject = + Object . HMS.fromList . map extractBarKey + + extractBarKey (HistogramBarCount bound stake) = + show bound .= stake + in + object + [ "histogram" .= histogramObject bars + , "allStakes" .= allStakes + , "boundType" .= log10 + ] instance FromJSON UtxoStatistics where - parseJSON = withObject "UtxoStatistics" $ \o -> do - histo <- o .: "histogram" :: Parser (Map Word64 Word64) - stakes <- o .: "allStakes" - eitherToParser $ mkUtxoStatistics histo stakes - - -data UtxoStatisticsError - = ErrHistogramEmpty - | ErrHistogramNamesInvalid - | ErrHistogramUpperBoundsNegative - | ErrAllStakesNegative - | ErrAllStakesValueNotCompatibleWithHistogram - deriving (Show) - + parseJSON = withObject "UtxoStatistics" parseUtxoStatistics + where + parseUtxoStatistics :: Object -> Parser UtxoStatistics + parseUtxoStatistics o = + eitherToParser =<< mkUtxoStatistics + <$> (o .: "boundType") + <*> (o .: "histogram") + <*> (o .: "allStakes") + + eitherToParser :: Buildable a => Either a b -> Parser b + eitherToParser = + either (fail . formatToString build) pure -getPossibleBounds :: Map Word64 Word64 -> (Word64, Word64) -getPossibleBounds histogram = - (calculatePossibleBound fst, calculatePossibleBound snd) - where - createBracketPairs :: Num a => [a] -> [(a,a)] - createBracketPairs (reverse -> (x:xs)) = zip (map (+1) $ reverse (xs ++ [0])) (reverse (x:xs)) - createBracketPairs _ = [] - matching fromPair (key,value) = - map ( (*value) . fromPair ) . filter (\(_,upper) -> key == upper) - acceptedKeys = NL.toList $ generateBounds Log10 - calculatePossibleBound fromPair = - sum . - concatMap (\pair -> matching fromPair pair $ createBracketPairs acceptedKeys) $ - Map.toList histogram +instance Arbitrary UtxoStatistics where + arbitrary = do + upperBounds <- shuffle (NL.toList $ generateBounds Log10) + counts <- infiniteListOf arbitrary + let histogram = zip upperBounds counts + let histoBars = map (uncurry HistogramBarCount) histogram + allStakes <- choose (getPossibleBounds $ Map.fromList histogram) + return $ UtxoStatistics histoBars allStakes +instance BuildableSafeGen UtxoStatistics where + buildSafeGen _ UtxoStatistics{..} = bprint ("{" + %" histogram="%build + %" allStakes="%build + %" }") + theHistogram + theAllStakes -instance Buildable UtxoStatisticsError where - build = \case - ErrHistogramEmpty -> - bprint "Utxo statistics histogram cannot be empty of bins" - ErrHistogramNamesInvalid -> - bprint "All names of Utxo statistics histogram have to be valid" - ErrHistogramUpperBoundsNegative -> - bprint "All upper bounds of Utxo statistics histogram have to be nonnegative" - ErrAllStakesNegative -> - bprint "Utxo statistics allStakes has to be nonnegative" - ErrAllStakesValueNotCompatibleWithHistogram -> - bprint "Utxo statistics allStakes has value that is not possible given histogram distribution" +instance Example UtxoStatistics instance ToSchema UtxoStatistics where declareNamedSchema _ = do wordRef <- declareSchemaRef (Proxy :: Proxy Word64) + btypeRef <- declareSchemaRef (Proxy :: Proxy BoundType) pure $ NamedSchema (Just "UtxoStatistics") $ mempty & type_ .~ SwaggerObject & required .~ ["histogram", "allStakes"] & properties .~ (mempty + & at "boundType" ?~ btypeRef + & at "allStakes" ?~ (Inline $ mempty + & type_ .~ SwaggerNumber + & minimum_ .~ Just 0 + ) & at "histogram" ?~ Inline (mempty & type_ .~ SwaggerObject & properties .~ (mempty @@ -200,57 +172,134 @@ instance ToSchema UtxoStatistics where & at "45000000000000000" ?~ wordRef ) ) - & at "allStakes" ?~ (Inline $ mempty - & type_ .~ SwaggerNumber - & minimum_ .~ Just 0 - ) ) -instance Arbitrary UtxoStatistics where +-- +-- CONSTRUCTING +-- + +-- | Smart-constructor to create bounds using a log-10 scale +log10 :: BoundType +log10 = Log10 +{-# INLINE log10 #-} + +-- | Compute UtxoStatistics from a bunch of UTXOs +computeUtxoStatistics :: BoundType -> [Word64] -> UtxoStatistics +computeUtxoStatistics btype = L.fold $ UtxoStatistics + <$> foldBuckets (generateBounds btype) + <*> L.sum + where + foldBuckets :: NonEmpty Word64 -> L.Fold Word64 [HistogramBar] + foldBuckets bounds = + let + step :: Map Word64 Word64 -> Word64 -> Map Word64 Word64 + step x a = + case Map.lookupGE a x of + Just (k, v) -> Map.insert k (v+1) x + Nothing -> Map.adjust (+1) (head bounds) x + initial :: Map Word64 Word64 + initial = + Map.fromList $ zip (NL.toList bounds) (repeat 0) + extract :: Map Word64 Word64 -> [HistogramBar] + extract = + map (uncurry HistogramBarCount) . Map.toList + in + L.Fold step initial extract + +-- +-- INTERNALS +-- + +-- Utxo statistics for the wallet. +-- Histogram is composed of bars that represent the bucket. The bucket is tagged by upper bound of a given bucket. +-- The bar value corresponds to the number of stakes +-- In the future the bar value could be different things: +-- (a) sum of stakes in a bucket +-- (b) avg or std of stake in a bucket +-- (c) topN buckets +-- to name a few +data HistogramBar = HistogramBarCount + { bucketUpperBound :: !Word64 + , bucketCount :: !Word64 + } deriving (Show, Eq, Ord, Generic) + +instance Example HistogramBar + +instance Arbitrary HistogramBar where arbitrary = do - upperBounds <- shuffle (NL.toList $ generateBounds Log10) - counts <- infiniteListOf arbitrary - let histogram = zip upperBounds counts - let histoBars = map (uncurry HistogramBarCount) histogram - allStakes <- choose (getPossibleBounds $ Map.fromList histogram) - return $ UtxoStatistics histoBars allStakes + upperBound <- elements (NL.toList $ generateBounds log10) + count <- arbitrary + pure (HistogramBarCount upperBound count) instance Buildable [HistogramBar] where build = bprint listJson +instance BuildableSafeGen HistogramBar where + buildSafeGen _ HistogramBarCount{..} = + bprint ("{" + %" upperBound="%build + %" count="%build + %" }") + bucketUpperBound + bucketCount -deriveSafeBuildable ''UtxoStatistics -instance BuildableSafeGen UtxoStatistics where - buildSafeGen _ UtxoStatistics{..} = bprint ("{" - %" histogram="%build - %" allStakes="%build - %" }") - theHistogram - theAllStakes +mkUtxoStatistics + :: BoundType + -> Map Word64 Word64 + -> Word64 + -> Either UtxoStatisticsError UtxoStatistics +mkUtxoStatistics btype histogram allStakes = do + let (histoKeys, histoElems) = (Map.keys histogram, Map.elems histogram) + let acceptedKeys = NL.toList $ generateBounds btype + let (minPossibleValue, maxPossibleValue) = getPossibleBounds histogram + let constructHistogram = uncurry HistogramBarCount + let histoBars = map constructHistogram $ Map.toList histogram -instance Example HistogramBar -instance Example UtxoStatistics + when (length histoKeys <= 0) $ + Left ErrEmptyHistogram + when (any (`notElem` acceptedKeys) histoKeys) $ + Left $ ErrInvalidBounds $ "given bounds are incompatible with bound type (" <> show btype <> ")" + when (any (< 0) histoElems) $ + Left $ ErrInvalidBounds "encountered negative bound" + when (allStakes < 0) $ + Left $ ErrInvalidTotalStakes "total stakes is negative" + when (allStakes < minPossibleValue && allStakes > maxPossibleValue) $ + Left $ ErrInvalidTotalStakes "inconsistent total stakes & histogram" + pure UtxoStatistics + { theHistogram = histoBars + , theAllStakes = allStakes + } -computeUtxoStatistics :: [Word64] -> UtxoStatistics -computeUtxoStatistics = L.fold $ UtxoStatistics - <$> foldBuckets (generateBounds Log10) - <*> L.sum +generateBounds :: BoundType -> NonEmpty Word64 +generateBounds bType = + let (^!) :: Word64 -> Word64 -> Word64 + (^!) = (^) + in case bType of + Log10 -> NL.fromList $ map (\toPower -> 10 ^! toPower) [1..16] ++ [45 * (10 ^! 15)] -foldBuckets :: NonEmpty Word64 -> L.Fold Word64 [HistogramBar] -foldBuckets bounds = - let - step :: Map Word64 Word64 -> Word64 -> Map Word64 Word64 - step x a = - case Map.lookupGE a x of - Just (k, v) -> Map.insert k (v+1) x - Nothing -> Map.adjust (+1) (head bounds) x - initial :: Map Word64 Word64 - initial = - Map.fromList $ zip (NL.toList bounds) (repeat 0) - extract :: Map Word64 Word64 -> [HistogramBar] - extract = - map (uncurry HistogramBarCount) . Map.toList - in - L.Fold step initial extract +getPossibleBounds :: Map Word64 Word64 -> (Word64, Word64) +getPossibleBounds histogram = + (calculatePossibleBound fst, calculatePossibleBound snd) + where + createBracketPairs :: Num a => [a] -> [(a,a)] + createBracketPairs (reverse -> (x:xs)) = zip (map (+1) $ reverse (xs ++ [0])) (reverse (x:xs)) + createBracketPairs _ = [] + matching fromPair (key,value) = + map ( (*value) . fromPair ) . filter (\(_,upper) -> key == upper) + acceptedKeys = NL.toList $ generateBounds log10 + calculatePossibleBound fromPair = + sum . + concatMap (\pair -> matching fromPair pair $ createBracketPairs acceptedKeys) $ + Map.toList histogram + +aesonEnumOpts :: Aeson.Options +aesonEnumOpts = Aeson.defaultOptions + { Aeson.tagSingleConstructors = True + } + + +-- | TH at the end because it needs mostly everything to be declared first +deriveSafeBuildable ''UtxoStatistics +deriveSafeBuildable ''HistogramBar From 166665c4141b782935a0cc852ee30865c5401017 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 20 Aug 2018 18:12:42 +0200 Subject: [PATCH 11/14] [CO-347] Change computeUtxoStatistics API to take [Utxo] This is more semantically correct and type-safe than taking a raw list of 'Word64'. This way, we also get documentation for free simply by looking at the function signature and also makes calls for callers simpler (provided they have a list of available utxos, but why would they call the function if they hadn't? :) ) --- wallet-new/integration/TransactionSpecs.hs | 15 +++++++++++-- .../Cardano/Wallet/API/V1/Handlers/Wallets.hs | 21 ++++++------------- .../Cardano/Wallet/Types/UtxoStatistics.hs | 19 +++++++++++++---- 3 files changed, 34 insertions(+), 21 deletions(-) diff --git a/wallet-new/integration/TransactionSpecs.hs b/wallet-new/integration/TransactionSpecs.hs index aeb7f0671fb..360e908f10c 100644 --- a/wallet-new/integration/TransactionSpecs.hs +++ b/wallet-new/integration/TransactionSpecs.hs @@ -8,13 +8,17 @@ import Universum import Cardano.Wallet.API.V1.Errors hiding (describe) import Cardano.Wallet.Client.Http import Control.Lens -import qualified Pos.Core as Core import Test.Hspec import Control.Concurrent (threadDelay) import Text.Show.Pretty (ppShow) import Util +import qualified Data.Map.Strict as Map +import qualified Pos.Core as Core +import qualified Pos.Core.Txp as Txp + + {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} log :: MonadIO m => Text -> m () @@ -216,7 +220,14 @@ transactionSpecs wRef wc = void $ postTransaction wc (payment 1) threadDelay 120000000 + let txIn = Txp.TxInUnknown 0 "test" + let txOut = Txp.TxOutAux Txp.TxOut + { Txp.txOutAddress = unV1 (addrId toAddr) + , Txp.txOutValue = Core.mkCoin 1 + } + let utxos = [Map.fromList [(txIn, txOut)]] + eresp <- getUtxoStatistics wc (walId wallet) utxoStatistics <- fmap wrData eresp `shouldPrism` _Right - let utxoStatisticsExpected = computeUtxoStatistics log10 [1] + let utxoStatisticsExpected = computeUtxoStatistics log10 utxos utxoStatistics `shouldBe` utxoStatisticsExpected diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs index 109935d28ba..ce3e345c86e 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Handlers/Wallets.hs @@ -2,22 +2,18 @@ module Cardano.Wallet.API.V1.Handlers.Wallets where import Universum +import Servant + import Cardano.Wallet.API.Request import Cardano.Wallet.API.Response import Cardano.Wallet.API.V1.Types as V1 -import qualified Cardano.Wallet.API.V1.Wallets as Wallets - import Cardano.Wallet.WalletLayer (PassiveWalletLayer (..)) -import qualified Cardano.Wallet.WalletLayer.Types as WalletLayer +import qualified Cardano.Wallet.API.V1.Wallets as Wallets import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as KernelIxSet +import qualified Cardano.Wallet.WalletLayer.Types as WalletLayer import qualified Data.IxSet.Typed as IxSet -import Pos.Chain.Txp (Utxo) -import Pos.Core.Common (Coin (..)) -import Pos.Core.Txp (TxOut (..), TxOutAux (..)) -import qualified Data.Map.Strict as M (elems) -import Servant -- | All the @Servant@ handlers for wallet-specific operations. handlers :: PassiveWalletLayer IO -> ServerT Wallets.API Handler @@ -110,10 +106,5 @@ getUtxoStatistics pwl wid = do res <- liftIO $ WalletLayer.getUtxos pwl wid case res of Left e -> throwM e - Right w -> do - let extractValue :: TxOutAux -> Word64 - extractValue = getCoin . txOutValue . toaOut - let utxosCoinValuesForAllAccounts :: [(Account, Utxo)] -> [Word64] - utxosCoinValuesForAllAccounts = - concatMap (\pair -> map extractValue (M.elems $ snd pair) ) - return $ single (V1.computeUtxoStatistics V1.log10 $ utxosCoinValuesForAllAccounts w) + Right w -> + return $ single $ V1.computeUtxoStatistics V1.log10 (map snd w) diff --git a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs index f26183b2323..7016febdabb 100644 --- a/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs +++ b/wallet-new/src/Cardano/Wallet/Types/UtxoStatistics.hs @@ -34,6 +34,9 @@ import Test.QuickCheck (Arbitrary (..), arbitrary, choose, elements, infiniteListOf, shuffle) import Cardano.Wallet.API.V1.Swagger.Example (Example) +import Pos.Chain.Txp (Utxo) +import Pos.Core.Common (Coin (..)) +import Pos.Core.Txp (TxOut (..), TxOutAux (..)) import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), deriveSafeBuildable) @@ -184,11 +187,19 @@ log10 = Log10 {-# INLINE log10 #-} -- | Compute UtxoStatistics from a bunch of UTXOs -computeUtxoStatistics :: BoundType -> [Word64] -> UtxoStatistics -computeUtxoStatistics btype = L.fold $ UtxoStatistics - <$> foldBuckets (generateBounds btype) - <*> L.sum +computeUtxoStatistics :: BoundType -> [Utxo] -> UtxoStatistics +computeUtxoStatistics btype = + L.fold foldStatistics . concatMap getCoins where + getCoins :: Utxo -> [Word64] + getCoins = + map (getCoin . txOutValue . toaOut) . Map.elems + + foldStatistics :: L.Fold Word64 UtxoStatistics + foldStatistics = UtxoStatistics + <$> foldBuckets (generateBounds btype) + <*> L.sum + foldBuckets :: NonEmpty Word64 -> L.Fold Word64 [HistogramBar] foldBuckets bounds = let From 8b23234248cf1ebfde1fa938dfe671630cde532c Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 20 Aug 2018 18:29:33 +0200 Subject: [PATCH 12/14] [CO-347] Re-generate pkgs/default.nix --- pkgs/default.nix | 23 ----------------------- 1 file changed, 23 deletions(-) diff --git a/pkgs/default.nix b/pkgs/default.nix index 03b1beec623..c7177cfb365 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -17549,21 +17549,17 @@ license = stdenv.lib.licenses.mit; , cardano-sl-chain , cardano-sl-client , cardano-sl-core -, cardano-sl-core-test , cardano-sl-crypto -, cardano-sl-crypto-test , cardano-sl-db , cardano-sl-generator , cardano-sl-infra , cardano-sl-networking , cardano-sl-node-ipc , cardano-sl-util -, cardano-sl-util-test , containers , cpphs , cryptonite , data-default -, deepseq , directory , dlist , ekg-core @@ -17577,7 +17573,6 @@ license = stdenv.lib.licenses.mit; , log-warper , memory , monad-control -, MonadRandom , mtl , QuickCheck , random @@ -17688,41 +17683,27 @@ libraryToolDepends = [ cpphs ]; testHaskellDepends = [ -aeson base -bytestring -cardano-crypto cardano-sl cardano-sl-chain cardano-sl-client cardano-sl-core -cardano-sl-core-test cardano-sl-crypto -cardano-sl-crypto-test cardano-sl-db cardano-sl-generator cardano-sl-infra cardano-sl-util -cardano-sl-util-test -containers data-default -deepseq ekg-core ether formatting hspec lens log-warper -MonadRandom mtl QuickCheck -safe-exceptions -safecopy -serokell-util -servant-server stm universum -unordered-containers ]; testToolDepends = [ cpphs @@ -17762,7 +17743,6 @@ license = stdenv.lib.licenses.mit; , cardano-sl-util , cardano-sl-util-test , cardano-sl-wallet -, cardano-sl-wallet-test , cassava , conduit , connection @@ -17876,7 +17856,6 @@ cardano-sl-networking cardano-sl-node-ipc cardano-sl-util cardano-sl-wallet -cardano-sl-wallet-test conduit connection containers @@ -18003,7 +17982,6 @@ formatting generic-arbitrary hedgehog hspec -ixset-typed lens log-warper mtl @@ -18034,7 +18012,6 @@ base bytestring cardano-sl-client cardano-sl-core -cardano-sl-db cardano-sl-wallet cassava connection From dd4b54a4d7f34717f3bb620311ed37a6f7dd09b9 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 20 Aug 2018 23:20:27 -0600 Subject: [PATCH 13/14] [CO-347] Fix test suite build --- wallet/cardano-sl-wallet.cabal | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/wallet/cardano-sl-wallet.cabal b/wallet/cardano-sl-wallet.cabal index 69fb03d37d8..fda934cf959 100644 --- a/wallet/cardano-sl-wallet.cabal +++ b/wallet/cardano-sl-wallet.cabal @@ -236,27 +236,44 @@ test-suite cardano-wallet-test type: exitcode-stdio-1.0 build-depends: base - , QuickCheck + , aeson + , bytestring + , cardano-crypto , cardano-sl , cardano-sl-chain , cardano-sl-client , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto , cardano-sl-db , cardano-sl-generator , cardano-sl-infra , cardano-sl-util + , cardano-sl-util-test + , cardano-sl-wallet + , cardano-sl-crypto-test + , containers + , safe-exceptions , data-default + , servant + , servant-server + , deepseq , ekg-core , ether , formatting + , formatting , hspec , lens , log-warper + , MonadRandom , mtl + , pvss + , QuickCheck + , safecopy + , serokell-util , stm - , formatting , universum >= 0.1.11 + , unordered-containers hs-source-dirs: test default-language: Haskell2010 From 3e5df1e1e376abe21b570f6f0f138d631e45322f Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 20 Aug 2018 23:27:59 -0600 Subject: [PATCH 14/14] [CO-347] pkgs --- pkgs/default.nix | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/pkgs/default.nix b/pkgs/default.nix index c7177cfb365..ab4a1be39db 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -17549,17 +17549,21 @@ license = stdenv.lib.licenses.mit; , cardano-sl-chain , cardano-sl-client , cardano-sl-core +, cardano-sl-core-test , cardano-sl-crypto +, cardano-sl-crypto-test , cardano-sl-db , cardano-sl-generator , cardano-sl-infra , cardano-sl-networking , cardano-sl-node-ipc , cardano-sl-util +, cardano-sl-util-test , containers , cpphs , cryptonite , data-default +, deepseq , directory , dlist , ekg-core @@ -17573,7 +17577,9 @@ license = stdenv.lib.licenses.mit; , log-warper , memory , monad-control +, MonadRandom , mtl +, pvss , QuickCheck , random , reflection @@ -17683,27 +17689,43 @@ libraryToolDepends = [ cpphs ]; testHaskellDepends = [ +aeson base +bytestring +cardano-crypto cardano-sl cardano-sl-chain cardano-sl-client cardano-sl-core +cardano-sl-core-test cardano-sl-crypto +cardano-sl-crypto-test cardano-sl-db cardano-sl-generator cardano-sl-infra cardano-sl-util +cardano-sl-util-test +containers data-default +deepseq ekg-core ether formatting hspec lens log-warper +MonadRandom mtl +pvss QuickCheck +safe-exceptions +safecopy +serokell-util +servant +servant-server stm universum +unordered-containers ]; testToolDepends = [ cpphs