Skip to content

Commit

Permalink
Merge #1763
Browse files Browse the repository at this point in the history 
1763: extract stake pool registrations r=KtorZ a=KtorZ

# Issue Number

<!-- Put here a reference to the issue this PR relates to and which requirements it tackles -->

#1761

# Overview

<!-- Detail in a few bullet points the work accomplished in this PR -->

- a57cf75
  📍 **extend pool database with two new tables to store metadata**
  one of them will be used to persist a queue of metadata to fetch, while the other
is a less volatile storage where metadata gets dumped once fetched.
There's in principle no need for caching or timestamps here since
metadata can't be updated (hash is stored on-chain as part of the
registration) which simplifies a bit the problem.

- e776d1c
  📍 **extract pool registration certificate from blocks**
  
- 29166e4
  📍 **add logic for monitoring shelley stake pools registration certificates**
  Still rudimentary, and doesn't keep track of metadata information _yet_ but it's coming.

- 1331015
  📍 **write stake pool monitoring in start-up code, with proper loggers**
  
- 7e62661
  📍 **destroy node's connection when they're no longer needed**
  
- 6065134
  📍 **do not force rollback when the list of checkpoints is empty**
  An empty list basically assumes that there's no checkpoint on the driver, so nothing to rollback.

- f49a7bf
  📍 **extract and store pool metadata references from the chain**
  
- 4ef1b80
  📍 **add basic property tests for checking new pool db functions.**
  
- 6ef5980
  📍 **store block production in the pool monitoring worker**
  
- e8e1d83
  📍 **change database fn for fetching metadata ref to return them one-by-one**
  This is how the worker uses it in the end, and it makes the signature looks less awkward.

- 2c63840
  📍 **avoid intermediary akward 'metadataQueue' table**
    Instead, we can store metadata references alongside the registration
  (with blank / default values for Jörmungandr)

- 279cd62
  📍 **remove unused module 'Cardano.Pool.Metadata'**
  Turns out that we won't be able to fetch metadata from Smash as it was
originally intended:

a) Metadata are fetchted by metadata hash
b) Metadata needs to be fetched as raw bytestring, and decoded to JSON
   _after_ so that we are able to compute their corresponding hash and
   verify it. If we immediately deserialize to JSON, then we would have
   to re-encode them but there's no particular canonical encoding
   enforced when registering metadata, which leaves many possibility
   about how to encode a single file.

Plus, there's no need for caching at the request-level since once
fetched, there's no reason to fetch a result again. This module is
therefore useless.

- d393b7d
  📍 **move jormungandr-specific data-type into jormungandr package target**
  This cleans up a bit the metadata-related types because it had become a mess. In the end, we'll keep in the core package
the types as they're expected by cardano-wallet-shelley and simply move the exceptional ones (jormungandr) inside its
relevant package.

# Comments

<!-- Additional comments or screenshots to attach if any -->

Kinda hard to fully test without wiring it up into the stake pool listing, but logs are quite positive:

```
[cardano-wallet.pools-engine:Info:1071] [2020-06-17 10:22:36.17 UTC] Monitoring stake pools. Currently at genesis
[cardano-wallet.network:Info:1071] [2020-06-17 10:22:36.17 UTC] Looking for an intersection with the node's local chain with: 
[cardano-wallet.network:Info:1071] [2020-06-17 10:22:36.18 UTC] Intersection found: 01010101
[cardano-wallet.pools-engine:Info:1071] [2020-06-17 10:22:36.18 UTC] Applying blocks [0.0 ... 0.0]
[cardano-wallet.pools-engine:Info:1071] [2020-06-17 10:22:36.19 UTC] Applying blocks [0.12 ... 2.0]
[cardano-wallet.pools-engine:Info:1071] [2020-06-17 10:22:36.19 UTC] Discovered stake pool registration: Registration of 5a7b67c7 owned by [ed25519_pk1h3cqm8h6glw56hqa5mgy0gl97jxcawzpphxy5hwtchq8hra6zcwq70fndy]
[cardano-wallet.pools-engine:Info:1071] [2020-06-17 10:22:36.19 UTC] Discovered stake pool registration: Registration of c7258ccc owned by [ed25519_pk1mnjxa09v9hmn48awwcgyrfmnnq4dvs7fsege3glcg6yn0vckn0xsrm4zqy]
[cardano-wallet.pools-engine:Info:1071] [2020-06-17 10:22:36.19 UTC] Discovered stake pool registration: Registration of 775af3b2 owned by [ed25519_pk1qud4ay0zapd0r43c88lc9av8fnesx2hu0r36dsf46lprdp9p3zksx7q880]
```

