From 6db6678e52d3f94e1954cfefc24536487963ce24 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 02:47:02 +0000 Subject: [PATCH 01/15] Reformat code to comply with coding standards. --- .../src/Cardano/Wallet/Shelley/Pools.hs | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index fa263d5874e..2623bfd12c3 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -157,24 +157,24 @@ newStakePoolLayer gp nl db = StakePoolLayer :: Coin -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool] _listPools userStake = do - tip <- liftIO getTip - lsqData <- combineLsqData <$> stakeDistribution nl tip userStake - chainData <- liftIO $ readDBPoolData db - return - . sortOn (Down . (view (#metrics . #nonMyopicMemberRewards))) - . map snd - . Map.toList - $ combineDbAndLsqData (slotParams gp) lsqData chainData + tip <- liftIO getTip + lsqData <- combineLsqData <$> stakeDistribution nl tip userStake + chainData <- liftIO $ readDBPoolData db + return + . sortOn (Down . (view (#metrics . #nonMyopicMemberRewards))) + . map snd + . Map.toList + $ combineDbAndLsqData (slotParams gp) lsqData chainData -- Note: We shouldn't have to do this conversion. el = getEpochLength gp gh = getGenesisBlockHash gp - getTip = fmap (toPoint gh el) . liftIO $ unsafeRunExceptT $ currentNodeTip nl + getTip = fmap (toPoint gh el) . liftIO $ + unsafeRunExceptT $ currentNodeTip nl -- -- Data Combination functions -- --- -- | Stake pool-related data that has been read from the node using a local -- state query. @@ -293,7 +293,7 @@ combineChainData combineChainData = Map.merge registeredNoProductions notRegisteredButProducing bothPresent where - registeredNoProductions = traverseMissing $ \_k cert -> + registeredNoProductions = traverseMissing $ \_k cert -> pure (cert, Quantity 0) -- Ignore blocks produced by BFT nodes. From 9a706d6ed78493c9ccfa1167e8dc363d34aed17b Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 02:44:32 +0000 Subject: [PATCH 02/15] Rename function to `readPoolDbData`. Justification: name is consistent with type. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 2623bfd12c3..91847d3d43a 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -159,7 +159,7 @@ newStakePoolLayer gp nl db = StakePoolLayer _listPools userStake = do tip <- liftIO getTip lsqData <- combineLsqData <$> stakeDistribution nl tip userStake - chainData <- liftIO $ readDBPoolData db + chainData <- liftIO $ readPoolDbData db return . sortOn (Down . (view (#metrics . #nonMyopicMemberRewards))) . map snd @@ -304,10 +304,10 @@ combineChainData = -- NOTE: If performance becomes a problem, we could try replacing all -- the individual DB queries, and combbination functions with a single -- hand-written Sqlite query. -readDBPoolData +readPoolDbData :: DBLayer IO -> IO (Map PoolId PoolDbData) -readDBPoolData DBLayer {..} = atomically $ do +readPoolDbData DBLayer {..} = atomically $ do pools <- listRegisteredPools registrationStatuses <- mapM readPoolLifeCycleStatus pools let certMap = Map.fromList From 6113c6dff2dd8f1d5093ae59f99f2524e5f59326 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 02:45:34 +0000 Subject: [PATCH 03/15] Rename function to `certificatesFromLifeCycleStatus`. Justification: name is consistent with type. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 91847d3d43a..e9118c5da3a 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -313,16 +313,16 @@ readPoolDbData DBLayer {..} = atomically $ do let certMap = Map.fromList [ (poolId, certs) | (poolId, Just certs) <- zip pools - (certificatesFromRegistrationStatus <$> registrationStatuses) + (certificatesFromLifeCycleStatus <$> registrationStatuses) ] prodMap <- readTotalProduction metaMap <- readPoolMetadata return $ Map.map (lookupMetaIn metaMap) (combineChainData certMap prodMap) where - certificatesFromRegistrationStatus + certificatesFromLifeCycleStatus :: PoolLifeCycleStatus -> Maybe (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) - certificatesFromRegistrationStatus = \case + certificatesFromLifeCycleStatus = \case PoolNotRegistered -> Nothing PoolRegistered regCert -> From 6016b84e7c07b9b2c4a4d6bf3ea66cf0688c41eb Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 02:51:19 +0000 Subject: [PATCH 04/15] Rename value to `dbData`. Justification: name is consistent with type. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index e9118c5da3a..2fb7e841cd9 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -159,12 +159,12 @@ newStakePoolLayer gp nl db = StakePoolLayer _listPools userStake = do tip <- liftIO getTip lsqData <- combineLsqData <$> stakeDistribution nl tip userStake - chainData <- liftIO $ readPoolDbData db + dbData <- liftIO $ readPoolDbData db return . sortOn (Down . (view (#metrics . #nonMyopicMemberRewards))) . map snd . Map.toList - $ combineDbAndLsqData (slotParams gp) lsqData chainData + $ combineDbAndLsqData (slotParams gp) lsqData dbData -- Note: We shouldn't have to do this conversion. el = getEpochLength gp From 71977dc8a770f1a3f5faa1c809a1e4f3a7f70e6a Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 02:58:19 +0000 Subject: [PATCH 05/15] Revise comments for `readPool{Registration,Retirement}`. Explain to the reader might they might want to look at `readPoolLifeCycleStatus`. --- lib/core/src/Cardano/Pool/DB.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index ca2d8a53c2b..d77dd60ba48 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -130,7 +130,7 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -- Note that a pool may also have other certificates associated with it -- that affect its current lifecycle status. -- - -- See 'readPoolLifeCycleStatus'. + -- See 'readPoolLifeCycleStatus' for a complete picture. , putPoolRetirement :: CertificatePublicationTime @@ -147,7 +147,7 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -- Note that a pool may also have other certificates associated with it -- that affect its current lifecycle status. -- - -- See 'readPoolLifeCycleStatus'. + -- See 'readPoolLifeCycleStatus' for a complete picture. , unfetchedPoolMetadataRefs :: Int From 934a43fd76ed5c80022449591e8564be798677ce Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 03:15:55 +0000 Subject: [PATCH 06/15] Use `where` instead of `let`. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 2fb7e841cd9..6708ca53bfa 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -337,11 +337,10 @@ readPoolDbData DBLayer {..} = atomically $ do ) -> PoolDbData lookupMetaIn m ((registrationCert, mRetirementCert), n) = - let - metaHash = snd <$> poolMetadata registrationCert - meta = flip Map.lookup m =<< metaHash - in - PoolDbData registrationCert mRetirementCert n meta + PoolDbData registrationCert mRetirementCert n meta + where + metaHash = snd <$> poolMetadata registrationCert + meta = flip Map.lookup m =<< metaHash -- -- Monitoring stake pool From 01cd9be8e5f0cb42aebc248f24c218609a5d8012 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 03:25:43 +0000 Subject: [PATCH 07/15] Merge function `lookupMetaIn` into `combineChainData`. --- .../src/Cardano/Wallet/Shelley/Pools.hs | 45 ++++++++++--------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 6708ca53bfa..36c8128d873 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -282,16 +282,19 @@ combineLsqData NodePoolLsqData{nOpt, rewards, stake} = bothPresent = zipWithMatched $ \_k s r -> PoolLsqData r s (sat s) -- | Combines all the chain-following data into a single map --- (doesn't include metadata) combineChainData - :: Map PoolId (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) + :: Map StakePoolMetadataHash StakePoolMetadata + -> Map PoolId (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) -> Map PoolId (Quantity "block" Word64) - -> Map PoolId - ( (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) - , Quantity "block" Word64 - ) -combineChainData = - Map.merge registeredNoProductions notRegisteredButProducing bothPresent + -> Map PoolId PoolDbData +combineChainData metaMap certMap prodMap = + Map.map (lookupMetaIn metaMap) $ + Map.merge + registeredNoProductions + notRegisteredButProducing + bothPresent + certMap + prodMap where registeredNoProductions = traverseMissing $ \_k cert -> pure (cert, Quantity 0) @@ -301,6 +304,18 @@ combineChainData = bothPresent = zipWithMatched $ const (,) + lookupMetaIn + :: Map StakePoolMetadataHash StakePoolMetadata + -> ( (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) + , Quantity "block" Word64 + ) + -> PoolDbData + lookupMetaIn m ((registrationCert, mRetirementCert), n) = + PoolDbData registrationCert mRetirementCert n meta + where + metaHash = snd <$> poolMetadata registrationCert + meta = flip Map.lookup m =<< metaHash + -- NOTE: If performance becomes a problem, we could try replacing all -- the individual DB queries, and combbination functions with a single -- hand-written Sqlite query. @@ -317,7 +332,7 @@ readPoolDbData DBLayer {..} = atomically $ do ] prodMap <- readTotalProduction metaMap <- readPoolMetadata - return $ Map.map (lookupMetaIn metaMap) (combineChainData certMap prodMap) + return $ combineChainData metaMap certMap prodMap where certificatesFromLifeCycleStatus :: PoolLifeCycleStatus @@ -330,18 +345,6 @@ readPoolDbData DBLayer {..} = atomically $ do PoolRegisteredAndRetired regCert retCert -> Just (regCert, Just retCert) - lookupMetaIn - :: Map StakePoolMetadataHash StakePoolMetadata - -> ( (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) - , Quantity "block" Word64 - ) - -> PoolDbData - lookupMetaIn m ((registrationCert, mRetirementCert), n) = - PoolDbData registrationCert mRetirementCert n meta - where - metaHash = snd <$> poolMetadata registrationCert - meta = flip Map.lookup m =<< metaHash - -- -- Monitoring stake pool -- From 69cc23e7531c442890f1ae70f6509e303a736237 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 03:59:11 +0000 Subject: [PATCH 08/15] Add functions `getPool{Registration,Retirement}Status`. --- lib/core/src/Cardano/Wallet/Primitive/Types.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index 434c83a56be..02205fcba31 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -66,6 +66,8 @@ module Cardano.Wallet.Primitive.Types , PoolRegistrationCertificate (..) , PoolRetirementCertificate (..) , PoolCertificate (..) + , getPoolRegistrationCertificate + , getPoolRetirementCertificate -- * Coin , Coin (..) @@ -1823,6 +1825,20 @@ data PoolLifeCycleStatus -- Records the latest registration and retirement certificates. deriving (Eq, Show) +getPoolRegistrationCertificate + :: PoolLifeCycleStatus -> Maybe PoolRegistrationCertificate +getPoolRegistrationCertificate = \case + PoolNotRegistered -> Nothing + PoolRegistered c -> Just c + PoolRegisteredAndRetired c _ -> Just c + +getPoolRetirementCertificate + :: PoolLifeCycleStatus -> Maybe PoolRetirementCertificate +getPoolRetirementCertificate = \case + PoolNotRegistered -> Nothing + PoolRegistered _ -> Nothing + PoolRegisteredAndRetired _ c -> Just c + {------------------------------------------------------------------------------- Polymorphic Types -------------------------------------------------------------------------------} From e6e27c0fee1284feb0c432b92f54742e9456a137 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 04:03:01 +0000 Subject: [PATCH 09/15] Simplify type of `combineChainData`. --- .../src/Cardano/Wallet/Shelley/Pools.hs | 42 ++++++++----------- 1 file changed, 18 insertions(+), 24 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 36c8128d873..63de94fd4df 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -62,6 +63,8 @@ import Cardano.Wallet.Primitive.Types , StakePoolMetadataHash , StakePoolMetadataUrl , epochStartTime + , getPoolRegistrationCertificate + , getPoolRetirementCertificate , slotParams ) import Cardano.Wallet.Shelley.Compatibility @@ -284,16 +287,17 @@ combineLsqData NodePoolLsqData{nOpt, rewards, stake} = -- | Combines all the chain-following data into a single map combineChainData :: Map StakePoolMetadataHash StakePoolMetadata - -> Map PoolId (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) + -> Map PoolId PoolRegistrationCertificate + -> Map PoolId PoolRetirementCertificate -> Map PoolId (Quantity "block" Word64) -> Map PoolId PoolDbData -combineChainData metaMap certMap prodMap = +combineChainData metaMap registrationMap retirementMap prodMap = Map.map (lookupMetaIn metaMap) $ Map.merge registeredNoProductions notRegisteredButProducing bothPresent - certMap + registrationMap prodMap where registeredNoProductions = traverseMissing $ \_k cert -> @@ -306,15 +310,15 @@ combineChainData metaMap certMap prodMap = lookupMetaIn :: Map StakePoolMetadataHash StakePoolMetadata - -> ( (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) - , Quantity "block" Word64 - ) + -> (PoolRegistrationCertificate, Quantity "block" Word64) -> PoolDbData - lookupMetaIn m ((registrationCert, mRetirementCert), n) = + lookupMetaIn m (registrationCert, n) = PoolDbData registrationCert mRetirementCert n meta where metaHash = snd <$> poolMetadata registrationCert meta = flip Map.lookup m =<< metaHash + mRetirementCert = + Map.lookup (view #poolId registrationCert) retirementMap -- NOTE: If performance becomes a problem, we could try replacing all -- the individual DB queries, and combbination functions with a single @@ -325,25 +329,15 @@ readPoolDbData readPoolDbData DBLayer {..} = atomically $ do pools <- listRegisteredPools registrationStatuses <- mapM readPoolLifeCycleStatus pools - let certMap = Map.fromList - [ (poolId, certs) - | (poolId, Just certs) <- zip pools - (certificatesFromLifeCycleStatus <$> registrationStatuses) - ] + let mkCertificateMap + :: forall a . (PoolLifeCycleStatus -> Maybe a) -> Map PoolId a + mkCertificateMap f = Map.fromList + [(p, c) | (p, Just c) <- zip pools (f <$> registrationStatuses)] + let registrationMap = mkCertificateMap getPoolRegistrationCertificate + let retirementMap = mkCertificateMap getPoolRetirementCertificate prodMap <- readTotalProduction metaMap <- readPoolMetadata - return $ combineChainData metaMap certMap prodMap - where - certificatesFromLifeCycleStatus - :: PoolLifeCycleStatus - -> Maybe (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) - certificatesFromLifeCycleStatus = \case - PoolNotRegistered -> - Nothing - PoolRegistered regCert -> - Just (regCert, Nothing) - PoolRegisteredAndRetired regCert retCert -> - Just (regCert, Just retCert) + return $ combineChainData metaMap registrationMap retirementMap prodMap -- -- Monitoring stake pool From 43cd573bfe5b3bbcf3098c1cacc12536eb22eeb7 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 04:04:10 +0000 Subject: [PATCH 10/15] Don't re-pass `metaMap` argument to `lookupMetaIn` function. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 63de94fd4df..c28b118a8db 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -292,7 +292,7 @@ combineChainData -> Map PoolId (Quantity "block" Word64) -> Map PoolId PoolDbData combineChainData metaMap registrationMap retirementMap prodMap = - Map.map (lookupMetaIn metaMap) $ + Map.map lookupMetaIn $ Map.merge registeredNoProductions notRegisteredButProducing @@ -309,14 +309,13 @@ combineChainData metaMap registrationMap retirementMap prodMap = bothPresent = zipWithMatched $ const (,) lookupMetaIn - :: Map StakePoolMetadataHash StakePoolMetadata - -> (PoolRegistrationCertificate, Quantity "block" Word64) + :: (PoolRegistrationCertificate, Quantity "block" Word64) -> PoolDbData - lookupMetaIn m (registrationCert, n) = + lookupMetaIn (registrationCert, n) = PoolDbData registrationCert mRetirementCert n meta where metaHash = snd <$> poolMetadata registrationCert - meta = flip Map.lookup m =<< metaHash + meta = flip Map.lookup metaMap =<< metaHash mRetirementCert = Map.lookup (view #poolId registrationCert) retirementMap From 470618cde3e59c15889e1da3b52256fc0441cf20 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 04:05:07 +0000 Subject: [PATCH 11/15] Rename function to `mkPoolDbData`. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index c28b118a8db..b179517f24f 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -292,7 +292,7 @@ combineChainData -> Map PoolId (Quantity "block" Word64) -> Map PoolId PoolDbData combineChainData metaMap registrationMap retirementMap prodMap = - Map.map lookupMetaIn $ + Map.map mkPoolDbData $ Map.merge registeredNoProductions notRegisteredButProducing @@ -308,10 +308,10 @@ combineChainData metaMap registrationMap retirementMap prodMap = bothPresent = zipWithMatched $ const (,) - lookupMetaIn + mkPoolDbData :: (PoolRegistrationCertificate, Quantity "block" Word64) -> PoolDbData - lookupMetaIn (registrationCert, n) = + mkPoolDbData (registrationCert, n) = PoolDbData registrationCert mRetirementCert n meta where metaHash = snd <$> poolMetadata registrationCert From a81812e2ffafc1ee19abe63c19ecabf05218fe5d Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 04:06:48 +0000 Subject: [PATCH 12/15] Use applicative style when calling `combineChainData`. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index b179517f24f..dfc951ac6d8 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -286,12 +286,12 @@ combineLsqData NodePoolLsqData{nOpt, rewards, stake} = -- | Combines all the chain-following data into a single map combineChainData - :: Map StakePoolMetadataHash StakePoolMetadata - -> Map PoolId PoolRegistrationCertificate + :: Map PoolId PoolRegistrationCertificate -> Map PoolId PoolRetirementCertificate -> Map PoolId (Quantity "block" Word64) + -> Map StakePoolMetadataHash StakePoolMetadata -> Map PoolId PoolDbData -combineChainData metaMap registrationMap retirementMap prodMap = +combineChainData registrationMap retirementMap prodMap metaMap = Map.map mkPoolDbData $ Map.merge registeredNoProductions @@ -332,11 +332,11 @@ readPoolDbData DBLayer {..} = atomically $ do :: forall a . (PoolLifeCycleStatus -> Maybe a) -> Map PoolId a mkCertificateMap f = Map.fromList [(p, c) | (p, Just c) <- zip pools (f <$> registrationStatuses)] - let registrationMap = mkCertificateMap getPoolRegistrationCertificate - let retirementMap = mkCertificateMap getPoolRetirementCertificate - prodMap <- readTotalProduction - metaMap <- readPoolMetadata - return $ combineChainData metaMap registrationMap retirementMap prodMap + combineChainData + (mkCertificateMap getPoolRegistrationCertificate) + (mkCertificateMap getPoolRetirementCertificate) + <$> readTotalProduction + <*> readPoolMetadata -- -- Monitoring stake pool From 98f39b916196cdaee28473b553a0e03e45a867de Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 04:12:53 +0000 Subject: [PATCH 13/15] Revise comment for `readDbPoolData`. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index dfc951ac6d8..5184a1bb25a 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -320,8 +320,8 @@ combineChainData registrationMap retirementMap prodMap metaMap = Map.lookup (view #poolId registrationCert) retirementMap -- NOTE: If performance becomes a problem, we could try replacing all --- the individual DB queries, and combbination functions with a single --- hand-written Sqlite query. +-- the individual database queries and combining functions with a single +-- hand-written database query. readPoolDbData :: DBLayer IO -> IO (Map PoolId PoolDbData) From ca70b0d5017081c3c87a9c237af64f4f8cc919f6 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 04:13:51 +0000 Subject: [PATCH 14/15] Unwrap type signature for function `readPoolDbData`. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 5184a1bb25a..d1b97f694c5 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -322,9 +322,7 @@ combineChainData registrationMap retirementMap prodMap metaMap = -- NOTE: If performance becomes a problem, we could try replacing all -- the individual database queries and combining functions with a single -- hand-written database query. -readPoolDbData - :: DBLayer IO - -> IO (Map PoolId PoolDbData) +readPoolDbData :: DBLayer IO -> IO (Map PoolId PoolDbData) readPoolDbData DBLayer {..} = atomically $ do pools <- listRegisteredPools registrationStatuses <- mapM readPoolLifeCycleStatus pools From 52a9399f87af059e76a4fd4c281ea0a2eefe9944 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 13 Jul 2020 04:19:09 +0000 Subject: [PATCH 15/15] Rename value to `lifeCycleStatuses`. Justification: name is consistent with type. --- lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index d1b97f694c5..787a0d6ec97 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -325,11 +325,11 @@ combineChainData registrationMap retirementMap prodMap metaMap = readPoolDbData :: DBLayer IO -> IO (Map PoolId PoolDbData) readPoolDbData DBLayer {..} = atomically $ do pools <- listRegisteredPools - registrationStatuses <- mapM readPoolLifeCycleStatus pools + lifeCycleStatuses <- mapM readPoolLifeCycleStatus pools let mkCertificateMap :: forall a . (PoolLifeCycleStatus -> Maybe a) -> Map PoolId a mkCertificateMap f = Map.fromList - [(p, c) | (p, Just c) <- zip pools (f <$> registrationStatuses)] + [(p, c) | (p, Just c) <- zip pools (f <$> lifeCycleStatuses)] combineChainData (mkCertificateMap getPoolRegistrationCertificate) (mkCertificateMap getPoolRetirementCertificate)