fixup: combine

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

lib/core/src/Cardano/Pool/DB/MVar.hs

@@ -97,6 +97,8 @@ newDBLayer = do
 
         , putPoolMetadata = error "todo"
 
+        , readPoolMetadata = error "todo"
+
         , atomically = id
         }
 

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
+        }

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