<!-- 
Don't forget to:

 ✓ Self-review your changes to make sure nothing unexpected slipped through
 ✓ Assign yourself to the PR
 ✓ Assign one or several reviewer(s)
 ✓ Once created, link this PR to its corresponding ticket
 ✓ Assign the PR to a corresponding milestone
 ✓ Acknowledge any changes required to the Wiki
-->


Co-authored-by: KtorZ <[email protected]>
Co-authored-by: IOHK <[email protected]>
Co-authored-by: Johannes Lund <[email protected]>
  • Loading branch information
@iohk-bors @KtorZ @Anviking
4 people authored Jun 18, 2020
2 parents 47d56b3 + 45f9717 commit 925efcd
Show file tree
Hide file tree
Showing 42 changed files with 1,348 additions and 1,340 deletions.
28 changes: 21 additions & 7 deletions lib/byron/src/Cardano/Wallet/Byron/Network.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,8 +49,10 @@ import Cardano.Wallet.Byron.Compatibility
)
import Cardano.Wallet.Network
( Cursor, ErrPostTx (..), NetworkLayer (..), mapCursor )
import Control.Concurrent
( ThreadId )
import Control.Concurrent.Async
( async, link )
( Async, async, asyncThreadId, cancel, link )
import Control.Exception
( IOException )
import Control.Monad
Expand Down Expand Up @@ -192,6 +194,7 @@ import qualified Data.Text.Encoding as T
-- | Network layer cursor for Byron. Mostly useless since the protocol itself is
-- stateful and the node's keep track of the associated connection's cursor.
data instance Cursor (m Byron) = Cursor
(Async ())
(Point ByronBlock)
(TQueue m (ChainSyncCmd ByronBlock m))

