From a6bcca778c942be3f190370f7e4304c7b29f5d0c Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Thu, 18 Jun 2020 15:15:57 +0200 Subject: [PATCH] fixup: combine --- lib/core/src/Cardano/Pool/DB.hs | 3 ++ lib/core/src/Cardano/Pool/DB/MVar.hs | 2 + lib/core/src/Cardano/Pool/DB/Sqlite.hs | 17 +++++++++ .../src/Cardano/Wallet/Shelley/Pools.hs | 38 +++++++++++++------ 4 files changed, 49 insertions(+), 11 deletions(-) diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index b4e89363e2c..cdabdd0c2d0 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -132,6 +132,9 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -> stm () -- ^ Store metadata fetched from a remote server. + , readPoolMetadata + :: stm (Map StakePoolMetadataHash StakePoolMetadata) + , readSystemSeed :: stm StdGen -- ^ Read the seed assigned to this particular database. The seed is diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index b12fe41e972..4adcea78221 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -97,6 +97,8 @@ newDBLayer = do , putPoolMetadata = error "todo" + , readPoolMetadata = error "todo" + , atomically = id } diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index f896a5abb9e..9abaf49b914 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -50,6 +51,7 @@ import Cardano.Wallet.Primitive.Types , PoolRegistrationCertificate (..) , SlotId (..) , StakePoolMetadata (..) + , StakePoolMetadataHash ) import Cardano.Wallet.Unsafe ( unsafeMkPercentage ) @@ -273,6 +275,10 @@ newDBLayer trace fp = do let StakePoolMetadata{ticker,name,description,homepage} = metadata putMany [PoolMetadata hash poolId name ticker description homepage] + , readPoolMetadata = do + Map.fromList . map (fromPoolMeta . entityVal) + <$> selectList [] [] + , listRegisteredPools = do fmap (poolRegistrationPoolId . entityVal) <$> selectList [ ] [ Desc PoolRegistrationSlot ] @@ -390,3 +396,14 @@ fromStakeDistribution distribution = ( stakeDistributionPoolId distribution , Quantity (stakeDistributionStake distribution) ) + +fromPoolMeta + :: PoolMetadata + -> (StakePoolMetadataHash, StakePoolMetadata) +fromPoolMeta meta = (poolMetadataHash meta,) $ + StakePoolMetadata + { ticker = poolMetadataTicker meta + , name = poolMetadataName meta + , description = poolMetadataDescription meta + , homepage = poolMetadataHomepage meta + } diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index d3738205da0..dfe5dbd5121 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -141,7 +141,7 @@ data PoolLsqMetrics = PoolLsqMetrics -- | Top level combine-function that merges chain and LSQ data. combineChainAndLsqData :: Map PoolId PoolLsqMetrics - -> Map PoolId (PoolRegistrationCertificate, Quantity "block" Word64) + -> Map PoolId (PoolRegistrationCertificate, Quantity "block" Word64, Maybe StakePoolMetadata) -> Map PoolId Api.ApiStakePool combineChainAndLsqData = Map.merge lsqButNoChain chainButNoLsq bothPresent @@ -158,7 +158,7 @@ combineChainAndLsqData = mkApiPool :: PoolId -> PoolLsqMetrics - -> Maybe (PoolRegistrationCertificate, Quantity "block" Word64) + -> Maybe (PoolRegistrationCertificate, Quantity "block" Word64, Maybe StakePoolMetadata) -> Api.ApiStakePool mkApiPool pid @@ -171,15 +171,20 @@ combineChainAndLsqData = , Api.relativeStake = Quantity pstk , Api.saturation = psat , Api.producedBlocks = maybe (Quantity 0) - (mapQ fromIntegral . snd) dbData + (mapQ fromIntegral . second) dbData } - , Api.metadata = Nothing -- TODO: Implement - , Api.cost = mapQ fromIntegral . poolCost . fst <$> dbData - , Api.margin = Quantity . poolMargin . fst <$> dbData + , Api.metadata = dbData >>= third >>= (return . ApiT) + , Api.cost = mapQ fromIntegral . poolCost . first <$> dbData + , Api.margin = Quantity . poolMargin . first <$> dbData } mapQ f (Quantity x) = Quantity $ f x + -- TODO: Add proper record + first (x,_,_) = x + second (_,x,_) = x + third (_,_,x) = x + -- | Combines all the LSQ data into a single map. -- @@ -263,7 +268,6 @@ newStakePoolLayer gp nl db = StakePoolLayer -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool] _listPools DBLayer{..} s = do pt <- liftIO getTip - -- TODO: We need to make sure th rawLsqData <- stakeDistribution nl pt s let lsqData = combineLsqData rawLsqData chainData <- liftIO readChainPoolData @@ -277,14 +281,26 @@ newStakePoolLayer gp nl db = StakePoolLayer -- certificates at once from the DB? readChainPoolData :: IO (Map PoolId - (PoolRegistrationCertificate, Quantity "block" Word64)) + (PoolRegistrationCertificate, Quantity "block" Word64, Maybe StakePoolMetadata)) readChainPoolData = do - (certs, prod) <- atomically $ do + (certs, prod, m) <- atomically $ do pools <- listRegisteredPools x <- mapM (\p -> ((fmap (p,)) <$> readPoolRegistration p) ) pools prod <- readTotalProduction - return (Map.fromList $ catMaybes x, prod) - return $ combineDBData certs prod + m <- readPoolMetadata + return (Map.fromList $ catMaybes x, prod, m) + return $ Map.map (lookupMetaIn m) (combineDBData certs prod) + where + lookupMetaIn + :: Map StakePoolMetadataHash StakePoolMetadata + -> (PoolRegistrationCertificate, Quantity "block" Word64) + -> (PoolRegistrationCertificate, Quantity "block" Word64, Maybe StakePoolMetadata) + lookupMetaIn m (cert, n) = + let + metaHash = snd <$> poolMetadata cert + meta = flip Map.lookup m =<< metaHash + in + (cert, n, meta) -- -- Monitoring stake pool