diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index 74905ca7c33..db4c8123dc6 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -25,6 +25,7 @@ import Cardano.Wallet.Primitive.Types , PoolId , PoolRegistrationCertificate , SlotId (..) + , StakePoolMetadataRef ) import Control.Monad.Fail ( MonadFail ) @@ -116,6 +117,23 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -- map we would get from 'readPoolProduction' because not all registered -- pools have necessarily produced any block yet! + , putPoolMetadataRef + :: PoolId + -> StakePoolMetadataRef + -> stm () + -- ^ Store references to a stake pool metadata found on chain. + + , deletePoolMetadataRef + :: PoolId + -> stm () + -- ^ Remove pool metadata references from the database. + + , peekPoolMetadataRef + :: Int + -> stm [(PoolId, StakePoolMetadataRef)] + -- ^ Peek at some pool metadata ref. Returns at most 'n' elements, where + -- 'n' is the first parameter. + , 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 69923c1ff17..af34266e63d 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -24,7 +24,10 @@ import Cardano.Pool.DB.Model , PoolErr (..) , emptyPoolDatabase , mCleanPoolProduction + , mDeletePoolMetadataRef , mListRegisteredPools + , mPeekPoolMetadataRef + , mPutPoolMetadataRef , mPutPoolProduction , mPutPoolRegistration , mPutStakeDistribution @@ -84,6 +87,15 @@ newDBLayer = do , listRegisteredPools = modifyMVar db (pure . swap . mListRegisteredPools) + , putPoolMetadataRef = \a0 a1 -> + void $ alterPoolDB (const Nothing) db (mPutPoolMetadataRef a0 a1) + + , deletePoolMetadataRef = + void . alterPoolDB (const Nothing) db . mDeletePoolMetadataRef + + , peekPoolMetadataRef = \a0 -> + modifyMVar db (pure . swap . mPeekPoolMetadataRef a0) + , readSystemSeed = modifyMVar db (fmap swap . mReadSystemSeed) diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index 74d457b3cec..10034995a4d 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -41,6 +41,9 @@ module Cardano.Pool.DB.Model , mPutPoolRegistration , mReadPoolRegistration , mListRegisteredPools + , mPutPoolMetadataRef + , mDeletePoolMetadataRef + , mPeekPoolMetadataRef , mReadSystemSeed , mRollbackTo , mReadCursor @@ -55,6 +58,7 @@ import Cardano.Wallet.Primitive.Types , PoolOwner (..) , PoolRegistrationCertificate (..) , SlotId (..) + , StakePoolMetadataRef ) import Data.Foldable ( fold ) @@ -94,6 +98,9 @@ data PoolDatabase = PoolDatabase , metadata :: !(Map (SlotId, PoolId) (Percentage, Quantity "lovelace" Word64)) -- ^ On-chain metadata associated with pools + , metadataRef :: [(PoolId, StakePoolMetadataRef)] + -- ^ On-chain metadata references needed to fetch metadata + , seed :: !SystemSeed -- ^ Store an arbitrary random generator seed } deriving (Generic, Show, Eq) @@ -111,7 +118,7 @@ instance Eq SystemSeed where -- | Produces an empty model pool production database. emptyPoolDatabase :: PoolDatabase -emptyPoolDatabase = PoolDatabase mempty mempty mempty mempty NotSeededYet +emptyPoolDatabase = PoolDatabase mempty mempty mempty mempty mempty NotSeededYet {------------------------------------------------------------------------------- Model Operation Types @@ -206,6 +213,22 @@ mListRegisteredPools :: PoolDatabase -> ([PoolId], PoolDatabase) mListRegisteredPools db@PoolDatabase{metadata} = ( snd <$> Map.keys metadata, db ) +mPutPoolMetadataRef :: PoolId -> StakePoolMetadataRef -> ModelPoolOp () +mPutPoolMetadataRef pid ref db@PoolDatabase{metadataRef} = + ( Right () + , db { metadataRef = (pid, ref):metadataRef } + ) + +mDeletePoolMetadataRef :: PoolId -> ModelPoolOp () +mDeletePoolMetadataRef pid db@PoolDatabase{metadataRef} = + ( Right () + , db { metadataRef = filter ((/= pid) . fst) metadataRef } + ) + +mPeekPoolMetadataRef :: Int -> PoolDatabase -> ([(PoolId, StakePoolMetadataRef)], PoolDatabase) +mPeekPoolMetadataRef n db@PoolDatabase{metadataRef} = + ( take n metadataRef, db ) + mReadSystemSeed :: PoolDatabase -> IO (StdGen, PoolDatabase) @@ -225,7 +248,7 @@ mReadCursor k db@PoolDatabase{pools} = in (Right $ reverse $ limit $ sortDesc allHeaders, db) mRollbackTo :: SlotId -> ModelPoolOp () -mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, seed} = +mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, metadataRef, seed} = let metadata' = Map.mapMaybeWithKey (discardBy id . fst) metadata owners' = Map.restrictKeys owners @@ -238,6 +261,7 @@ mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, seed} = , distributions = Map.mapMaybeWithKey (discardBy epochNumber) distributions , owners = owners' , metadata = metadata' + , metadataRef , seed } ) diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 4152fbfe538..f8b861ec95c 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -46,6 +46,7 @@ import Cardano.Wallet.Primitive.Types , PoolId , PoolRegistrationCertificate (..) , SlotId (..) + , StakePoolMetadataRef (..) ) import Cardano.Wallet.Unsafe ( unsafeMkPercentage ) @@ -74,6 +75,7 @@ import Database.Persist.Sql , deleteWhere , insertMany_ , insert_ + , putMany , selectFirst , selectList , (<.) @@ -214,6 +216,15 @@ newDBLayer trace fp = do fmap (poolRegistrationPoolId . entityVal) <$> selectList [ ] [ Desc PoolRegistrationSlot ] + , putPoolMetadataRef = \poolId ref -> do + putMany [PoolMetadataQueue poolId (metadataURL ref) (metadataHash ref)] + + , deletePoolMetadataRef = \poolId -> do + deleteWhere [PoolMetadataQueuePoolId ==. poolId] + + , peekPoolMetadataRef = \n -> do + fmap (fromPoolMetadataQueue . entityVal) <$> selectList [] [ LimitTo n ] + , rollbackTo = \point -> do let (EpochNo epoch) = epochNumber point deleteWhere [ PoolProductionSlot >. point ] @@ -326,3 +337,10 @@ fromStakeDistribution distribution = ( stakeDistributionPoolId distribution , Quantity (stakeDistributionStake distribution) ) + + +fromPoolMetadataQueue + :: PoolMetadataQueue + -> (PoolId, StakePoolMetadataRef) +fromPoolMetadataQueue (PoolMetadataQueue poolId url hash) = + (poolId, StakePoolMetadataRef url hash) diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index e05b6477a77..38623564073 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -143,6 +143,7 @@ module Cardano.Wallet.Primitive.Types , StakeDistribution (..) , poolIdBytesLength , StakePoolMetadata (..) + , StakePoolMetadataRef (..) , StakePoolOffChainMetadata (..) , StakePoolTicker (..) , sameStakePoolMetadata @@ -583,6 +584,14 @@ data StakePool = StakePool , saturation :: Double } deriving (Show, Generic) +-- | Metadata references, in order to fetch them from a remote. +data StakePoolMetadataRef = StakePoolMetadataRef + { metadataURL :: Text + -- ^ A URL location where to find pools metadata + , metadataHash :: ByteString + -- ^ A blake2b_256 hash of the pools' metadata. For verification. + } deriving (Eq, Show, Generic) + -- | Information about a stake pool, published by a stake pool owner in the -- stake pool registry. -- diff --git a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs index a2b20792a3f..a1de8471dfb 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs @@ -33,7 +33,7 @@ import Test.Utils.Trace ( captureLogging ) spec :: Spec -spec = do +spec = describe "PATATE" $ do withDB newMemoryDBLayer $ do describe "Sqlite" properties diff --git a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs index 7e79696e683..b111728353f 100644 --- a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs +++ b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs @@ -169,7 +169,7 @@ data StakePoolLayer e m = StakePoolLayer -- The pool productions and stake distrubtions in the db can /never/ be from -- different forks such that it's safe for readers to access it. monitorStakePools - :: GetStakeDistribution t IO ~ GetStakeDistribution Jormungandr IO + :: (GetStakeDistribution t IO ~ GetStakeDistribution Jormungandr IO) => Tracer IO StakePoolLog -> (Block, Quantity "block" Word32) -- ^ Genesis block and 'k' diff --git a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs index 12893dd5ac3..bc27c6d32ab 100644 --- a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs @@ -265,6 +265,8 @@ prop_trackRegistrations test = monadicIO $ do $ ErrNetworkInvalid "The test case has finished") , initCursor = pure . const (Cursor header0) + , destroyCursor = + const (pure ()) , stakeDistribution = \_ -> pure mempty , currentNodeTip = diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 71fc2523fa9..3772a1ea1a4 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -167,6 +167,8 @@ import Ouroboros.Network.NodeToClient ) import Ouroboros.Network.Point ( WithOrigin (..) ) +import Shelley.Spec.Ledger.BaseTypes + ( strictMaybeToMaybe, urlToText ) import qualified Cardano.Api as Cardano import qualified Cardano.Byron.Codec.Cbor as CBOR @@ -358,7 +360,7 @@ fromShelleyBlock genesisHash epLength blk = fromShelleyBlock' :: W.EpochLength -> ShelleyBlock - -> (W.SlotId, [W.PoolRegistrationCertificate]) + -> (W.SlotId, [(W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef)]) fromShelleyBlock' epLength blk = let O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) _ = blk @@ -628,7 +630,10 @@ toShelleyCoin (W.Coin c) = SL.Coin $ safeCast c -- NOTE: For resolved inputs we have to pass in a dummy value of 0. fromShelleyTx :: SL.Tx TPraosStandardCrypto - -> (W.Tx, [W.DelegationCertificate], [W.PoolRegistrationCertificate]) + -> ( W.Tx + , [W.DelegationCertificate] + , [(W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef)] + ) fromShelleyTx (SL.Tx bod@(SL.TxBody ins outs certs _ _ _ _ _) _ _) = ( W.Tx (fromShelleyTxId $ SL.txid bod) @@ -661,15 +666,18 @@ fromShelleyDelegationCert = \case -- 'Nothing' if certificates aren't delegation certificate. fromShelleyRegistrationCert :: SL.DCert TPraosStandardCrypto - -> Maybe W.PoolRegistrationCertificate + -> Maybe (W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef) fromShelleyRegistrationCert = \case SL.DCertPool (SL.RegPool pp) -> - Just $ W.PoolRegistrationCertificate - { W.poolId = fromPoolKeyHash $ SL._poolPubKey pp - , W.poolOwners = fromOwnerKeyHash <$> Set.toList (SL._poolOwners pp) - , W.poolMargin = fromUnitInterval (SL._poolMargin pp) - , W.poolCost = Quantity $ fromIntegral (SL._poolCost pp) - } + Just $ + ( W.PoolRegistrationCertificate + { W.poolId = fromPoolKeyHash $ SL._poolPubKey pp + , W.poolOwners = fromOwnerKeyHash <$> Set.toList (SL._poolOwners pp) + , W.poolMargin = fromUnitInterval (SL._poolMargin pp) + , W.poolCost = Quantity $ fromIntegral (SL._poolCost pp) + } + , fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp) + ) SL.DCertPool (SL.RetirePool{}) -> Nothing -- FIXME We need to acknowledge pool retirement @@ -678,6 +686,13 @@ fromShelleyRegistrationCert = \case SL.DCertGenesis{} -> Nothing SL.DCertMir{} -> Nothing +fromPoolMetaData :: SL.PoolMetaData -> W.StakePoolMetadataRef +fromPoolMetaData meta = + W.StakePoolMetadataRef + { W.metadataURL = urlToText (SL._poolMDUrl meta) + , W.metadataHash = SL._poolMDHash meta + } + -- | Convert a stake credentials to a 'ChimericAccount' type. Unlike with -- Jörmungandr, the Chimeric payload doesn't represent a public key but a HASH -- of a public key. diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index 43a80afad2f..4175a527955 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -355,6 +355,7 @@ withNetworkLayer tr np addrInfo versionData action = do handleQueryFailure = withExceptT (\e -> ErrNetworkUnreachable $ T.pack $ "Unexpected" ++ show e) . ExceptT + _stakeDistribution queue pt coin = do stakeMap <- fromPoolDistr <$> handleQueryFailure (queue `send` CmdQueryLocalState pt OC.GetStakeDistribution) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 2df25bee4bc..1e86ec231e7 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} @@ -38,7 +39,7 @@ import Cardano.Wallet.Primitive.Types , Coin (..) , GenesisParameters (..) , PoolId - , PoolRegistrationCertificate + , PoolRegistrationCertificate (..) , ProtocolParameters , SlotId ) @@ -218,11 +219,11 @@ monitorStakePools tr gp nl db@DBLayer{..} = do -> IO (FollowAction ()) forward blocks (_nodeTip, _pparams) = do atomically $ forM_ blocks $ \blk -> do - -- FIXME: Also extract & store metadata information from the block let (slot, registrations) = fromShelleyBlock' getEpochLength blk - forM_ registrations $ \pool -> do + forM_ registrations $ \(pool, metadata) -> do liftIO $ traceWith tr $ MsgStakePoolRegistration pool putPoolRegistration slot pool + maybe (pure ()) (putPoolMetadataRef (poolId pool)) metadata pure Continue data StakePoolLog