Expand Down Expand Up @@ -232,6 +235,7 @@ withNetworkLayer tr np addrInfo versionData action = do
{ currentNodeTip = liftIO $ _currentNodeTip nodeTipVar
, nextBlocks = _nextBlocks
, initCursor = _initCursor
, destroyCursor = _destroyCursor
, cursorSlotId = _cursorSlotId
, getProtocolParameters = atomically $ readTVar protocolParamsVar
, postTx = _postTx localTxSubmissionQ
Expand All @@ -248,8 +252,8 @@ withNetworkLayer tr np addrInfo versionData action = do
chainSyncQ <- atomically newTQueue
client <- mkWalletClient gp chainSyncQ
let handlers = failOnConnectionLost tr
link =<< async
(connectClient tr handlers client versionData addrInfo)
thread <- async (connectClient tr handlers client versionData addrInfo)
link thread
let points = reverse $ genesisPoint :
(toPoint getGenesisBlockHash getEpochLength <$> headers)
let findIt = chainSyncQ `send` CmdFindIntersection points
Expand All @@ -261,18 +265,22 @@ withNetworkLayer tr np addrInfo versionData action = do
$ MsgIntersectionFound
$ fromChainHash getGenesisBlockHash
$ pointHash intersection
pure $ Cursor intersection chainSyncQ
pure $ Cursor thread intersection chainSyncQ
_ -> fail $ unwords
[ "initCursor: intersection not found? This can't happen"
, "because we always give at least the genesis point."
, "Here are the points we gave: " <> show headers
]

_nextBlocks (Cursor _ chainSyncQ) = do
let toCursor point = Cursor point chainSyncQ
_destroyCursor (Cursor thread _ _) = do
liftIO $ traceWith tr $ MsgDestroyCursor (asyncThreadId thread)
cancel thread

_nextBlocks (Cursor thread _ chainSyncQ) = do
let toCursor point = Cursor thread point chainSyncQ
liftIO $ mapCursor toCursor <$> chainSyncQ `send` CmdNextBlocks

_cursorSlotId (Cursor point _) = do
_cursorSlotId (Cursor _ point _) = do
fromSlotNo getEpochLength $ fromWithOrigin (SlotNo 0) $ pointSlot point

_getAccountBalance _ =
Expand Down Expand Up @@ -572,6 +580,7 @@ data NetworkLayerLog
| MsgNodeTip W.BlockHeader
| MsgProtocolParameters W.ProtocolParameters
| MsgLocalStateQueryError String
| MsgDestroyCursor ThreadId

type HandshakeTrace = TraceSendRecv (Handshake NodeToClientVersion CBOR.Term)

Expand Down Expand Up @@ -617,6 +626,10 @@ instance ToText NetworkLayerLog where
[ "Error when querying local state parameters:"
, T.pack e
]
MsgDestroyCursor threadId -> T.unwords
[ "Destroying cursor connection at"
, T.pack (show threadId)
]

instance HasPrivacyAnnotation NetworkLayerLog
instance HasSeverityAnnotation NetworkLayerLog where
Expand All @@ -635,3 +648,4 @@ instance HasSeverityAnnotation NetworkLayerLog where
MsgNodeTip{} -> Debug
MsgProtocolParameters{} -> Info
MsgLocalStateQueryError{} -> Error
MsgDestroyCursor{} -> Notice
3 changes: 0 additions & 3 deletions lib/core/cardano-wallet-core.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -57,7 +57,6 @@ library
, foldl
, generic-lens
, http-api-data
, http-client
, http-media
, http-types
, io-sim-classes
Expand Down Expand Up @@ -110,7 +109,6 @@ library
Cardano.Byron.Codec.Cbor
Cardano.DB.Sqlite
Cardano.DB.Sqlite.Delete
Cardano.Pool.Metadata
Cardano.Pool.DB
Cardano.Pool.DB.MVar
Cardano.Pool.DB.Model
Expand Down Expand Up @@ -252,7 +250,6 @@ test-suite unit
other-modules:
Cardano.Byron.Codec.CborSpec
Cardano.DB.Sqlite.DeleteSpec
Cardano.Pool.MetadataSpec
Cardano.Pool.DB.Arbitrary
Cardano.Pool.DB.Properties
Cardano.Pool.DB.SqliteSpec
Expand Down
29 changes: 6 additions & 23 deletions lib/core/src/Cardano/Pool/DB/Model.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -63,9 +63,7 @@ import Data.Map.Strict
import Data.Ord
( Down (..) )
import Data.Quantity
( Percentage, Quantity (..) )
import Data.Text.Class
( toText )
( Quantity (..) )
import Data.Word
( Word64 )
import GHC.Generics
Expand All @@ -91,7 +89,7 @@ data PoolDatabase = PoolDatabase
, owners :: !(Map PoolId [PoolOwner])
-- ^ Mapping between pool ids and owners

, metadata :: !(Map (SlotId, PoolId) (Percentage, Quantity "lovelace" Word64))
, metadata :: !(Map (SlotId, PoolId) PoolRegistrationCertificate)
-- ^ On-chain metadata associated with pools

, seed :: !SystemSeed
Expand Down Expand Up @@ -173,30 +171,15 @@ mPutPoolRegistration :: SlotId -> PoolRegistrationCertificate -> ModelPoolOp ()
mPutPoolRegistration sl registration db@PoolDatabase{owners,metadata} =
( Right ()
, db { owners = Map.insert poolId poolOwners owners
, metadata = Map.insert (sl, poolId) (poolMargin, poolCost) metadata
, metadata = Map.insert (sl, poolId) registration metadata
}
)
where
PoolRegistrationCertificate
{ poolId
, poolOwners
, poolCost
, poolMargin
} = registration
PoolRegistrationCertificate { poolId , poolOwners } = registration

mReadPoolRegistration :: PoolId -> ModelPoolOp (Maybe PoolRegistrationCertificate)
mReadPoolRegistration poolId db@PoolDatabase{owners, metadata} =
( Right $
case Map.lookupMax $ Map.filterWithKey (only poolId) metadata of
Nothing -> Nothing
Just (_, (poolMargin, poolCost)) ->
let poolOwners = maybe [] (L.sortOn toText) $ Map.lookup poolId owners
in Just PoolRegistrationCertificate
{ poolId
, poolOwners
, poolMargin
, poolCost
}
mReadPoolRegistration poolId db@PoolDatabase{metadata} =
( Right $ fmap snd $ Map.lookupMax $ Map.filterWithKey (only poolId) metadata
, db
)
where
Expand Down
29 changes: 27 additions & 2 deletions lib/core/src/Cardano/Pool/DB/Sqlite.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -185,30 +185,54 @@ newDBLayer trace fp = do
, poolOwners
, poolMargin
, poolCost
, poolPledge
, poolMetadata
} -> do
let poolMarginN = fromIntegral $ numerator $ getPercentage poolMargin
let poolMarginD = fromIntegral $ denominator $ getPercentage poolMargin
let poolCost_ = getQuantity poolCost
let poolPledge_ = getQuantity poolPledge
let poolMetadataUrl = fst <$> poolMetadata
let poolMetadataHash = snd <$> poolMetadata
insert_ $ PoolRegistration
poolId
point
poolMarginN
poolMarginD
poolCost_
poolPledge_
poolMetadataUrl
poolMetadataHash
insertMany_ $ zipWith (PoolOwner poolId) poolOwners [0..]

, readPoolRegistration = \poolId -> do
selectFirst [ PoolRegistrationPoolId ==. poolId ] [] >>= \case
Nothing -> pure Nothing
Just meta -> do
let (PoolRegistration _ _ marginNum marginDen poolCost_) = entityVal meta
let PoolRegistration
_poolId
_point
marginNum
marginDen
poolCost_
poolPledge_
poolMetadataUrl
poolMetadataHash = entityVal meta
let poolMargin = unsafeMkPercentage $ toRational $ marginNum % marginDen
let poolCost = Quantity poolCost_
let poolPledge = Quantity poolPledge_
let poolMetadata = (,) <$> poolMetadataUrl <*> poolMetadataHash
poolOwners <- fmap (poolOwnerOwner . entityVal) <$> selectList
[ PoolOwnerPoolId ==. poolId ]
[ Asc PoolOwnerIndex ]
pure $ Just $ PoolRegistrationCertificate
{ poolId, poolOwners, poolMargin, poolCost }
{ poolId
, poolOwners
, poolMargin
, poolCost
, poolPledge
, poolMetadata
}

, listRegisteredPools = do
fmap (poolRegistrationPoolId . entityVal) <$> selectList [ ]
Expand Down Expand Up @@ -240,6 +264,7 @@ newDBLayer trace fp = do
deleteWhere ([] :: [Filter PoolOwner])
deleteWhere ([] :: [Filter PoolRegistration])
deleteWhere ([] :: [Filter StakeDistribution])
deleteWhere ([] :: [Filter PoolMetadata])

, atomically = runQuery
})
Expand Down
30 changes: 24 additions & 6 deletions lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,8 @@ import Prelude

import Cardano.Wallet.DB.Sqlite.Types
( sqlSettings' )
import Data.Text
( Text )
import Data.Word
( Word32, Word64, Word8 )
import Database.Persist.Class
Expand Down Expand Up @@ -69,7 +71,7 @@ StakeDistribution sql=stake_distribution
Primary stakeDistributionPoolId stakeDistributionEpoch
deriving Show Generic

-- Mapping from pool id to owner
-- Mapping from pool id to owner.
PoolOwner sql=pool_owner
poolOwnerPoolId W.PoolId sql=pool_id
poolOwnerOwner W.PoolOwner sql=pool_owner
Expand All @@ -81,12 +83,28 @@ PoolOwner sql=pool_owner

-- Mapping of registration certificate to pool
PoolRegistration sql=pool_registration
poolRegistrationPoolId W.PoolId sql=pool_id
poolRegistrationSlot W.SlotId sql=slot
poolRegistrationMarginNumerator Word64 sql=margin_numerator
poolRegistrationMarginDenominator Word64 sql=margin_denominator
poolRegistrationCost Word64 sql=cost
poolRegistrationPoolId W.PoolId sql=pool_id
poolRegistrationSlot W.SlotId sql=slot
poolRegistrationMarginNumerator Word64 sql=margin_numerator
poolRegistrationMarginDenominator Word64 sql=margin_denominator
poolRegistrationCost Word64 sql=cost
poolRegistrationPledge Word64 sql=pledge
poolRegistrationMetadataUrl Text Maybe sql=metadata_url
poolRegistrationMetadataHash W.StakePoolMetadataHash Maybe sql=metadata_hash

Primary poolRegistrationPoolId
deriving Show Generic

-- Cached metadata after they've been fetched from a remote server.
PoolMetadata sql=pool_metadata
poolMetadataHash W.StakePoolMetadataHash sql=metadata_hash
poolMetadataPoolId W.PoolId sql=pool_id
poolMetadataName Text sql=name
poolMetadataTicker W.StakePoolTicker sql=ticker
poolMetadataDescription Text Maybe sql=description
poolMetadataHomepage Text sql=homepage

Primary poolMetadataHash
Foreign PoolRegistration fk_registration_metadata_hash poolMetadataPoolId ! ON DELETE CASCADE
deriving Show Generic
|]
Loading

0 comments on commit 925efcd

Please sign in to comment.