From a57cf755140ea247a9692ea229894a26acb4b505 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 15 Jun 2020 15:36:59 +0200 Subject: [PATCH 01/14] 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. --- lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs | 26 +++++++++++++++++++ .../src/Cardano/Wallet/DB/Sqlite/Types.hs | 11 ++++++++ 2 files changed, 37 insertions(+) diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs b/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs index 4e6286986e5..5e616507c0b 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs @@ -22,6 +22,10 @@ import Prelude import Cardano.Wallet.DB.Sqlite.Types ( sqlSettings' ) +import Data.ByteString + ( ByteString ) +import Data.Text + ( Text ) import Data.Word ( Word32, Word64, Word8 ) import Database.Persist.Class @@ -89,4 +93,26 @@ PoolRegistration sql=pool_registration Primary poolRegistrationPoolId deriving Show Generic + +-- Temporary queue where metadata to fetch are stored. +PoolMetadataQueue sql=pool_metadata_queue + poolMetadataQueuePoolId W.PoolId sql=pool_id + poolMetadataQueueUrl Text sql=metadata_url + poolMetadataQueueHash ByteString sql=metadata_hash + + Primary poolMetadataQueuePoolId + deriving Show Generic + +-- Cached metadata after they've been fetched from a remote server. +PoolMetadata sql=pool_metadata + poolMetadataPoolId W.PoolId sql=pool_id + poolMetadataName Text sql=name + poolMetadataTicker W.StakePoolTicker sql=ticker + poolMetadataDescription Text Maybe sql=description + poolMetadataHomepage Text sql=homepage + poolMetadataPledge Word64 sql=pledge + poolMetadataOwner ByteString sql=owner + + Primary poolMetadataPoolId + deriving Show Generic |] diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs index 454bde4b814..42a87c16eb5 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs @@ -36,6 +36,7 @@ import Cardano.Wallet.Primitive.Types , PoolOwner (..) , SlotId (..) , SlotNo (..) + , StakePoolTicker , TxStatus (..) , WalletId (..) , flatSlot @@ -454,3 +455,13 @@ instance PersistField PassphraseScheme where instance PersistFieldSql PassphraseScheme where sqlType _ = sqlType (Proxy @String) + +---------------------------------------------------------------------------- +-- StakePoolTicker + +instance PersistField StakePoolTicker where + toPersistValue = toPersistValue . toText + fromPersistValue = fromPersistValueFromText + +instance PersistFieldSql StakePoolTicker where + sqlType _ = sqlType (Proxy @Text) From e776d1c72089ef60bd7befae7f3104e33b43a9ed Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 15 Jun 2020 15:53:50 +0200 Subject: [PATCH 02/14] extract pool registration certificate from blocks --- .../Cardano/Wallet/Shelley/Compatibility.hs | 66 ++++++++++++++----- 1 file changed, 49 insertions(+), 17 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 437fffdd06d..43a560efb64 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -178,6 +178,7 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import qualified Data.Text.Encoding as T import qualified Ouroboros.Consensus.Shelley.Ledger as O import qualified Ouroboros.Network.Block as O @@ -324,7 +325,7 @@ fromShelleyBlock genesisHash epLength blk = let O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) headerHash = blk SL.TxSeq txs' = txSeq - (txs, certs) = unzip $ map fromShelleyTx $ toList txs' + (txs, certs, _) = unzip3 $ map fromShelleyTx $ toList txs' in W.Block { header = W.BlockHeader @@ -438,23 +439,14 @@ fromPParams pp = W.ProtocolParameters -- convert it into a percentage. -- decentralizationLevelFromPParams - :: HasCallStack - => SL.PParams + :: SL.PParams -> W.DecentralizationLevel decentralizationLevelFromPParams pp = - either reportInvalidValue W.DecentralizationLevel - $ mkPercentage - $ toRational - $ SL.intervalValue + W.DecentralizationLevel $ fromUnitInterval -- We must invert the value provided: (see function comment) $ invertUnitInterval d where d = SL._d pp - reportInvalidValue = error $ mconcat - [ "decentralizationLevelFromPParams: " - , "encountered invalid decentralization parameter value: " - , show d - ] txParametersFromPParams :: SL.PParams @@ -611,19 +603,24 @@ toShelleyCoin (W.Coin c) = SL.Coin $ safeCast c safeCast = fromIntegral -- NOTE: For resolved inputs we have to pass in a dummy value of 0. -fromShelleyTx :: SL.Tx TPraosStandardCrypto -> (W.Tx, [W.DelegationCertificate]) +fromShelleyTx + :: SL.Tx TPraosStandardCrypto + -> (W.Tx, [W.DelegationCertificate], [W.PoolRegistrationCertificate]) fromShelleyTx (SL.Tx bod@(SL.TxBody ins outs certs _ _ _ _ _) _ _) = ( W.Tx (fromShelleyTxId $ SL.txid bod) (map ((,W.Coin 0) . fromShelleyTxIn) (toList ins)) (map fromShelleyTxOut (toList outs)) - , mapMaybe fromShelleyCert (toList certs) + , mapMaybe fromShelleyDelegationCert (toList certs) + , mapMaybe fromShelleyRegistrationCert (toList certs) ) -- Convert & filter Shelley certificate into delegation certificate. Returns -- 'Nothing' if certificates aren't delegation certificate. -fromShelleyCert :: SL.DCert TPraosStandardCrypto -> Maybe W.DelegationCertificate -fromShelleyCert = \case +fromShelleyDelegationCert + :: SL.DCert TPraosStandardCrypto + -> Maybe W.DelegationCertificate +fromShelleyDelegationCert = \case SL.DCertDeleg (SL.Delegate delegation) -> Just $ W.CertDelegateFull (fromStakeCredential (SL._delegator delegation)) @@ -637,6 +634,27 @@ fromShelleyCert = \case SL.DCertGenesis{} -> Nothing SL.DCertMir{} -> Nothing +-- Convert & filter Shelley certificate into delegation certificate. Returns +-- 'Nothing' if certificates aren't delegation certificate. +fromShelleyRegistrationCert + :: SL.DCert TPraosStandardCrypto + -> Maybe W.PoolRegistrationCertificate +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) + } + + SL.DCertPool (SL.RetirePool{}) -> + Nothing -- FIXME We need to acknowledge pool retirement + + SL.DCertDeleg{} -> Nothing + SL.DCertGenesis{} -> Nothing + SL.DCertMir{} -> Nothing + -- | 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. @@ -651,11 +669,25 @@ fromPoolKeyHash :: SL.KeyHash 'SL.StakePool TPraosStandardCrypto -> W.PoolId fromPoolKeyHash (SL.KeyHash h) = W.PoolId (getHash h) +fromOwnerKeyHash :: SL.KeyHash 'SL.Staking TPraosStandardCrypto -> W.PoolOwner +fromOwnerKeyHash (SL.KeyHash h) = + W.PoolOwner (getHash h) + +fromUnitInterval :: HasCallStack => SL.UnitInterval -> Percentage +fromUnitInterval x = + either bomb id . mkPercentage . toRational . SL.intervalValue $ x + where + bomb = error $ mconcat + [ "fromUnitInterval: " + , "encountered invalid parameter value: " + , show x + ] + -- NOTE: Arguably breaks naming conventions. Perhaps fromCardanoSignedTx instead toSealed :: SL.Tx TPraosStandardCrypto -> (W.Tx, W.SealedTx) toSealed tx = let - (wtx, _) = fromShelleyTx tx + (wtx, _, _) = fromShelleyTx tx sealed = W.SealedTx $ serialize' $ O.mkShelleyTx tx in (wtx, sealed) From 29166e4ba7c4b4f4a6150c6abef008157005be29 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 15 Jun 2020 17:43:01 +0200 Subject: [PATCH 03/14] add logic for monitoring shelley stake pools registration certificates Still rudimentary, and doesn't keep track of metadata information _yet_ but it's coming. --- .../Cardano/Wallet/Shelley/Compatibility.hs | 55 +++++--- .../src/Cardano/Wallet/Shelley/Pools.hs | 122 +++++++++++++++++- 2 files changed, 158 insertions(+), 19 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 43a560efb64..71fc2523fa9 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -63,9 +63,10 @@ module Cardano.Wallet.Shelley.Compatibility , fromNonMyopicMemberRewards , optimumNumberOfPools - , fromBlockNo , fromShelleyBlock + , fromShelleyBlock' + , toBlockHeader , fromShelleyHash , fromPrevHash , fromChainHash @@ -316,6 +317,27 @@ toSlotNo :: W.EpochLength -> W.SlotId -> SlotNo toSlotNo epLength = SlotNo . W.flatSlot epLength +toBlockHeader + :: W.Hash "Genesis" + -> W.EpochLength + -> ShelleyBlock + -> W.BlockHeader +toBlockHeader genesisHash epLength blk = + let + O.ShelleyBlock (SL.Block (SL.BHeader header _) _) headerHash = blk + in + W.BlockHeader + { slotId = + fromSlotNo epLength $ SL.bheaderSlotNo header + , blockHeight = + fromBlockNo $ SL.bheaderBlockNo header + , headerHash = + fromShelleyHash headerHash + , parentHeaderHash = + fromPrevHash (coerce genesisHash) $ + SL.bheaderPrev header + } + fromShelleyBlock :: W.Hash "Genesis" -> W.EpochLength @@ -323,26 +345,28 @@ fromShelleyBlock -> W.Block fromShelleyBlock genesisHash epLength blk = let - O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) headerHash = blk + O.ShelleyBlock (SL.Block _ txSeq) _ = blk SL.TxSeq txs' = txSeq (txs, certs, _) = unzip3 $ map fromShelleyTx $ toList txs' in W.Block - { header = W.BlockHeader - { slotId = - fromSlotNo epLength $ SL.bheaderSlotNo header - , blockHeight = - fromBlockNo $ SL.bheaderBlockNo header - , headerHash = - fromShelleyHash headerHash - , parentHeaderHash = - fromPrevHash (coerce genesisHash) $ - SL.bheaderPrev header - } + { header = toBlockHeader genesisHash epLength blk , transactions = txs , delegations = mconcat certs } +fromShelleyBlock' + :: W.EpochLength + -> ShelleyBlock + -> (W.SlotId, [W.PoolRegistrationCertificate]) +fromShelleyBlock' epLength blk = + let + O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) _ = blk + SL.TxSeq txs' = txSeq + (_, _, certs) = unzip3 $ map fromShelleyTx $ toList txs' + in + (fromSlotNo epLength $ SL.bheaderSlotNo header, mconcat certs) + fromShelleyHash :: ShelleyHash c -> W.Hash "BlockHeader" fromShelleyHash (ShelleyHash (SL.HashHeader h)) = W.Hash (getHash h) @@ -411,7 +435,7 @@ fromMaxTxSize :: Natural -> Quantity "byte" Word16 fromMaxTxSize = Quantity . fromIntegral -fromPParams :: HasCallStack => SL.PParams -> W.ProtocolParameters +fromPParams :: SL.PParams -> W.ProtocolParameters fromPParams pp = W.ProtocolParameters { decentralizationLevel = decentralizationLevelFromPParams pp @@ -464,8 +488,7 @@ txParametersFromPParams pp = W.TxParameters -- | Convert genesis data into blockchain params and an initial set of UTxO fromGenesisData - :: HasCallStack - => ShelleyGenesis TPraosStandardCrypto + :: ShelleyGenesis TPraosStandardCrypto -> (W.NetworkParameters, W.Block) fromGenesisData g = ( W.NetworkParameters diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 3482a6e8572..2df25bee4bc 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | @@ -16,22 +17,47 @@ module Cardano.Wallet.Shelley.Pools where import Prelude +import Cardano.BM.Data.Severity + ( Severity (..) ) +import Cardano.BM.Data.Tracer + ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) +import Cardano.Pool.DB + ( DBLayer (..) ) import Cardano.Wallet.Api.Types ( ApiT (..) ) import Cardano.Wallet.Network - ( ErrNetworkUnavailable, NetworkLayer (..) ) + ( ErrNetworkUnavailable + , FollowAction (..) + , FollowExit (..) + , FollowLog + , NetworkLayer (..) + , follow + ) import Cardano.Wallet.Primitive.Types - ( Coin (..), GenesisParameters (..), PoolId ) + ( BlockHeader + , Coin (..) + , GenesisParameters (..) + , PoolId + , PoolRegistrationCertificate + , ProtocolParameters + , SlotId + ) import Cardano.Wallet.Shelley.Compatibility - ( Shelley, toPoint ) + ( Shelley, ShelleyBlock, fromShelleyBlock', toBlockHeader, toPoint ) import Cardano.Wallet.Shelley.Network ( NodePoolLsqData (..) ) import Cardano.Wallet.Unsafe ( unsafeMkPercentage, unsafeRunExceptT ) +import Control.Monad + ( forM_ ) import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Except ( ExceptT (..), runExceptT ) +import Control.Tracer + ( Tracer, contramap, traceWith ) +import Data.List.NonEmpty + ( NonEmpty (..) ) import Data.Map ( Map ) import Data.Map.Merge.Strict @@ -42,8 +68,12 @@ import Data.Quantity ( Percentage (..), Quantity (..) ) import Data.Sort ( sortOn ) +import Data.Text.Class + ( ToText (..) ) import Data.Word ( Word64 ) +import Fmt + ( pretty ) import GHC.Generics ( Generic ) @@ -146,3 +176,89 @@ newStakePoolLayer gp nl = StakePoolLayer } mapQ f (Quantity x) = Quantity $ f x + + +-- +-- Monitoring stake pool +-- + +monitorStakePools + :: Tracer IO StakePoolLog + -> GenesisParameters + -> NetworkLayer IO t ShelleyBlock + -> DBLayer IO + -> IO () +monitorStakePools tr gp nl db@DBLayer{..} = do + cursor <- initCursor + traceWith tr $ MsgStartMonitoring cursor + follow nl (contramap MsgFollow tr) cursor forward getHeader >>= \case + FollowInterrupted -> traceWith tr MsgHaltMonitoring + FollowFailure -> traceWith tr MsgCrashMonitoring + FollowRollback point -> do + traceWith tr $ MsgRollingBackTo point + liftIO . atomically $ rollbackTo point + monitorStakePools tr gp nl db + where + GenesisParameters + { getGenesisBlockHash + , getEpochLength + , getEpochStability + } = gp + + initCursor :: IO [BlockHeader] + initCursor = atomically $ readPoolProductionCursor (max 100 k) + where k = fromIntegral $ getQuantity getEpochStability + + getHeader :: ShelleyBlock -> BlockHeader + getHeader = toBlockHeader getGenesisBlockHash getEpochLength + + forward + :: NonEmpty ShelleyBlock + -> (BlockHeader, ProtocolParameters) + -> 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 + liftIO $ traceWith tr $ MsgStakePoolRegistration pool + putPoolRegistration slot pool + pure Continue + +data StakePoolLog + = MsgFollow FollowLog + | MsgStartMonitoring [BlockHeader] + | MsgHaltMonitoring + | MsgCrashMonitoring + | MsgRollingBackTo SlotId + | MsgStakePoolRegistration PoolRegistrationCertificate + deriving (Show, Eq) + +instance HasPrivacyAnnotation StakePoolLog +instance HasSeverityAnnotation StakePoolLog where + getSeverityAnnotation = \case + MsgFollow e -> getSeverityAnnotation e + MsgStartMonitoring{} -> Info + MsgHaltMonitoring{} -> Info + MsgCrashMonitoring{} -> Error + MsgRollingBackTo{} -> Info + MsgStakePoolRegistration{} -> Info + +instance ToText StakePoolLog where + toText = \case + MsgFollow e -> + toText e + MsgStartMonitoring cursor -> mconcat + [ "Monitoring stake pools. Currently at " + , case cursor of + [] -> "genesis" + _ -> pretty (last cursor) + ] + MsgHaltMonitoring -> + "Stopping stake pool monitoring as requested." + MsgCrashMonitoring -> + "Chain follower exited with error. Worker will no longer monitor stake pools." + MsgRollingBackTo point -> + "Rolling back to " <> pretty point + MsgStakePoolRegistration pool -> + "Discovered stake pool registration: " <> pretty pool From 1331015b527254d0b1a8d23029f01ec14c45ae71 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 08:55:43 +0200 Subject: [PATCH 04/14] write stake pool monitoring in start-up code, with proper loggers --- lib/shelley/exe/cardano-wallet-shelley.hs | 2 + lib/shelley/src/Cardano/Wallet/Shelley.hs | 60 ++++++++++++++++++----- 2 files changed, 50 insertions(+), 12 deletions(-) diff --git a/lib/shelley/exe/cardano-wallet-shelley.hs b/lib/shelley/exe/cardano-wallet-shelley.hs index 2b8cf9eaec9..944f191b7ec 100644 --- a/lib/shelley/exe/cardano-wallet-shelley.hs +++ b/lib/shelley/exe/cardano-wallet-shelley.hs @@ -302,6 +302,8 @@ tracerSeveritiesOption = Tracers <*> traceOpt apiServerTracer (Just Info) <*> traceOpt walletEngineTracer (Just Info) <*> traceOpt walletDbTracer (Just Info) + <*> traceOpt poolsEngineTracer (Just Info) + <*> traceOpt poolsDbTracer (Just Info) <*> traceOpt ntpClientTracer (Just Info) <*> traceOpt networkTracer (Just Info) where diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index 0bd2eaeb7fb..e5b2926001b 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -100,7 +100,7 @@ import Cardano.Wallet.Primitive.Types , WalletId ) import Cardano.Wallet.Registry - ( WorkerLog (..) ) + ( WorkerLog (..), defaultWorkerAfter ) import Cardano.Wallet.Shelley.Api.Server ( server ) import Cardano.Wallet.Shelley.Compatibility @@ -108,15 +108,19 @@ import Cardano.Wallet.Shelley.Compatibility import Cardano.Wallet.Shelley.Network ( NetworkLayerLog, withNetworkLayer ) import Cardano.Wallet.Shelley.Pools - ( StakePoolLayer (..), newStakePoolLayer ) + ( StakePoolLayer (..), StakePoolLog, monitorStakePools, newStakePoolLayer ) import Cardano.Wallet.Shelley.Transaction ( newTransactionLayer ) import Cardano.Wallet.Transaction ( TransactionLayer ) import Control.Applicative ( Const (..) ) +import Control.Concurrent + ( forkFinally ) +import Control.Monad + ( void ) import Control.Tracer - ( Tracer (..), nullTracer, traceWith ) + ( Tracer (..), contramap, nullTracer, traceWith ) import Data.Function ( (&) ) import Data.Proxy @@ -144,6 +148,7 @@ import System.Exit import System.IOManager ( withIOManager ) +import qualified Cardano.Pool.DB.Sqlite as Pool import qualified Cardano.Wallet.Api.Server as Server import qualified Cardano.Wallet.DB.Sqlite as Sqlite import qualified Data.Text as T @@ -229,15 +234,16 @@ serveWallet icarusApi <- apiLayer (newTransactionLayer proxy pm el ) nl shelleyApi <- apiLayer (newTransactionLayer proxy pm el) nl let spl = newStakePoolLayer (genesisParameters np) nl - startServer - proxy - socket - randomApi - icarusApi - shelleyApi - spl - ntpClient - pure ExitSuccess + withPoolsMonitoring databaseDir (genesisParameters np) nl $ do + startServer + proxy + socket + randomApi + icarusApi + shelleyApi + spl + ntpClient + pure ExitSuccess networkDiscriminantValFromProxy :: forall n. (NetworkDiscriminantVal n) @@ -270,6 +276,20 @@ serveWallet server byron icarus shelley spl ntp Server.start settings apiServerTracer tlsConfig socket application + withPoolsMonitoring + :: Maybe FilePath + -> GenesisParameters + -> NetworkLayer IO t ShelleyBlock + -> IO a + -> IO a + withPoolsMonitoring dir gp nl action = + Pool.withDBLayer poolsDbTracer (Pool.defaultFilePath <$> dir) $ \db -> do + void $ forkFinally (monitorStakePools tr gp nl db) onExit + action + where + tr = contramap (MsgFromWorker mempty) poolsEngineTracer + onExit = defaultWorkerAfter poolsEngineTracer + apiLayer :: forall s k. ( IsOurs s Address @@ -364,6 +384,8 @@ data Tracers' f = Tracers , apiServerTracer :: f ApiLog , walletEngineTracer :: f (WorkerLog WalletId WalletLog) , walletDbTracer :: f DBLog + , poolsEngineTracer :: f (WorkerLog Text StakePoolLog) + , poolsDbTracer :: f DBLog , ntpClientTracer :: f NtpTrace , networkTracer :: f NetworkLayerLog } @@ -386,6 +408,8 @@ tracerSeverities sev = Tracers , apiServerTracer = Const sev , walletDbTracer = Const sev , walletEngineTracer = Const sev + , poolsEngineTracer = Const sev + , poolsDbTracer = Const sev , ntpClientTracer = Const sev , networkTracer = Const sev } @@ -400,6 +424,8 @@ setupTracers sev tr = Tracers , apiServerTracer = mkTrace apiServerTracer $ onoff apiServerTracer tr , walletEngineTracer = mkTrace walletEngineTracer $ onoff walletEngineTracer tr , walletDbTracer = mkTrace walletDbTracer $ onoff walletDbTracer tr + , poolsEngineTracer = mkTrace poolsEngineTracer $ onoff poolsEngineTracer tr + , poolsDbTracer = mkTrace poolsDbTracer $ onoff poolsDbTracer tr , ntpClientTracer = mkTrace ntpClientTracer $ onoff ntpClientTracer tr , networkTracer = mkTrace networkTracer $ onoff networkTracer tr } @@ -428,6 +454,8 @@ tracerLabels = Tracers , apiServerTracer = Const "api-server" , walletEngineTracer = Const "wallet-engine" , walletDbTracer = Const "wallet-db" + , poolsEngineTracer = Const "pools-engine" + , poolsDbTracer = Const "pools-db" , ntpClientTracer = Const "ntp-client" , networkTracer = Const "network" } @@ -447,6 +475,12 @@ tracerDescriptions = , ( lbl walletDbTracer , "About database operations of each wallet." ) + , ( lbl poolsEngineTracer + , "About the background worker monitoring stake pools and stake pools engine." + ) + , ( lbl poolsDbTracer + , "About database operations on stake pools." + ) , ( lbl ntpClientTracer , "About ntp-client." ) @@ -464,6 +498,8 @@ nullTracers = Tracers , apiServerTracer = nullTracer , walletEngineTracer = nullTracer , walletDbTracer = nullTracer + , poolsEngineTracer = nullTracer + , poolsDbTracer = nullTracer , ntpClientTracer = nullTracer , networkTracer = nullTracer } From 7e626619be7244f04f587653b1f5013acdb5d37e Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 10:03:39 +0200 Subject: [PATCH 05/14] destroy node's connection when they're no longer needed --- lib/byron/src/Cardano/Wallet/Byron/Network.hs | 28 +++++++++++---- lib/core/src/Cardano/Wallet/Network.hs | 22 +++++++----- lib/core/test/unit/Cardano/WalletSpec.hs | 2 ++ .../src/Cardano/Wallet/Jormungandr/Network.hs | 3 ++ .../Cardano/Pool/Jormungandr/MetricsSpec.hs | 2 ++ .../src/Cardano/Wallet/Shelley/Network.hs | 34 +++++++++++++------ 6 files changed, 65 insertions(+), 26 deletions(-) diff --git a/lib/byron/src/Cardano/Wallet/Byron/Network.hs b/lib/byron/src/Cardano/Wallet/Byron/Network.hs index 4b30b239c55..e64f93aaaff 100644 --- a/lib/byron/src/Cardano/Wallet/Byron/Network.hs +++ b/lib/byron/src/Cardano/Wallet/Byron/Network.hs @@ -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 @@ -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)) @@ -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 @@ -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 @@ -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 _ = @@ -572,6 +580,7 @@ data NetworkLayerLog | MsgNodeTip W.BlockHeader | MsgProtocolParameters W.ProtocolParameters | MsgLocalStateQueryError String + | MsgDestroyCursor ThreadId type HandshakeTrace = TraceSendRecv (Handshake NodeToClientVersion CBOR.Term) @@ -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 @@ -635,3 +648,4 @@ instance HasSeverityAnnotation NetworkLayerLog where MsgNodeTip{} -> Debug MsgProtocolParameters{} -> Info MsgLocalStateQueryError{} -> Error + MsgDestroyCursor{} -> Notice diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs index 666eaef7217..8e4441a4dc1 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -68,6 +68,8 @@ import Control.Retry ( RetryPolicyM, constantDelay, limitRetriesByCumulativeDelay, retrying ) import Control.Tracer ( Tracer, traceWith ) +import Data.Functor + ( ($>) ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Quantity @@ -109,6 +111,10 @@ data NetworkLayer m target block = NetworkLayer -- ^ Creates a cursor from the given block header so that 'nextBlocks' -- can be used to fetch blocks. + , destroyCursor + :: Cursor target -> m () + -- ^ Cleanup network connection once we're done with them. + , cursorSlotId :: Cursor target -> SlotId -- ^ Get the slot corresponding to a cursor. @@ -340,18 +346,18 @@ follow nl tr cps yield header = step delay cursor where retry (e :: SomeException) = case asyncExceptionFromException e of - Just ThreadKilled -> - return FollowInterrupted - Just UserInterrupt -> - return FollowInterrupted + Just ThreadKilled -> do + destroyCursor nl cursor $> FollowInterrupted + Just UserInterrupt -> do + destroyCursor nl cursor $> FollowInterrupted Nothing | fromException e == Just AsyncCancelled -> do - return FollowInterrupted + destroyCursor nl cursor $> FollowInterrupted Just _ -> do traceWith tr $ MsgUnhandledException eT - return FollowFailure + destroyCursor nl cursor $> FollowFailure _ -> do traceWith tr $ MsgUnhandledException eT - return FollowFailure + destroyCursor nl cursor $> FollowFailure where eT = T.pack (show e) @@ -388,7 +394,7 @@ follow nl tr cps yield header = (sl, _:_) | sl == slotId (last cps) -> step delay0 cursor' (sl, _) -> - pure (FollowRollback sl) + destroyCursor nl cursor' $> FollowRollback sl where continueWith :: Cursor target -> FollowAction e -> IO FollowExit continueWith cursor' = \case diff --git a/lib/core/test/unit/Cardano/WalletSpec.hs b/lib/core/test/unit/Cardano/WalletSpec.hs index b2784d51ef6..e66cf27220e 100644 --- a/lib/core/test/unit/Cardano/WalletSpec.hs +++ b/lib/core/test/unit/Cardano/WalletSpec.hs @@ -652,6 +652,8 @@ dummyNetworkLayer = NetworkLayer error "dummyNetworkLayer: nextBlocks not implemented" , initCursor = error "dummyNetworkLayer: initCursor not implemented" + , destroyCursor = + error "dummyNetworkLayer: destroyCursor not implemented" , cursorSlotId = error "dummyNetworkLayer: cursorSlotId not implemented" , currentNodeTip = diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs index 9f1976f32cd..85d8e643f45 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs @@ -309,6 +309,9 @@ mkRawNetworkLayer np batchSize st j = NetworkLayer , initCursor = _initCursor + , destroyCursor = + const (pure ()) + , cursorSlotId = _cursorSlotId diff --git a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs index 672696eaafa..12893dd5ac3 100644 --- a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs @@ -330,6 +330,8 @@ mockNetworkLayer = NetworkLayer \_ -> error "mockNetworkLayer: nextBlocks" , initCursor = \_ -> error "mockNetworkLayer: initCursor" + , destroyCursor = + \_ -> error "mockNetworkLayer: destroyCursor" , cursorSlotId = \_ -> error "mockNetworkLayer: cursorSlotId" , currentNodeTip = diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index ea0eeaadc77..43a80afad2f 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -67,8 +67,10 @@ import Cardano.Wallet.Shelley.Compatibility , toShelleyCoin , toStakeCredential ) +import Control.Concurrent + ( ThreadId ) import Control.Concurrent.Async - ( async, link ) + ( Async, async, asyncThreadId, cancel, link ) import Control.Exception ( IOException ) import Control.Monad @@ -214,6 +216,7 @@ import qualified Shelley.Spec.Ledger.PParams as SL -- | Network layer cursor for Shelley. Mostly useless since the protocol itself is -- stateful and the node's keep track of the associated connection's cursor. data instance Cursor (m Shelley) = Cursor + (Async ()) (Point ShelleyBlock) (TQueue m (ChainSyncCmd ShelleyBlock m)) @@ -248,6 +251,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 @@ -282,8 +286,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 @@ -295,18 +299,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 nodeTipVar queryRewardQ acct = do @@ -490,8 +498,7 @@ mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onPParamsUpdate = do let queryLocalState - :: HasCallStack - => Point ShelleyBlock + :: Point ShelleyBlock -> m () queryLocalState pt = do st <- localStateQueryQ `send` @@ -499,8 +506,7 @@ mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onPParamsUpdate = do handleLocalState st handleLocalState - :: HasCallStack - => Either AcquireFailure SL.PParams + :: Either AcquireFailure SL.PParams -> m () handleLocalState = \case Left (e :: AcquireFailure) -> @@ -689,6 +695,7 @@ data NetworkLayerLog | MsgGetRewardAccountBalance W.BlockHeader W.ChimericAccount | MsgAccountDelegationAndRewards W.ChimericAccount Delegations RewardAccounts + | MsgDestroyCursor ThreadId data QueryClientName = TipSyncClient @@ -752,6 +759,10 @@ instance ToText NetworkLayerLog where , " delegations = " <> T.pack (show delegations) , " rewards = " <> T.pack (show rewards) ] + MsgDestroyCursor threadId -> T.unwords + [ "Destroying cursor connection at" + , T.pack (show threadId) + ] instance HasPrivacyAnnotation NetworkLayerLog instance HasSeverityAnnotation NetworkLayerLog where @@ -772,3 +783,4 @@ instance HasSeverityAnnotation NetworkLayerLog where MsgLocalStateQueryError{} -> Error MsgGetRewardAccountBalance{} -> Info MsgAccountDelegationAndRewards{} -> Info + MsgDestroyCursor{} -> Notice From 60651346585eaf503304308ad9970e73c294a804 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 10:20:01 +0200 Subject: [PATCH 06/14] 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. --- lib/core/src/Cardano/Wallet/Network.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs index 8e4441a4dc1..0269b03414e 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -391,6 +391,8 @@ follow nl tr cps yield header = -- initiates the protocol by asking clients to rollback to the last -- known intersection. case (cursorSlotId nl cursor', cps) of + (_, []) -> + step delay0 cursor' (sl, _:_) | sl == slotId (last cps) -> step delay0 cursor' (sl, _) -> From f49a7bf40e0c3d9a11048be419cb9106faf66cd1 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 12:04:19 +0200 Subject: [PATCH 07/14] extract and store pool metadata references from the chain --- lib/core/src/Cardano/Pool/DB.hs | 18 ++++++++++ lib/core/src/Cardano/Pool/DB/MVar.hs | 12 +++++++ lib/core/src/Cardano/Pool/DB/Model.hs | 28 ++++++++++++++-- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 18 ++++++++++ .../src/Cardano/Wallet/Primitive/Types.hs | 9 +++++ .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 2 +- .../src/Cardano/Pool/Jormungandr/Metrics.hs | 2 +- .../Cardano/Pool/Jormungandr/MetricsSpec.hs | 2 ++ .../Cardano/Wallet/Shelley/Compatibility.hs | 33 ++++++++++++++----- .../src/Cardano/Wallet/Shelley/Network.hs | 1 + .../src/Cardano/Wallet/Shelley/Pools.hs | 7 ++-- 11 files changed, 116 insertions(+), 16 deletions(-) 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 From 4ef1b8097af05063f21669314ccf6969f5dbf0d0 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 14:55:14 +0200 Subject: [PATCH 08/14] add basic property tests for checking new pool db functions. --- lib/core/src/Cardano/Pool/DB.hs | 2 +- lib/core/src/Cardano/Pool/DB/MVar.hs | 6 +-- lib/core/src/Cardano/Pool/DB/Model.hs | 6 +-- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 4 +- .../src/Cardano/Wallet/Primitive/Types.hs | 2 +- .../test/unit/Cardano/Pool/DB/Arbitrary.hs | 13 +++++ .../test/unit/Cardano/Pool/DB/Properties.hs | 52 ++++++++++++++++++- .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 2 +- .../Wallet/Primitive/AddressDerivationSpec.hs | 2 +- 9 files changed, 77 insertions(+), 12 deletions(-) diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index db4c8123dc6..19351685410 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -128,7 +128,7 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -> stm () -- ^ Remove pool metadata references from the database. - , peekPoolMetadataRef + , readPoolMetadataRef :: Int -> stm [(PoolId, StakePoolMetadataRef)] -- ^ Peek at some pool metadata ref. Returns at most 'n' elements, where diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index af34266e63d..f580fcf834f 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -26,12 +26,12 @@ import Cardano.Pool.DB.Model , mCleanPoolProduction , mDeletePoolMetadataRef , mListRegisteredPools - , mPeekPoolMetadataRef , mPutPoolMetadataRef , mPutPoolProduction , mPutPoolRegistration , mPutStakeDistribution , mReadCursor + , mReadPoolMetadataRef , mReadPoolProduction , mReadPoolRegistration , mReadStakeDistribution @@ -93,8 +93,8 @@ newDBLayer = do , deletePoolMetadataRef = void . alterPoolDB (const Nothing) db . mDeletePoolMetadataRef - , peekPoolMetadataRef = \a0 -> - modifyMVar db (pure . swap . mPeekPoolMetadataRef a0) + , readPoolMetadataRef = \a0 -> + modifyMVar db (pure . swap . mReadPoolMetadataRef 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 10034995a4d..21f5e5c64da 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -43,7 +43,7 @@ module Cardano.Pool.DB.Model , mListRegisteredPools , mPutPoolMetadataRef , mDeletePoolMetadataRef - , mPeekPoolMetadataRef + , mReadPoolMetadataRef , mReadSystemSeed , mRollbackTo , mReadCursor @@ -225,8 +225,8 @@ mDeletePoolMetadataRef pid db@PoolDatabase{metadataRef} = , db { metadataRef = filter ((/= pid) . fst) metadataRef } ) -mPeekPoolMetadataRef :: Int -> PoolDatabase -> ([(PoolId, StakePoolMetadataRef)], PoolDatabase) -mPeekPoolMetadataRef n db@PoolDatabase{metadataRef} = +mReadPoolMetadataRef :: Int -> PoolDatabase -> ([(PoolId, StakePoolMetadataRef)], PoolDatabase) +mReadPoolMetadataRef n db@PoolDatabase{metadataRef} = ( take n metadataRef, db ) mReadSystemSeed diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index f8b861ec95c..e70a2b655be 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -222,7 +222,7 @@ newDBLayer trace fp = do , deletePoolMetadataRef = \poolId -> do deleteWhere [PoolMetadataQueuePoolId ==. poolId] - , peekPoolMetadataRef = \n -> do + , readPoolMetadataRef = \n -> do fmap (fromPoolMetadataQueue . entityVal) <$> selectList [] [ LimitTo n ] , rollbackTo = \point -> do @@ -251,6 +251,8 @@ newDBLayer trace fp = do deleteWhere ([] :: [Filter PoolOwner]) deleteWhere ([] :: [Filter PoolRegistration]) deleteWhere ([] :: [Filter StakeDistribution]) + deleteWhere ([] :: [Filter PoolMetadata]) + deleteWhere ([] :: [Filter PoolMetadataQueue]) , atomically = runQuery }) diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index 38623564073..f2885177c67 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -590,7 +590,7 @@ data StakePoolMetadataRef = StakePoolMetadataRef -- ^ A URL location where to find pools metadata , metadataHash :: ByteString -- ^ A blake2b_256 hash of the pools' metadata. For verification. - } deriving (Eq, Show, Generic) + } deriving (Eq, Ord, 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/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index 97a8c4c55e2..e549aab2c32 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -26,6 +26,7 @@ import Cardano.Wallet.Primitive.Types , SlotId (..) , SlotNo (..) , SlotParameters (..) + , StakePoolMetadataRef (..) , slotSucc , unsafeEpochNo ) @@ -58,6 +59,7 @@ import Test.QuickCheck , vector ) +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import qualified Data.List as L @@ -170,3 +172,14 @@ instance Arbitrary StakePoolsFixture where appendPair pools pairs slot = do pool <- elements pools return $ (pool,slot):pairs + +instance Arbitrary StakePoolMetadataRef where + arbitrary = StakePoolMetadataRef <$> genURL <*> genHash + where + genHash = BS.pack <$> vector 32 + genURL = do + protocol <- elements [ "http", "https" ] + fstP <- elements [ "cardano", "ada", "pool", "staking", "reward" ] + sndP <- elements [ "rocks", "moon", "digital", "server", "fast" ] + extP <- elements [ ".io", ".dev", ".com", ".eu" ] + pure $ protocol <> "://" <> fstP <> "-" <> sndP <> extP diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs index e3f3fa9770a..36adf862863 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -27,6 +27,7 @@ import Cardano.Wallet.Primitive.Types , PoolId , PoolRegistrationCertificate (..) , SlotId (..) + , StakePoolMetadataRef ) import Cardano.Wallet.Unsafe ( unsafeRunExceptT ) @@ -70,7 +71,13 @@ import Test.Hspec , shouldReturn ) import Test.QuickCheck - ( Positive (..), Property, classify, counterexample, property ) + ( NonEmptyList (..) + , Positive (..) + , Property + , classify + , counterexample + , property + ) import Test.QuickCheck.Monadic ( assert, monadicIO, monitor, run ) @@ -140,6 +147,10 @@ properties = do (property . prop_listRegisteredPools) it "putPoolProduction* . readTotalProduction matches expectations" (property . prop_readTotalProduction) + it "putPoolMetadataRef . readPoolMetadataRef" + (property . prop_putReadMetadataRef) + it "propDeleteMetadataRef" + (property . prop_deleteMetadataRef) {------------------------------------------------------------------------------- Properties @@ -452,6 +463,45 @@ prop_listRegisteredPools DBLayer {..} entries = ] assert (pools == (poolId <$> reverse entries)) +prop_putReadMetadataRef + :: DBLayer IO + -> [(PoolId, StakePoolMetadataRef)] + -> Property +prop_putReadMetadataRef DBLayer{..} entries = + monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + prop = do + run . atomically $ mapM_ (uncurry putPoolMetadataRef) entries + refs <- run . atomically $ readPoolMetadataRef (length entries) + monitor $ counterexample $ unlines + [ "Stored " <> show (length entries) <> " entries" + , "Read " <> show (length refs) <> " entries" + , "Read from DB: " <> show refs + ] + assert (L.sort refs == L.sort entries) + +prop_deleteMetadataRef + :: DBLayer IO + -> NonEmptyList (PoolId, StakePoolMetadataRef) + -> Property +prop_deleteMetadataRef DBLayer{..} (NonEmpty entries) = + monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + prop = do + let removed = fst $ head entries + run . atomically $ mapM_ (uncurry putPoolMetadataRef) entries + run . atomically $ deletePoolMetadataRef removed + refs <- run . atomically $ readPoolMetadataRef (length entries) + monitor $ counterexample $ unlines + [ "Stored " <> show (length entries) <> " entries" + , "Read " <> show (length refs) <> " entries" + , "Removed: " <> show removed + , "Read from DB: " <> show refs + ] + assert (removed `notElem` (fst <$> refs)) + -- | successive readSystemSeed yield the exact same value prop_readSystemSeedIdempotent :: DBLayer IO diff --git a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs index a1de8471dfb..a2b20792a3f 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 = describe "PATATE" $ do +spec = do withDB newMemoryDBLayer $ do describe "Sqlite" properties diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDerivationSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDerivationSpec.hs index 90a60d65b62..bcda686ecc0 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDerivationSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDerivationSpec.hs @@ -92,7 +92,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T spec :: Spec -spec = describe "PATATE" $ do +spec = do describe "Bounded / Enum relationship" $ do it "The calls Index.succ maxBound should result in a runtime err (hard)" prop_succMaxBoundHardIx From 6ef598028f0dbeb3230eb66eea6a9b0a7aff64cf Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 17:26:50 +0200 Subject: [PATCH 09/14] store block production in the pool monitoring worker --- .../Cardano/Wallet/Shelley/Compatibility.hs | 29 ++++++++++++------- .../src/Cardano/Wallet/Shelley/Pools.hs | 19 ++++++++++-- 2 files changed, 35 insertions(+), 13 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 3772a1ea1a4..6fb6e8a5b6e 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -62,6 +62,7 @@ module Cardano.Wallet.Shelley.Compatibility , fromPoolDistr , fromNonMyopicMemberRewards , optimumNumberOfPools + , getProducer , fromBlockNo , fromShelleyBlock @@ -340,6 +341,13 @@ toBlockHeader genesisHash epLength blk = SL.bheaderPrev header } +getProducer :: ShelleyBlock -> W.PoolId +getProducer blk = + let + O.ShelleyBlock (SL.Block (SL.BHeader header _) _) _ = blk + in + fromPoolKeyHash $ SL.hashKey (SL.bheaderVk header) + fromShelleyBlock :: W.Hash "Genesis" -> W.EpochLength @@ -668,16 +676,15 @@ fromShelleyRegistrationCert :: SL.DCert TPraosStandardCrypto -> 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) - } - , fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp) - ) + 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) + } + , fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp) + ) SL.DCertPool (SL.RetirePool{}) -> Nothing -- FIXME We need to acknowledge pool retirement @@ -703,7 +710,7 @@ fromStakeCredential = \case SL.KeyHashObj (SL.KeyHash h) -> W.ChimericAccount (getHash h) -fromPoolKeyHash :: SL.KeyHash 'SL.StakePool TPraosStandardCrypto -> W.PoolId +fromPoolKeyHash :: SL.KeyHash rol TPraosStandardCrypto -> W.PoolId fromPoolKeyHash (SL.KeyHash h) = W.PoolId (getHash h) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 1e86ec231e7..1978d9ce531 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -23,7 +23,7 @@ import Cardano.BM.Data.Severity import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) import Cardano.Pool.DB - ( DBLayer (..) ) + ( DBLayer (..), ErrPointAlreadyExists (..) ) import Cardano.Wallet.Api.Types ( ApiT (..) ) import Cardano.Wallet.Network @@ -44,7 +44,13 @@ import Cardano.Wallet.Primitive.Types , SlotId ) import Cardano.Wallet.Shelley.Compatibility - ( Shelley, ShelleyBlock, fromShelleyBlock', toBlockHeader, toPoint ) + ( Shelley + , ShelleyBlock + , fromShelleyBlock' + , getProducer + , toBlockHeader + , toPoint + ) import Cardano.Wallet.Shelley.Network ( NodePoolLsqData (..) ) import Cardano.Wallet.Unsafe @@ -220,6 +226,9 @@ monitorStakePools tr gp nl db@DBLayer{..} = do forward blocks (_nodeTip, _pparams) = do atomically $ forM_ blocks $ \blk -> do let (slot, registrations) = fromShelleyBlock' getEpochLength blk + runExceptT (putPoolProduction (getHeader blk) (getProducer blk)) >>= \case + Left e -> liftIO $ traceWith tr $ MsgErrProduction e + Right () -> pure () forM_ registrations $ \(pool, metadata) -> do liftIO $ traceWith tr $ MsgStakePoolRegistration pool putPoolRegistration slot pool @@ -233,6 +242,7 @@ data StakePoolLog | MsgCrashMonitoring | MsgRollingBackTo SlotId | MsgStakePoolRegistration PoolRegistrationCertificate + | MsgErrProduction ErrPointAlreadyExists deriving (Show, Eq) instance HasPrivacyAnnotation StakePoolLog @@ -244,6 +254,7 @@ instance HasSeverityAnnotation StakePoolLog where MsgCrashMonitoring{} -> Error MsgRollingBackTo{} -> Info MsgStakePoolRegistration{} -> Info + MsgErrProduction{} -> Error instance ToText StakePoolLog where toText = \case @@ -263,3 +274,7 @@ instance ToText StakePoolLog where "Rolling back to " <> pretty point MsgStakePoolRegistration pool -> "Discovered stake pool registration: " <> pretty pool + MsgErrProduction (ErrPointAlreadyExists blk) -> mconcat + [ "Couldn't store production for given block before it conflicts " + , "with another block. Conflicting block header is: ", pretty blk + ] From e8e1d8302310973173f9e1b7af5e9192dc16f094 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 17 Jun 2020 12:18:09 +0200 Subject: [PATCH 10/14] 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. --- lib/core/src/Cardano/Pool/DB.hs | 5 ++- lib/core/src/Cardano/Pool/DB/MVar.hs | 6 ++-- lib/core/src/Cardano/Pool/DB/Model.hs | 10 +++--- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 4 +-- .../test/unit/Cardano/Pool/DB/Properties.hs | 33 ++++++++++--------- 5 files changed, 31 insertions(+), 27 deletions(-) diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index 19351685410..0359034fd7d 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -128,9 +128,8 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -> stm () -- ^ Remove pool metadata references from the database. - , readPoolMetadataRef - :: Int - -> stm [(PoolId, StakePoolMetadataRef)] + , peekPoolMetadataRef + :: stm (Maybe (PoolId, StakePoolMetadataRef)) -- ^ Peek at some pool metadata ref. Returns at most 'n' elements, where -- 'n' is the first parameter. diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index f580fcf834f..74d6c28be0a 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -26,12 +26,12 @@ import Cardano.Pool.DB.Model , mCleanPoolProduction , mDeletePoolMetadataRef , mListRegisteredPools + , mPeekPoolMetadataRef , mPutPoolMetadataRef , mPutPoolProduction , mPutPoolRegistration , mPutStakeDistribution , mReadCursor - , mReadPoolMetadataRef , mReadPoolProduction , mReadPoolRegistration , mReadStakeDistribution @@ -93,8 +93,8 @@ newDBLayer = do , deletePoolMetadataRef = void . alterPoolDB (const Nothing) db . mDeletePoolMetadataRef - , readPoolMetadataRef = \a0 -> - modifyMVar db (pure . swap . mReadPoolMetadataRef a0) + , peekPoolMetadataRef = + modifyMVar db (pure . swap . mPeekPoolMetadataRef) , 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 21f5e5c64da..87a32bbe6fe 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -43,7 +43,7 @@ module Cardano.Pool.DB.Model , mListRegisteredPools , mPutPoolMetadataRef , mDeletePoolMetadataRef - , mReadPoolMetadataRef + , mPeekPoolMetadataRef , mReadSystemSeed , mRollbackTo , mReadCursor @@ -64,6 +64,8 @@ import Data.Foldable ( fold ) import Data.Map.Strict ( Map ) +import Data.Maybe + ( listToMaybe ) import Data.Ord ( Down (..) ) import Data.Quantity @@ -225,9 +227,9 @@ mDeletePoolMetadataRef pid db@PoolDatabase{metadataRef} = , db { metadataRef = filter ((/= pid) . fst) metadataRef } ) -mReadPoolMetadataRef :: Int -> PoolDatabase -> ([(PoolId, StakePoolMetadataRef)], PoolDatabase) -mReadPoolMetadataRef n db@PoolDatabase{metadataRef} = - ( take n metadataRef, db ) +mPeekPoolMetadataRef :: PoolDatabase -> (Maybe (PoolId, StakePoolMetadataRef), PoolDatabase) +mPeekPoolMetadataRef db@PoolDatabase{metadataRef} = + ( listToMaybe $ take 1 metadataRef, db ) mReadSystemSeed :: PoolDatabase diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index e70a2b655be..8b14b2853cb 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -222,8 +222,8 @@ newDBLayer trace fp = do , deletePoolMetadataRef = \poolId -> do deleteWhere [PoolMetadataQueuePoolId ==. poolId] - , readPoolMetadataRef = \n -> do - fmap (fromPoolMetadataQueue . entityVal) <$> selectList [] [ LimitTo n ] + , peekPoolMetadataRef = do + fmap (fromPoolMetadataQueue . entityVal) <$> selectFirst [] [] , rollbackTo = \point -> do let (EpochNo epoch) = epochNumber point diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs index 36adf862863..2063c555a19 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -147,8 +147,8 @@ properties = do (property . prop_listRegisteredPools) it "putPoolProduction* . readTotalProduction matches expectations" (property . prop_readTotalProduction) - it "putPoolMetadataRef . readPoolMetadataRef" - (property . prop_putReadMetadataRef) + it "putPoolMetadataRef . peekPoolMetadataRef" + (property . prop_putPeekMetadataRef) it "propDeleteMetadataRef" (property . prop_deleteMetadataRef) @@ -463,23 +463,24 @@ prop_listRegisteredPools DBLayer {..} entries = ] assert (pools == (poolId <$> reverse entries)) -prop_putReadMetadataRef +prop_putPeekMetadataRef :: DBLayer IO -> [(PoolId, StakePoolMetadataRef)] -> Property -prop_putReadMetadataRef DBLayer{..} entries = +prop_putPeekMetadataRef DBLayer{..} entries = monadicIO (setup >> prop) where setup = run $ atomically cleanDB prop = do run . atomically $ mapM_ (uncurry putPoolMetadataRef) entries - refs <- run . atomically $ readPoolMetadataRef (length entries) + mref <- run . atomically $ peekPoolMetadataRef monitor $ counterexample $ unlines [ "Stored " <> show (length entries) <> " entries" - , "Read " <> show (length refs) <> " entries" - , "Read from DB: " <> show refs + , "Read from DB: " <> show mref ] - assert (L.sort refs == L.sort entries) + case mref of + Just ref -> assert (ref `elem` entries) + Nothing -> assert (null entries) prop_deleteMetadataRef :: DBLayer IO @@ -490,17 +491,19 @@ prop_deleteMetadataRef DBLayer{..} (NonEmpty entries) = where setup = run $ atomically cleanDB prop = do - let removed = fst $ head entries run . atomically $ mapM_ (uncurry putPoolMetadataRef) entries - run . atomically $ deletePoolMetadataRef removed - refs <- run . atomically $ readPoolMetadataRef (length entries) + removed <- run . atomically $ replicateM (length entries) $ do + mref <- peekPoolMetadataRef + mref <$ case mref of + Nothing -> pure () + Just (pid,_) -> deletePoolMetadataRef pid + let refs = catMaybes removed monitor $ counterexample $ unlines [ "Stored " <> show (length entries) <> " entries" - , "Read " <> show (length refs) <> " entries" - , "Removed: " <> show removed - , "Read from DB: " <> show refs + , "Removed " <> show (length refs) <> " entries" + , show removed ] - assert (removed `notElem` (fst <$> refs)) + assert (L.sort refs == L.sort entries) -- | successive readSystemSeed yield the exact same value prop_readSystemSeedIdempotent From 2c63840b9ddcc8dcd28ae3131fdb1e1fb8a3ac3a Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 17 Jun 2020 14:52:50 +0200 Subject: [PATCH 11/14] avoid intermediary akward 'metadataQueue' table MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Instead, we can store metadata references alongside the registration (with blank / default values for Jörmungandr) --- lib/core/src/Cardano/Pool/DB.hs | 17 ------ lib/core/src/Cardano/Pool/DB/MVar.hs | 12 ---- lib/core/src/Cardano/Pool/DB/Model.hs | 59 +++---------------- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 47 ++++++++------- lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs | 44 ++++++-------- .../src/Cardano/Wallet/DB/Sqlite/Types.hs | 31 ++++++++++ .../src/Cardano/Wallet/Primitive/Types.hs | 28 ++++++--- .../test/unit/Cardano/Pool/DB/Arbitrary.hs | 29 ++++----- .../test/unit/Cardano/Pool/DB/Properties.hs | 55 +---------------- .../src/Cardano/Wallet/Jormungandr/Binary.hs | 3 +- .../Cardano/Pool/Jormungandr/MetricsSpec.hs | 6 +- .../Cardano/Wallet/Shelley/Compatibility.hs | 18 +++--- .../src/Cardano/Wallet/Shelley/Pools.hs | 3 +- 13 files changed, 134 insertions(+), 218 deletions(-) diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index 0359034fd7d..74905ca7c33 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -25,7 +25,6 @@ import Cardano.Wallet.Primitive.Types , PoolId , PoolRegistrationCertificate , SlotId (..) - , StakePoolMetadataRef ) import Control.Monad.Fail ( MonadFail ) @@ -117,22 +116,6 @@ 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 - :: stm (Maybe (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 74d6c28be0a..69923c1ff17 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -24,10 +24,7 @@ import Cardano.Pool.DB.Model , PoolErr (..) , emptyPoolDatabase , mCleanPoolProduction - , mDeletePoolMetadataRef , mListRegisteredPools - , mPeekPoolMetadataRef - , mPutPoolMetadataRef , mPutPoolProduction , mPutPoolRegistration , mPutStakeDistribution @@ -87,15 +84,6 @@ 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 = - modifyMVar db (pure . swap . mPeekPoolMetadataRef) - , 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 87a32bbe6fe..ad1298187e0 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -41,9 +41,6 @@ module Cardano.Pool.DB.Model , mPutPoolRegistration , mReadPoolRegistration , mListRegisteredPools - , mPutPoolMetadataRef - , mDeletePoolMetadataRef - , mPeekPoolMetadataRef , mReadSystemSeed , mRollbackTo , mReadCursor @@ -58,20 +55,15 @@ import Cardano.Wallet.Primitive.Types , PoolOwner (..) , PoolRegistrationCertificate (..) , SlotId (..) - , StakePoolMetadataRef ) import Data.Foldable ( fold ) import Data.Map.Strict ( Map ) -import Data.Maybe - ( listToMaybe ) import Data.Ord ( Down (..) ) import Data.Quantity - ( Percentage, Quantity (..) ) -import Data.Text.Class - ( toText ) + ( Quantity (..) ) import Data.Word ( Word64 ) import GHC.Generics @@ -97,12 +89,9 @@ 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 - , metadataRef :: [(PoolId, StakePoolMetadataRef)] - -- ^ On-chain metadata references needed to fetch metadata - , seed :: !SystemSeed -- ^ Store an arbitrary random generator seed } deriving (Generic, Show, Eq) @@ -120,7 +109,7 @@ instance Eq SystemSeed where -- | Produces an empty model pool production database. emptyPoolDatabase :: PoolDatabase -emptyPoolDatabase = PoolDatabase mempty mempty mempty mempty mempty NotSeededYet +emptyPoolDatabase = PoolDatabase mempty mempty mempty mempty NotSeededYet {------------------------------------------------------------------------------- Model Operation Types @@ -182,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 @@ -215,22 +189,6 @@ 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 :: PoolDatabase -> (Maybe (PoolId, StakePoolMetadataRef), PoolDatabase) -mPeekPoolMetadataRef db@PoolDatabase{metadataRef} = - ( listToMaybe $ take 1 metadataRef, db ) - mReadSystemSeed :: PoolDatabase -> IO (StdGen, PoolDatabase) @@ -250,7 +208,7 @@ mReadCursor k db@PoolDatabase{pools} = in (Right $ reverse $ limit $ sortDesc allHeaders, db) mRollbackTo :: SlotId -> ModelPoolOp () -mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, metadataRef, seed} = +mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, seed} = let metadata' = Map.mapMaybeWithKey (discardBy id . fst) metadata owners' = Map.restrictKeys owners @@ -263,7 +221,6 @@ mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, metadataR , 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 8b14b2853cb..8ab3424ad20 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -46,7 +46,6 @@ import Cardano.Wallet.Primitive.Types , PoolId , PoolRegistrationCertificate (..) , SlotId (..) - , StakePoolMetadataRef (..) ) import Cardano.Wallet.Unsafe ( unsafeMkPercentage ) @@ -75,7 +74,6 @@ import Database.Persist.Sql , deleteWhere , insertMany_ , insert_ - , putMany , selectFirst , selectList , (<.) @@ -187,44 +185,59 @@ 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 [ ] [ Desc PoolRegistrationSlot ] - , putPoolMetadataRef = \poolId ref -> do - putMany [PoolMetadataQueue poolId (metadataURL ref) (metadataHash ref)] - - , deletePoolMetadataRef = \poolId -> do - deleteWhere [PoolMetadataQueuePoolId ==. poolId] - - , peekPoolMetadataRef = do - fmap (fromPoolMetadataQueue . entityVal) <$> selectFirst [] [] - , rollbackTo = \point -> do let (EpochNo epoch) = epochNumber point deleteWhere [ PoolProductionSlot >. point ] @@ -252,7 +265,6 @@ newDBLayer trace fp = do deleteWhere ([] :: [Filter PoolRegistration]) deleteWhere ([] :: [Filter StakeDistribution]) deleteWhere ([] :: [Filter PoolMetadata]) - deleteWhere ([] :: [Filter PoolMetadataQueue]) , atomically = runQuery }) @@ -339,10 +351,3 @@ 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/Pool/DB/Sqlite/TH.hs b/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs index 5e616507c0b..55708eb6a79 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs @@ -22,8 +22,6 @@ import Prelude import Cardano.Wallet.DB.Sqlite.Types ( sqlSettings' ) -import Data.ByteString - ( ByteString ) import Data.Text ( Text ) import Data.Word @@ -73,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 @@ -85,34 +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 --- Temporary queue where metadata to fetch are stored. -PoolMetadataQueue sql=pool_metadata_queue - poolMetadataQueuePoolId W.PoolId sql=pool_id - poolMetadataQueueUrl Text sql=metadata_url - poolMetadataQueueHash ByteString sql=metadata_hash - - Primary poolMetadataQueuePoolId - deriving Show Generic - -- Cached metadata after they've been fetched from a remote server. PoolMetadata sql=pool_metadata - poolMetadataPoolId W.PoolId sql=pool_id - poolMetadataName Text sql=name - poolMetadataTicker W.StakePoolTicker sql=ticker - poolMetadataDescription Text Maybe sql=description - poolMetadataHomepage Text sql=homepage - poolMetadataPledge Word64 sql=pledge - poolMetadataOwner ByteString sql=owner - - Primary poolMetadataPoolId + 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 |] diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs index 42a87c16eb5..0e41cff5b73 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs @@ -36,6 +36,7 @@ import Cardano.Wallet.Primitive.Types , PoolOwner (..) , SlotId (..) , SlotNo (..) + , StakePoolMetadataHash (..) , StakePoolTicker , TxStatus (..) , WalletId (..) @@ -465,3 +466,33 @@ instance PersistField StakePoolTicker where instance PersistFieldSql StakePoolTicker where sqlType _ = sqlType (Proxy @Text) + +---------------------------------------------------------------------------- +-- StakePoolMetadataHash + +instance PersistField StakePoolMetadataHash where + toPersistValue = toPersistValue . toText + fromPersistValue = fromPersistValueFromText + +instance PersistFieldSql StakePoolMetadataHash where + sqlType _ = sqlType (Proxy @Text) + +instance Read StakePoolMetadataHash where + readsPrec _ = error "readsPrec stub needed for persistent" + +instance ToHttpApiData StakePoolMetadataHash where + toUrlPiece = toText + +instance FromHttpApiData StakePoolMetadataHash where + parseUrlPiece = fromText' + +instance ToJSON StakePoolMetadataHash where + toJSON = String . toText + +instance FromJSON StakePoolMetadataHash where + parseJSON = aesonFromText "StakePoolMetadataHash" + +instance PathPiece StakePoolMetadataHash where + fromPathPiece = fromTextMaybe + toPathPiece = toText + diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index f2885177c67..408cf23e9ee 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -143,7 +143,7 @@ module Cardano.Wallet.Primitive.Types , StakeDistribution (..) , poolIdBytesLength , StakePoolMetadata (..) - , StakePoolMetadataRef (..) + , StakePoolMetadataHash (..) , StakePoolOffChainMetadata (..) , StakePoolTicker (..) , sameStakePoolMetadata @@ -584,13 +584,21 @@ 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, Ord, Show, Generic) +-- | A newtype to wrap metadata hash. +-- +-- NOTE: not using the 'Hash' type as this newtype is primarily for database +-- interop which doesn't quite like DataKinds. +newtype StakePoolMetadataHash = StakePoolMetadataHash ByteString + deriving (Eq, Ord, Show, Generic) + +instance NFData StakePoolMetadataHash + +instance ToText StakePoolMetadataHash where + toText (StakePoolMetadataHash bytes) = + toText (Hash bytes) + +instance FromText StakePoolMetadataHash where + fromText = fmap (StakePoolMetadataHash . getHash @"_") . hashFromText 32 -- | Information about a stake pool, published by a stake pool owner in the -- stake pool registry. @@ -1832,12 +1840,14 @@ data PoolRegistrationCertificate = PoolRegistrationCertificate , poolOwners :: ![PoolOwner] , poolMargin :: Percentage , poolCost :: Quantity "lovelace" Word64 + , poolPledge :: Quantity "lovelace" Word64 + , poolMetadata :: Maybe (Text, StakePoolMetadataHash) } deriving (Generic, Show, Eq, Ord) instance NFData PoolRegistrationCertificate instance Buildable PoolRegistrationCertificate where - build (PoolRegistrationCertificate p o _ _) = mempty + build (PoolRegistrationCertificate p o _ _ _ _) = mempty <> "Registration of " <> build p <> " owned by " diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index e549aab2c32..b88f5aeb46e 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -26,7 +26,7 @@ import Cardano.Wallet.Primitive.Types , SlotId (..) , SlotNo (..) , SlotParameters (..) - , StakePoolMetadataRef (..) + , StakePoolMetadataHash (..) , slotSucc , unsafeEpochNo ) @@ -116,14 +116,26 @@ instance Arbitrary PoolOwner where return $ PoolOwner $ B8.pack (replicate 32 byte) instance Arbitrary PoolRegistrationCertificate where - shrink (PoolRegistrationCertificate p xs m c) = - (\xs' -> PoolRegistrationCertificate p xs' m c) + shrink (PoolRegistrationCertificate p xs m c pl md) = + (\xs' -> PoolRegistrationCertificate p xs' m c pl md) <$> shrinkList (const []) xs arbitrary = PoolRegistrationCertificate <$> arbitrary <*> scale (`mod` 8) (listOf arbitrary) <*> genPercentage <*> fmap Quantity arbitrary + <*> fmap Quantity arbitrary + <*> oneof [pure Nothing, Just <$> genMetadata] + where + genMetadata = (,) + <$> genURL + <*> fmap (StakePoolMetadataHash . BS.pack) (vector 32) + genURL = do + protocol <- elements [ "http", "https" ] + fstP <- elements [ "cardano", "ada", "pool", "staking", "reward" ] + sndP <- elements [ "rocks", "moon", "digital", "server", "fast" ] + extP <- elements [ ".io", ".dev", ".com", ".eu" ] + pure $ protocol <> "://" <> fstP <> "-" <> sndP <> extP instance Arbitrary StakePoolsFixture where arbitrary = do @@ -172,14 +184,3 @@ instance Arbitrary StakePoolsFixture where appendPair pools pairs slot = do pool <- elements pools return $ (pool,slot):pairs - -instance Arbitrary StakePoolMetadataRef where - arbitrary = StakePoolMetadataRef <$> genURL <*> genHash - where - genHash = BS.pack <$> vector 32 - genURL = do - protocol <- elements [ "http", "https" ] - fstP <- elements [ "cardano", "ada", "pool", "staking", "reward" ] - sndP <- elements [ "rocks", "moon", "digital", "server", "fast" ] - extP <- elements [ ".io", ".dev", ".com", ".eu" ] - pure $ protocol <> "://" <> fstP <> "-" <> sndP <> extP diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs index 2063c555a19..e3f3fa9770a 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -27,7 +27,6 @@ import Cardano.Wallet.Primitive.Types , PoolId , PoolRegistrationCertificate (..) , SlotId (..) - , StakePoolMetadataRef ) import Cardano.Wallet.Unsafe ( unsafeRunExceptT ) @@ -71,13 +70,7 @@ import Test.Hspec , shouldReturn ) import Test.QuickCheck - ( NonEmptyList (..) - , Positive (..) - , Property - , classify - , counterexample - , property - ) + ( Positive (..), Property, classify, counterexample, property ) import Test.QuickCheck.Monadic ( assert, monadicIO, monitor, run ) @@ -147,10 +140,6 @@ properties = do (property . prop_listRegisteredPools) it "putPoolProduction* . readTotalProduction matches expectations" (property . prop_readTotalProduction) - it "putPoolMetadataRef . peekPoolMetadataRef" - (property . prop_putPeekMetadataRef) - it "propDeleteMetadataRef" - (property . prop_deleteMetadataRef) {------------------------------------------------------------------------------- Properties @@ -463,48 +452,6 @@ prop_listRegisteredPools DBLayer {..} entries = ] assert (pools == (poolId <$> reverse entries)) -prop_putPeekMetadataRef - :: DBLayer IO - -> [(PoolId, StakePoolMetadataRef)] - -> Property -prop_putPeekMetadataRef DBLayer{..} entries = - monadicIO (setup >> prop) - where - setup = run $ atomically cleanDB - prop = do - run . atomically $ mapM_ (uncurry putPoolMetadataRef) entries - mref <- run . atomically $ peekPoolMetadataRef - monitor $ counterexample $ unlines - [ "Stored " <> show (length entries) <> " entries" - , "Read from DB: " <> show mref - ] - case mref of - Just ref -> assert (ref `elem` entries) - Nothing -> assert (null entries) - -prop_deleteMetadataRef - :: DBLayer IO - -> NonEmptyList (PoolId, StakePoolMetadataRef) - -> Property -prop_deleteMetadataRef DBLayer{..} (NonEmpty entries) = - monadicIO (setup >> prop) - where - setup = run $ atomically cleanDB - prop = do - run . atomically $ mapM_ (uncurry putPoolMetadataRef) entries - removed <- run . atomically $ replicateM (length entries) $ do - mref <- peekPoolMetadataRef - mref <$ case mref of - Nothing -> pure () - Just (pid,_) -> deletePoolMetadataRef pid - let refs = catMaybes removed - monitor $ counterexample $ unlines - [ "Stored " <> show (length entries) <> " entries" - , "Removed " <> show (length refs) <> " entries" - , show removed - ] - assert (L.sort refs == L.sort entries) - -- | successive readSystemSeed yield the exact same value prop_readSystemSeedIdempotent :: DBLayer IO diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs index 0ebdb4ef728..50a36c4e5e8 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs @@ -1088,7 +1088,8 @@ poolRegistrationsFromBlock (Block _hdr fragments) = do PoolRegistration (poolId, owners, taxes, _tx) <- fragments let margin = fromRight maxBound $ mkPercentage $ toRational $ taxRatio taxes let cost = Quantity (taxFixed taxes) - pure $ W.PoolRegistrationCertificate poolId owners margin cost + let dummyPledge = Quantity 0 + pure $ W.PoolRegistrationCertificate poolId owners margin cost dummyPledge Nothing -- | If all incentives parameters are present in the blocks, returns a function -- that computes reward based on a given epoch. diff --git a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs index bc27c6d32ab..017311a197f 100644 --- a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs @@ -436,14 +436,16 @@ instance Arbitrary PoolOwner where arbitrary = PoolOwner . B8.singleton <$> elements ['a'..'e'] instance Arbitrary PoolRegistrationCertificate where - shrink (PoolRegistrationCertificate p o m c) = - (\(p', NonEmpty o') -> PoolRegistrationCertificate p' o' m c) + shrink (PoolRegistrationCertificate p o m c pl md) = + (\(p', NonEmpty o') -> PoolRegistrationCertificate p' o' m c pl md) <$> shrink (p, NonEmpty o) arbitrary = PoolRegistrationCertificate <$> arbitrary <*> fmap (L.nub . getNonEmpty) (scale (`mod` 3) arbitrary) <*> genPercentage <*> fmap Quantity arbitrary + <*> pure (Quantity 0) + <*> pure Nothing instance Arbitrary RegistrationsTest where shrink (RegistrationsTest xs) = RegistrationsTest <$> shrink xs diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 6fb6e8a5b6e..fe7aeb39c0c 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -368,7 +368,7 @@ fromShelleyBlock genesisHash epLength blk = fromShelleyBlock' :: W.EpochLength -> ShelleyBlock - -> (W.SlotId, [(W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef)]) + -> (W.SlotId, [W.PoolRegistrationCertificate]) fromShelleyBlock' epLength blk = let O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) _ = blk @@ -640,7 +640,7 @@ fromShelleyTx :: SL.Tx TPraosStandardCrypto -> ( W.Tx , [W.DelegationCertificate] - , [(W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef)] + , [W.PoolRegistrationCertificate] ) fromShelleyTx (SL.Tx bod@(SL.TxBody ins outs certs _ _ _ _ _) _ _) = ( W.Tx @@ -674,7 +674,7 @@ fromShelleyDelegationCert = \case -- 'Nothing' if certificates aren't delegation certificate. fromShelleyRegistrationCert :: SL.DCert TPraosStandardCrypto - -> Maybe (W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef) + -> Maybe (W.PoolRegistrationCertificate) fromShelleyRegistrationCert = \case SL.DCertPool (SL.RegPool pp) -> Just ( W.PoolRegistrationCertificate @@ -682,8 +682,9 @@ fromShelleyRegistrationCert = \case , W.poolOwners = fromOwnerKeyHash <$> Set.toList (SL._poolOwners pp) , W.poolMargin = fromUnitInterval (SL._poolMargin pp) , W.poolCost = Quantity $ fromIntegral (SL._poolCost pp) + , W.poolPledge = Quantity $ fromIntegral (SL._poolPledge pp) + , W.poolMetadata = fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp) } - , fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp) ) SL.DCertPool (SL.RetirePool{}) -> @@ -693,12 +694,11 @@ fromShelleyRegistrationCert = \case SL.DCertGenesis{} -> Nothing SL.DCertMir{} -> Nothing -fromPoolMetaData :: SL.PoolMetaData -> W.StakePoolMetadataRef +fromPoolMetaData :: SL.PoolMetaData -> (Text, W.StakePoolMetadataHash) fromPoolMetaData meta = - W.StakePoolMetadataRef - { W.metadataURL = urlToText (SL._poolMDUrl meta) - , W.metadataHash = SL._poolMDHash meta - } + ( urlToText (SL._poolMDUrl meta) + , W.StakePoolMetadataHash (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 diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 1978d9ce531..fc678b86553 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -229,10 +229,9 @@ monitorStakePools tr gp nl db@DBLayer{..} = do runExceptT (putPoolProduction (getHeader blk) (getProducer blk)) >>= \case Left e -> liftIO $ traceWith tr $ MsgErrProduction e Right () -> pure () - forM_ registrations $ \(pool, metadata) -> do + forM_ registrations $ \pool -> do liftIO $ traceWith tr $ MsgStakePoolRegistration pool putPoolRegistration slot pool - maybe (pure ()) (putPoolMetadataRef (poolId pool)) metadata pure Continue data StakePoolLog From 279cd62c35a90b00329c4767e53150ce4c634955 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 17 Jun 2020 16:04:10 +0200 Subject: [PATCH 12/14] 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. --- lib/core/cardano-wallet-core.cabal | 2 - lib/core/src/Cardano/Pool/Metadata.hs | 217 ------------ lib/core/src/Cardano/Wallet/Api/Types.hs | 6 - .../src/Cardano/Wallet/Primitive/Types.hs | 15 - .../test/unit/Cardano/Pool/MetadataSpec.hs | 324 ------------------ 5 files changed, 564 deletions(-) delete mode 100644 lib/core/src/Cardano/Pool/Metadata.hs delete mode 100644 lib/core/test/unit/Cardano/Pool/MetadataSpec.hs diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index 6162d4baa2b..0b788149403 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -110,7 +110,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 @@ -252,7 +251,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 diff --git a/lib/core/src/Cardano/Pool/Metadata.hs b/lib/core/src/Cardano/Pool/Metadata.hs deleted file mode 100644 index de7df599844..00000000000 --- a/lib/core/src/Cardano/Pool/Metadata.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Copyright: © 2018-2020 IOHK --- License: Apache-2.0 --- --- API and corresponding client for dealing with a metadata aggregation server --- in Shelley. Such servers follow an OpenAPI specification, and on existing --- implementation written in Haskell is available at: --- --- - https://github.com/input-output-hk/smash --- --- This module is expected to be mostly used qualified as 'Metadata' to give --- context to the exposed functions and data-types. -module Cardano.Pool.Metadata - ( Api - - -- * Client - , Client(..) - , ClientConfig (..) - , ClientCallbacks (..) - , newClient - , MetadataRegistryLog (..) - - -- * Re-export - , BaseUrl (..) - , Scheme (..) - , Manager - , defaultManagerSettings - , newManager - ) where - -import Prelude - -import Cardano.BM.Data.Severity - ( Severity (..) ) -import Cardano.BM.Data.Tracer - ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) -import Cardano.Wallet.Api.Types - ( ApiT (..) ) -import Cardano.Wallet.Primitive.Types - ( PoolId, StakePoolOffChainMetadata (..) ) -import Control.Tracer - ( Tracer, traceWith ) -import Data.Proxy - ( Proxy (..) ) -import Data.Text.Class - ( ToText (..) ) -import Data.Time.Clock - ( NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime ) -import Fmt - ( pretty ) -import GHC.Generics - ( Generic ) -import Network.HTTP.Client - ( Manager, defaultManagerSettings, newManager ) -import Network.HTTP.Types - ( status404 ) -import Servant - ( (:>), Capture, Get, JSON ) -import Servant.Client - ( BaseUrl (..) - , ClientError (..) - , ClientM - , Scheme (..) - , client - , mkClientEnv - , responseStatusCode - , runClientM - ) - -import qualified Data.Text as T - --- --- Api --- - -type Api - = "api" - :> "v1" - :> "metadata" - :> Capture "hash" (ApiT PoolId) - :> Get '[JSON] (ApiT StakePoolOffChainMetadata) - --- --- Client --- - --- | A client for fetching metadata from an Aggregation server. --- --- See also 'newClient' to construct a client. -newtype Client api m = Client - { getStakePoolMetadata - :: PoolId - -> m (Maybe StakePoolOffChainMetadata) - } - --- | A configuration for managing metadata with the aggregation server. --- Callbacks and parameterized effects allows for easier testing while a real --- specialization would wire a database connector in here. -data ClientConfig = ClientConfig - { manager - :: Manager - -- ^ An HTTP connection manager. - - , baseUrl - :: BaseUrl - -- ^ Url for reaching out to the metadata aggregation server. - - , cacheTTL - :: NominalDiffTime - -- ^ A constant for the maximum age of cached registry metadatabefore - -- it's considered to be stale. - } - --- | Callbacks interfaces allowing the client to cache and manage cached --- entities. These would typically be hooked up with a database. -data ClientCallbacks (m :: * -> *) = ClientCallbacks - { saveMetadata - :: PoolId -> (Maybe StakePoolOffChainMetadata, UTCTime) -> m () - -- ^ A callback action for storing an off-chain metadata. The callback - -- may be called with 'Nothing' to store that no metadata were found for - -- a particular 'PoolId; this allows for not constantly re-fetching data - -- for pools that are known to have no metadata. - - , getCachedMetadata - :: PoolId -> m (Maybe (Maybe StakePoolOffChainMetadata, UTCTime)) - -- ^ Action for fetching the last modification time of a cached result. - -- 'Nothing' is expected when there's no cached result. - } - --- | Create a new HTTP 'Client' in IO with caching support. -newClient - :: Tracer IO MetadataRegistryLog - -> ClientConfig - -> ClientCallbacks IO - -> Client Api IO -newClient tr ClientConfig{manager,baseUrl,cacheTTL} callbacks = - Client { getStakePoolMetadata } - where - run :: ClientM a -> IO (Either ClientError a) - run query = runClientM query (mkClientEnv manager baseUrl) - - getFromServer = - client (Proxy @Api) - - ClientCallbacks{getCachedMetadata,saveMetadata} = - callbacks - - getStakePoolMetadata - :: PoolId - -> IO (Maybe StakePoolOffChainMetadata) - getStakePoolMetadata pid = do - now <- getCurrentTime - getCachedMetadata pid >>= \case - Just (meta, time) | diffUTCTime now time < cacheTTL -> do - traceWith tr $ MsgUsingCached pid time - pure meta - - _expiredOrNotCached -> - (handleRequest <$> run (getFromServer (ApiT pid))) >>= \case - Right meta -> do - traceWith tr $ MsgRefreshingMetadata pid (meta, now) - saveMetadata pid (meta, now) - pure meta - Left e -> do - traceWith tr $ MsgUnexpectedError e - pure Nothing - where - handleRequest = \case - Right (ApiT meta) -> - Right (Just meta) - Left (FailureResponse _ res) | responseStatusCode res == status404 -> - Right Nothing - Left e -> - Left e - --- | Capture log events for the Client. -data MetadataRegistryLog - = MsgUsingCached PoolId UTCTime - | MsgRefreshingMetadata PoolId (Maybe StakePoolOffChainMetadata, UTCTime) - | MsgUnexpectedError ClientError - deriving (Generic, Show, Eq) - -instance HasPrivacyAnnotation MetadataRegistryLog -instance HasSeverityAnnotation MetadataRegistryLog where - getSeverityAnnotation = \case - MsgUsingCached{} -> Debug - MsgRefreshingMetadata{} -> Debug - MsgUnexpectedError{} -> Warning - -instance ToText MetadataRegistryLog where - toText = \case - MsgUsingCached pid time -> T.unwords - [ "Using cached result for" - , pretty pid - , "last modified at" - , T.pack (show time) - ] - MsgRefreshingMetadata pid (meta, time) -> T.unwords - [ "Setting metadata for " - , pretty pid - , "=" - , maybe "ø" (T.pack . show) meta - , ", last modified at" - , T.pack (show time) - ] - MsgUnexpectedError e -> T.unwords - [ "Unexpected error from the aggregation server:" - , T.pack (show e) - ] diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs index 09157692b45..ab7d095dcd2 100644 --- a/lib/core/src/Cardano/Wallet/Api/Types.hs +++ b/lib/core/src/Cardano/Wallet/Api/Types.hs @@ -163,7 +163,6 @@ import Cardano.Wallet.Primitive.Types , SlotLength (..) , SlotNo (..) , StakePoolMetadata - , StakePoolOffChainMetadata , StartTime (..) , SyncProgress (..) , TxIn (..) @@ -1237,11 +1236,6 @@ instance FromJSON (ApiT StakePoolMetadata) where instance ToJSON (ApiT StakePoolMetadata) where toJSON = genericToJSON defaultRecordTypeOptions . getApiT -instance FromJSON (ApiT StakePoolOffChainMetadata) where - parseJSON = fmap ApiT . genericParseJSON defaultRecordTypeOptions -instance ToJSON (ApiT StakePoolOffChainMetadata) where - toJSON = genericToJSON defaultRecordTypeOptions . getApiT - instance FromJSON (ApiT StartTime) where parseJSON = fmap (ApiT . StartTime) . parseJSON instance ToJSON (ApiT StartTime) where diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index 408cf23e9ee..13a9742f1b4 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -144,7 +144,6 @@ module Cardano.Wallet.Primitive.Types , poolIdBytesLength , StakePoolMetadata (..) , StakePoolMetadataHash (..) - , StakePoolOffChainMetadata (..) , StakePoolTicker (..) , sameStakePoolMetadata @@ -623,20 +622,6 @@ data StakePoolMetadata = StakePoolMetadata -- ^ Bech32-encoded address. } deriving (Eq, Show, Generic) --- | A subset of the 'StakePoolMetadata' but with the information that is --- available off-chain. The 'pledgeAddress' and 'owner' are actually part of the --- pool registration certificates published on-chain. -data StakePoolOffChainMetadata = StakePoolOffChainMetadata - { ticker :: StakePoolTicker - -- ^ Very short human-readable ID for the stake pool. - , name :: Text - -- ^ Name of the stake pool. - , description :: Text - -- ^ Short description of the stake pool. - , homepage :: Text - -- ^ Absolute URL for the stake pool's homepage link. - } deriving (Eq, Show, Generic) - -- | Returns 'True' iff metadata is exactly equal, modulo 'PoolOwner'. sameStakePoolMetadata :: StakePoolMetadata -> StakePoolMetadata -> Bool sameStakePoolMetadata a b = a { owner = same } == b { owner = same } diff --git a/lib/core/test/unit/Cardano/Pool/MetadataSpec.hs b/lib/core/test/unit/Cardano/Pool/MetadataSpec.hs deleted file mode 100644 index 871310eb628..00000000000 --- a/lib/core/test/unit/Cardano/Pool/MetadataSpec.hs +++ /dev/null @@ -1,324 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Cardano.Pool.MetadataSpec - ( spec - ) where - -import Prelude - -import Cardano.Pool.Metadata - ( Api - , BaseUrl (..) - , Client (..) - , ClientCallbacks (..) - , ClientConfig (..) - , MetadataRegistryLog (..) - , Scheme (..) - , defaultManagerSettings - , newClient - , newManager - ) -import Cardano.Wallet.Api.Server - ( Listen (..), withListeningSocket ) -import Cardano.Wallet.Api.Types - ( ApiT (..) ) -import Cardano.Wallet.Primitive.Types - ( PoolId (..), StakePoolOffChainMetadata (..), StakePoolTicker (..) ) -import Control.Concurrent - ( threadDelay ) -import Control.Concurrent.Async - ( async, cancel ) -import Control.Concurrent.MVar - ( modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar ) -import Control.Exception - ( bracket ) -import Control.Lens - ( at, (.~), (?~) ) -import Control.Monad - ( void ) -import Control.Tracer - ( Tracer, nullTracer ) -import Data.Aeson - ( toJSON ) -import Data.Function - ( (&) ) -import Data.Generics.Sum.Constructors - ( _Ctor ) -import Data.Maybe - ( isNothing ) -import Data.Proxy - ( Proxy (..) ) -import Data.String - ( fromString ) -import Data.Swagger - ( Referenced (..) - , Schema - , SwaggerType (..) - , maxLength - , minLength - , paramSchema - , properties - , required - , type_ - ) -import Data.Swagger.Schema.Validation - ( validateJSON ) -import Data.Text - ( Text ) -import Data.Text.Class - ( ToText (..) ) -import Data.Time.Clock - ( NominalDiffTime ) -import Data.Vector.Shuffle - ( mkSeed ) -import Network.Wai.Handler.Warp - ( runSettingsSocket, setBeforeMainLoop ) -import Servant - ( Server, err400, err404, serve, throwError ) -import Test.Hspec - ( Spec, around, describe, it ) -import Test.QuickCheck - ( ASCIIString (..) - , Arbitrary (..) - , PrintableString (..) - , choose - , counterexample - , label - , property - , vector - , vectorOf - , withMaxSuccess - ) -import Test.QuickCheck.Gen - ( Gen (..) ) -import Test.QuickCheck.Monadic - ( assert, monadicIO, monitor, run ) -import Test.QuickCheck.Random - ( mkQCGen ) -import Test.Utils.Trace - ( captureLogging, countMsg ) - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as BL8 -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import qualified Network.Wai.Handler.Warp as Warp - -spec :: Spec -spec = describe "Metadata - MockServer" $ do - - around (withMockServer noCache) - $ it "Mock Server works as intended" - $ \mkClient -> property $ \pid -> monadicIO $ do - let Client{getStakePoolMetadata} = mkClient nullTracer - run (getStakePoolMetadata pid) >>= \case - Nothing -> do - monitor $ label "No Corresponding Metadata" - res <- run (getStakePoolMetadata pid) - monitor $ counterexample $ unwords - [ "request isn't deterministic:" - , show res - ] - assert (isNothing res) - - Just metadata -> do - monitor $ label "Got Valid Metadata" - let json = toJSON $ ApiT metadata - let errs = validateJSON mempty metadataSchema json - monitor $ counterexample $ BL8.unpack $ Aeson.encode json - monitor $ counterexample $ show errs - assert (null errs) - - around (withMockServer inMemoryCache) - $ it "Cache metadata when called twice within the TTL" - $ \mkClient -> withMaxSuccess 4 $ property $ \pid -> monadicIO $ do - (logs, _) <- run $ captureLogging $ \tr -> do - let Client{getStakePoolMetadata} = mkClient tr - void $ getStakePoolMetadata pid - void $ getStakePoolMetadata pid - monitor $ counterexample $ unlines $ show <$> logs - assert $ countMsg (_Ctor @"MsgRefreshingMetadata") logs == 1 - assert $ countMsg (_Ctor @"MsgUsingCached") logs == 1 - - around (withMockServer inMemoryCache) - $ it "Fetch them again when fetching outside of the TTL" - $ \mkClient -> withMaxSuccess 4 $ property $ \pid -> monadicIO $ do - (logs, _) <- run $ captureLogging $ \tr -> do - let Client{getStakePoolMetadata} = mkClient tr - void $ getStakePoolMetadata pid - threadDelay' (2 * defaultCacheTTL) - void $ getStakePoolMetadata pid - assert $ countMsg (_Ctor @"MsgRefreshingMetadata") logs == 2 - assert $ countMsg (_Ctor @"MsgUsingCached") logs == 0 - - around (withMockServer inMemoryCache) - $ it "Returns 'Nothing' and a warning log message on failure" - $ \mkClient -> withMaxSuccess 1 $ monadicIO $ do - (logs, res) <- run $ captureLogging $ \tr -> do - let Client{getStakePoolMetadata} = mkClient tr - getStakePoolMetadata $ PoolId "NOT A VALID POOL ID" - monitor $ counterexample $ unlines $ show <$> logs - assert $ isNothing res - assert $ countMsg (_Ctor @"MsgUnexpectedError") logs == 1 - --- --- Mock Storage --- - --- | A default value for the cache, 1s -defaultCacheTTL :: NominalDiffTime -defaultCacheTTL = 1 - --- | Default dummy caching, callbacks are NoOps. -noCache :: IO (ClientCallbacks IO) -noCache = - pure $ ClientCallbacks - { saveMetadata = \_ _ -> pure () - , getCachedMetadata = \_ -> pure Nothing - } - --- | A simple cache using an in-memory 'Map' stored in an 'MVar' -inMemoryCache :: IO (ClientCallbacks IO) -inMemoryCache = do - mvar <- newMVar mempty - pure $ ClientCallbacks - { saveMetadata = \k v -> - modifyMVar_ mvar $ pure . Map.insert k v - , getCachedMetadata = \k -> - Map.lookup k <$> readMVar mvar - } - --- --- Mock Server --- - --- | Run a server in a separate thread. Block until the server is ready, and --- returns the TCP port on which the server is listening, and a handle to the --- server thread. -withMockServer - :: IO (ClientCallbacks IO) - -> ((Tracer IO MetadataRegistryLog -> Client Api IO) -> IO ()) - -> IO () -withMockServer mkCallbacks action = do - bracket acquire release inBetween - where - host = "127.0.0.1" - listen = ListenOnRandomPort - acquire = do - mvar <- newEmptyMVar - thread <- async $ withListeningSocket (fromString host) listen $ \case - Left e -> putMVar mvar (Left e) - Right (p, socket) -> do - let settings = Warp.defaultSettings - & setBeforeMainLoop (putMVar mvar (Right p)) - let application = serve (Proxy @Api) server - runSettingsSocket settings socket application - takeMVar mvar >>= \case - Left e -> error (show e) - Right port -> do - manager <- newManager defaultManagerSettings - let baseUrl = BaseUrl Http host port "" - let cacheTTL = defaultCacheTTL - let config = ClientConfig{manager,baseUrl,cacheTTL} - callbacks <- mkCallbacks - pure (\tr -> newClient tr config callbacks, thread) - release = cancel . snd - inBetween = action . fst - -server :: Server Api -server = hGetMetadata - where - -- A mock metadata server. Returns either a 404 not found, or, some - -- arbitrary metadata. It uses the pool's id as an random seed such that - -- results are consistent between calls. - hGetMetadata (ApiT pid) - | BS.length (getPoolId pid) /= 32 = throwError err400 - | otherwise = - if generateWith seed arbitrary - then throwError err404 - else return $ ApiT $ StakePoolOffChainMetadata - { ticker = - generateWith seed arbitrary - , name = - "_" <> generateWith seed (getPrintableText <$> arbitrary) - , description = - "_" <> generateWith seed (getPrintableText <$> arbitrary) - , homepage = mconcat - [ "https://" - , generateWith seed (getASCIIText <$> arbitrary) - , ".io" - ] - } - where - seed = toText pid - -metadataSchema :: Schema -metadataSchema = mempty - & required .~ - ["ticker", "name", "description", "homepage" ] - & properties .~ (mempty - & at "ticker" - ?~ Inline (mempty & paramSchema .~ tickerSchema) - & at "name" - ?~ Inline (mempty & paramSchema .~ nameSchema) - & at "description" - ?~ Inline (mempty & paramSchema .~ descriptionSchema) - & at "homepage" - ?~ Inline (mempty & paramSchema .~ homepageSchema) - ) - where - tickerSchema = mempty - & type_ ?~ SwaggerString - & minLength ?~ 3 - & maxLength ?~ 5 - nameSchema = mempty - & type_ ?~ SwaggerString - & minLength ?~ 1 - & maxLength ?~ 50 - descriptionSchema = mempty - & type_ ?~ SwaggerString - & minLength ?~ 1 - & maxLength ?~ 255 - homepageSchema = mempty - & type_ ?~ SwaggerString - --- --- Internals --- - -instance Arbitrary StakePoolTicker where - arbitrary = StakePoolTicker . T.pack <$> - (choose (3,5) >>= \n -> vectorOf n (choose ('A', 'Z'))) - -instance Arbitrary PoolId where - arbitrary = PoolId . BS.pack <$> vector 32 - -getPrintableText :: PrintableString -> Text -getPrintableText = T.pack . getPrintableString - -getASCIIText :: ASCIIString -> Text -getASCIIText = T.pack . getASCIIString - --- | Like QuickCheck 'generate', but allow using an explicit string as seed. -generateWith - :: Text -- ^ A 'Text' seed - -> Gen a -- ^ Quickcheck generator - -> a -generateWith seed (MkGen gen) = - gen (mkQCGen $ mkSeed seed) size - where - -- The size passed to the generator is always 30; See also: - -- - -- https://hackage.haskell.org/package/QuickCheck-2.13.2/docs/src/Test.QuickCheck.Gen.html#generate - size = 30 - --- | Like 'threadDelay', but works with 'NominalDiffTime' -threadDelay' :: NominalDiffTime -> IO () -threadDelay' = threadDelay . (`div` 1000000) . fromEnum From d393b7db500400330de5aec15cdbdb5058c25c5c Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 17 Jun 2020 17:08:33 +0200 Subject: [PATCH 13/14] 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. --- lib/core/src/Cardano/Wallet/Api/Types.hs | 28 -- .../src/Cardano/Wallet/Primitive/Types.hs | 19 +- .../Wallet/Api/ApiJormungandrStakePool.json | 292 ----------------- .../test/unit/Cardano/Pool/DB/Arbitrary.hs | 1 + .../test/unit/Cardano/Wallet/Api/TypesSpec.hs | 31 -- .../cardano-wallet-jormungandr.cabal | 5 + .../exe/cardano-wallet-jormungandr.hs | 6 +- .../src/Cardano/Pool/Jormungandr/Metadata.hs | 97 +++++- .../src/Cardano/Pool/Jormungandr/Metrics.hs | 9 +- .../src/Cardano/Wallet/Jormungandr.hs | 6 +- .../Cardano/Wallet/Jormungandr/Api/Server.hs | 29 +- .../data/Cardano/Wallet/Api/ApiStakePool.json | 309 ++++++++++++++++++ .../Wallet/Api/ApiStakePoolMetrics.json} | 42 +-- .../Jormungandr/Scenario/API/StakePools.hs | 59 ++-- .../Cardano/Pool/Jormungandr/MetadataSpec.hs | 3 +- .../Cardano/Pool/Jormungandr/MetricsSpec.hs | 4 +- .../Cardano/Wallet/Jormungandr/ApiSpec.hs | 169 +++++++++- 17 files changed, 653 insertions(+), 456 deletions(-) delete mode 100644 lib/core/test/data/Cardano/Wallet/Api/ApiJormungandrStakePool.json create mode 100644 lib/jormungandr/test/data/Cardano/Wallet/Api/ApiStakePool.json rename lib/{core/test/data/Cardano/Wallet/Api/ApiJormungandrStakePoolMetrics.json => jormungandr/test/data/Cardano/Wallet/Api/ApiStakePoolMetrics.json} (69%) diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs index ab7d095dcd2..d6d66642656 100644 --- a/lib/core/src/Cardano/Wallet/Api/Types.hs +++ b/lib/core/src/Cardano/Wallet/Api/Types.hs @@ -47,8 +47,6 @@ module Cardano.Wallet.Api.Types , ApiCoinSelectionInput (..) , ApiStakePool (..) , ApiStakePoolMetrics (..) - , ApiJormungandrStakePool (..) - , ApiJormungandrStakePoolMetrics (..) , ApiWallet (..) , ApiWalletPassphrase (..) , ApiWalletPassphraseInfo (..) @@ -407,22 +405,6 @@ data ApiStakePoolMetrics = ApiStakePoolMetrics , producedBlocks :: !(Quantity "block" Natural) } deriving (Eq, Generic, Show) -data ApiJormungandrStakePool = ApiJormungandrStakePool - { id :: !(ApiT PoolId) - , metrics :: !ApiJormungandrStakePoolMetrics - , apparentPerformance :: !Double - , metadata :: !(Maybe (ApiT StakePoolMetadata)) - , cost :: !(Quantity "lovelace" Natural) - , margin :: !(Quantity "percent" Percentage) - , desirability :: !Double - , saturation :: !Double - } deriving (Eq, Generic, Show) - -data ApiJormungandrStakePoolMetrics = ApiJormungandrStakePoolMetrics - { controlledStake :: !(Quantity "lovelace" Natural) - , producedBlocks :: !(Quantity "block" Natural) - } deriving (Eq, Generic, Show) - data ApiUtxoStatistics = ApiUtxoStatistics { total :: !(Quantity "lovelace" Natural) , scale :: !(ApiT BoundType) @@ -1082,16 +1064,6 @@ instance FromJSON ApiStakePoolMetrics where instance ToJSON ApiStakePoolMetrics where toJSON = genericToJSON defaultRecordTypeOptions -instance FromJSON ApiJormungandrStakePool where - parseJSON = genericParseJSON defaultRecordTypeOptions -instance ToJSON ApiJormungandrStakePool where - toJSON = genericToJSON defaultRecordTypeOptions - -instance FromJSON ApiJormungandrStakePoolMetrics where - parseJSON = genericParseJSON defaultRecordTypeOptions -instance ToJSON ApiJormungandrStakePoolMetrics where - toJSON = genericToJSON defaultRecordTypeOptions - instance FromJSON (ApiT WalletName) where parseJSON = parseJSON >=> eitherToParser . bimap ShowFmt ApiT . fromText instance ToJSON (ApiT WalletName) where diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index 13a9742f1b4..0420c6c37ff 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -145,7 +145,6 @@ module Cardano.Wallet.Primitive.Types , StakePoolMetadata (..) , StakePoolMetadataHash (..) , StakePoolTicker (..) - , sameStakePoolMetadata -- * Querying , SortOrder (..) @@ -599,18 +598,12 @@ instance ToText StakePoolMetadataHash where instance FromText StakePoolMetadataHash where fromText = fmap (StakePoolMetadataHash . getHash @"_") . hashFromText 32 --- | Information about a stake pool, published by a stake pool owner in the --- stake pool registry. --- --- The wallet searches for registrations involving the owner, to find metadata --- for a given PoolID. +-- | Information about a stake pool. -- -- The metadata information is not used directly by cardano-wallet, but rather -- passed straight through to API consumers. data StakePoolMetadata = StakePoolMetadata - { owner :: PoolOwner - -- ^ Bech32-encoded ed25519 public key. - , ticker :: StakePoolTicker + { ticker :: StakePoolTicker -- ^ Very short human-readable ID for the stake pool. , name :: Text -- ^ Name of the stake pool. @@ -618,16 +611,8 @@ data StakePoolMetadata = StakePoolMetadata -- ^ Short description of the stake pool. , homepage :: Text -- ^ Absolute URL for the stake pool's homepage link. - , pledgeAddress :: Text - -- ^ Bech32-encoded address. } deriving (Eq, Show, Generic) --- | Returns 'True' iff metadata is exactly equal, modulo 'PoolOwner'. -sameStakePoolMetadata :: StakePoolMetadata -> StakePoolMetadata -> Bool -sameStakePoolMetadata a b = a { owner = same } == b { owner = same } - where - same = PoolOwner mempty - -- | Very short name for a stake pool. newtype StakePoolTicker = StakePoolTicker { unStakePoolTicker :: Text } deriving stock (Generic, Show, Eq) diff --git a/lib/core/test/data/Cardano/Wallet/Api/ApiJormungandrStakePool.json b/lib/core/test/data/Cardano/Wallet/Api/ApiJormungandrStakePool.json deleted file mode 100644 index 62d3e236a1a..00000000000 --- a/lib/core/test/data/Cardano/Wallet/Api/ApiJormungandrStakePool.json +++ /dev/null @@ -1,292 +0,0 @@ -{ - "seed": -7826649569111114843, - "samples": [ - { - "saturation": 1.5519793660925632, - "metrics": { - "controlled_stake": { - "quantity": 101792220539, - "unit": "lovelace" - }, - "produced_blocks": { - "quantity": 10323423, - "unit": "block" - } - }, - "cost": { - "quantity": 196, - "unit": "lovelace" - }, - "margin": { - "quantity": 58.29, - "unit": "percent" - }, - "apparent_performance": 3.0472643669770787, - "metadata": { - "homepage": "h\u0003F", - "owner": "ed25519_pk1c7k9l4x2luc5x0deq4rfqla3lr9a5lwqpplf6h39s8prv2su7m4qg208fr", - "name": "\u001fB󷐧x񗺈qIS;񡣚e\u0004u񞔭\u000c\u000egg\u0005o1", - "ticker": "&\u000f(b", - "pledge_address": "򂲩\u0007xLz󝩺OC];򁒳qu^xr/gH񛅁𯵄Qr𲌉\u0006\u001e\u001b\\𡪅&}\u000f", - "description": "\u0018񷾿`􏻇\u0010v$\u001a\u000b9ꏞ롑򒭜UT\t2\r\u000bH񠄟A\\Z񵴤\u001b,A:`󷔫" - }, - "id": "7d4360401c2e9cdbc87a5438a0c3a04f166c703addf32f8c123d6a74404fd557", - "desirability": 59.364944965731645 - }, - { - "saturation": 1.3494398412862032, - "metrics": { - "controlled_stake": { - "quantity": 325597529392, - "unit": "lovelace" - }, - "produced_blocks": { - "quantity": 16792525, - "unit": "block" - } - }, - "cost": { - "quantity": 177, - "unit": "lovelace" - }, - "margin": { - "quantity": 1.67, - "unit": "percent" - }, - "apparent_performance": 4.251575790849382, - "metadata": { - "homepage": "G\u0001񀿲W2\u0000~񻿥4AW.󳙽9.\u0008\"F{%5\u0004g\u001f񩤊\u000eSL\u0017\u0011h\u0017򶉬\u0002?!m\u00163e\u001f,\u0012󸪐@q񭚞񉡕m񯧱,\u001e⋪􃹲|򢊈񡣇scw 52[졼󈁌p#]=\u0011UghH", - "owner": "ed25519_pk1n5ec86jzpreqqx26fuh50xmml0p3vdypjqzftdqjx2wh40h0tgcse639l5", - "name": "񸼶Om%e󜗄򪎛\u001b\u0011򉢞󋄐󈩿W4_T񤥶񡄞\u0012+.\u0011#\u0005󞶱󩓄5A񒔱dm\u0002o", - "ticker": "\u0013񔣊\u0003", - "pledge_address": "m򈪏:CP7񆳖#򸦯Uh}3񞭡@񍞷\u001a&V󙟎򐐲e񔩳𦒃Bq᫳񆧜\u0014󴪔0\u0008󦇬\u0005\u001b\u0016􈸁cObj[@\u0004I", - "owner": "ed25519_pk1k0tecz63s3ymqdtqgh7a4jw4qmgt6uk0q6wmvvu3s0rce92hh40qvflapc", - "name": "yJ~l|e`󻉍\u0011󞜟qi󏍇", - "ticker": "o\u001e_\u001b𰬄", - "pledge_address": "^nw^󊖟U7𬩇^C>fg0󘻟\u0016􎽈񍨯{\u0013!Q\u00141}񤙄y}9W", - "description": "WO\u0006\u0019Q\u001dD򯏌󯲜򝴤\u0002\u0019WN<󂲣>\u0018𚂤zm\u0002\u0006\u0007vT$󚸷J\u001ap4\u0011*Ds𨩼!󣡾\u0005e-\u0004>\u0004󿁠Sp򬁟;񅚺E\u0016\u0011񅝗񄧋-񎚗d𷫪0a\u0018򲡽\t󘧄Km\u0016𫹶L\u001c񩔭\n񴉈o񝘥!N\rq}QQF\u0000h9z𑰡C𿾎,򅼍b`򞯘񷬙󛆐\u0002򝆉MHo\u0003󒀇󍖄󺽀\u001f򆵝g\u000c󷷎zF.8񦞾gp=򥱉V`:򺷫$\u0016h杞\u0006󞨥􎆔2𐎄񥃪񎝛🻱󒶟k\u000eo򈣡\u0006Cb󢨇󹬟\"񥋀v4J񍍙.𧛼5`A\u001a\u000f(񆣕㟐z𻀓$Sp\u0002*𝠣\u001d" - }, - "id": "6f88b39681c8e95832daacac2607caadb9296fe227d7e4002129d0fd89150cec", - "desirability": 96.57249970643599 - }, - { - "saturation": 1.646578466604294, - "metrics": { - "controlled_stake": { - "quantity": 22621029932, - "unit": "lovelace" - }, - "produced_blocks": { - "quantity": 14981837, - "unit": "block" - } - }, - "cost": { - "quantity": 170, - "unit": "lovelace" - }, - "margin": { - "quantity": 73.22, - "unit": "percent" - }, - "apparent_performance": 0.6747156596326076, - "id": "135643368822c084f9b98c6c632c6afea5327d5fe0481d3772a04d3a4607adf1", - "desirability": 8.564894228346876 - }, - { - "saturation": 1.2353682409156277, - "metrics": { - "controlled_stake": { - "quantity": 822407014584, - "unit": "lovelace" - }, - "produced_blocks": { - "quantity": 12592798, - "unit": "block" - } - }, - "cost": { - "quantity": 59, - "unit": "lovelace" - }, - "margin": { - "quantity": 64.06, - "unit": "percent" - }, - "apparent_performance": 4.202651261159843, - "metadata": { - "homepage": "a\u0006FW]EF_񼾡5USQF\n\u001e[񹪃n𼀅VE򵑗CEvf\rP`", - "owner": "ed25519_pk1tgj09u35ph8la7dwp0tcc6thwalj9k2uaslpzrp9p66yyvzdqwhqw5k52a", - "name": "\"\u000eu󇺼O*aP@?\"󻰗􇄣򘦤Y𵛁𱑣.\u0001𵿼\u0003\u0000CS,e򖪉򦈖򾆑Wu\u0012𥠋C$3?K𞁧N\u0015&s8\u0016^P", - "ticker": "񎒄v\"", - "pledge_address": "󒊷}𖚖m\u0019񭿍𯈀8pkz\u001fUf\u0010~\u0002-􀴯m􏜂򗒆h곐񘶣o91\u000e󛚬A\u001b\u0006Z򼍲i$x" - }, - "id": "c446cbeb2fa2c4797c5964950eb1d491ff3565c52dd2804ea638c88731f62c02", - "desirability": 54.7843230282794 - } - ] -} \ No newline at end of file diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index b88f5aeb46e..cfa96d8672f 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -52,6 +52,7 @@ import Test.QuickCheck , choose , elements , listOf + , oneof , scale , shrinkIntegral , shrinkList diff --git a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs index 6b875387447..b7339bdd7e2 100644 --- a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs @@ -49,8 +49,6 @@ import Cardano.Wallet.Api.Types , ApiCoinSelectionInput (..) , ApiEpochInfo (..) , ApiFee (..) - , ApiJormungandrStakePool (..) - , ApiJormungandrStakePoolMetrics (..) , ApiMnemonicT (..) , ApiNetworkClock (..) , ApiNetworkInformation (..) @@ -294,8 +292,6 @@ spec = do jsonRoundtripAndGolden $ Proxy @(ApiT (Hash "Genesis")) jsonRoundtripAndGolden $ Proxy @ApiStakePool jsonRoundtripAndGolden $ Proxy @ApiStakePoolMetrics - jsonRoundtripAndGolden $ Proxy @ApiJormungandrStakePool - jsonRoundtripAndGolden $ Proxy @ApiJormungandrStakePoolMetrics jsonRoundtripAndGolden $ Proxy @(AddressAmount (ApiT Address, Proxy ('Testnet 0))) jsonRoundtripAndGolden $ Proxy @(ApiTransaction ('Testnet 0)) jsonRoundtripAndGolden $ Proxy @ApiWallet @@ -360,8 +356,6 @@ spec = do \has compatible ToJSON and ToSchema instances using validateToJSON." $ do validateEveryToJSON (Proxy :: Proxy (Api ('Testnet 0) ApiStakePool)) - validateEveryToJSON - (Proxy :: Proxy (Api ('Testnet 0) ApiJormungandrStakePool)) -- NOTE See (ToSchema WalletOrAccountPostData) validateEveryToJSON (Proxy :: Proxy ( @@ -1017,31 +1011,12 @@ instance Arbitrary ApiStakePoolMetrics where <*> (choose (0.0, 5.0)) <*> (Quantity . fromIntegral <$> choose (1::Integer, 22_600_000)) -instance Arbitrary ApiJormungandrStakePoolMetrics where - arbitrary = do - stakes <- Quantity . fromIntegral <$> choose (1::Integer, 1_000_000_000_000) - blocks <- Quantity . fromIntegral <$> choose (1::Integer, 22_600_000) - pure $ ApiJormungandrStakePoolMetrics stakes blocks - -instance Arbitrary ApiJormungandrStakePool where - arbitrary = ApiJormungandrStakePool - <$> arbitrary - <*> arbitrary - <*> choose (0.0, 5.0) - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> choose (0.0, 100.0) - <*> choose (0.0, 2.0) - instance Arbitrary StakePoolMetadata where arbitrary = StakePoolMetadata <$> arbitrary - <*> arbitrary <*> arbitraryText 50 <*> arbitraryMaybeText 255 <*> arbitraryText 100 - <*> arbitraryText 50 where arbitraryText maxLen = do len <- choose (1, maxLen) @@ -1408,12 +1383,6 @@ instance ToSchema ApiStakePool where instance ToSchema ApiStakePoolMetrics where declareNamedSchema _ = declareSchemaForDefinition "ApiStakePoolMetrics" -instance ToSchema ApiJormungandrStakePool where - declareNamedSchema _ = declareSchemaForDefinition "ApiJormungandrStakePool" - -instance ToSchema ApiJormungandrStakePoolMetrics where - declareNamedSchema _ = declareSchemaForDefinition "ApiStakePoolMetrics" - instance ToSchema ApiFee where declareNamedSchema _ = declareSchemaForDefinition "ApiFee" diff --git a/lib/jormungandr/cardano-wallet-jormungandr.cabal b/lib/jormungandr/cardano-wallet-jormungandr.cabal index 8df6ce11f52..e52327b74e4 100644 --- a/lib/jormungandr/cardano-wallet-jormungandr.cabal +++ b/lib/jormungandr/cardano-wallet-jormungandr.cabal @@ -155,6 +155,7 @@ test-suite unit , deepseq , directory , filepath + , file-embed , fmt , generic-arbitrary , generic-lens @@ -168,11 +169,15 @@ test-suite unit , QuickCheck , safe , servant + , servant-swagger + , swagger2 , temporary , text , text-class , time , transformers + , unordered-containers + , yaml , zip build-tools: hspec-discover diff --git a/lib/jormungandr/exe/cardano-wallet-jormungandr.hs b/lib/jormungandr/exe/cardano-wallet-jormungandr.hs index 00dbb6ea7a3..bb549d13cac 100644 --- a/lib/jormungandr/exe/cardano-wallet-jormungandr.hs +++ b/lib/jormungandr/exe/cardano-wallet-jormungandr.hs @@ -62,6 +62,8 @@ import Cardano.CLI ) import Cardano.Launcher ( StdStream (..) ) +import Cardano.Pool.Jormungandr.Metadata + ( ApiStakePool ) import Cardano.Startup ( ShutdownHandlerLog , installSignalHandlers @@ -77,8 +79,6 @@ import Cardano.Wallet.Api.Client ) import Cardano.Wallet.Api.Server ( HostPreference, Listen (..) ) -import Cardano.Wallet.Api.Types - ( ApiJormungandrStakePool ) import Cardano.Wallet.Jormungandr ( TracerSeverities , Tracers @@ -180,7 +180,7 @@ main = withUtf8Encoding $ do <> cmdWallet cmdWalletCreate walletClient <> cmdTransaction transactionClient walletClient <> cmdAddress addressClient - <> cmdStakePool @ApiJormungandrStakePool stakePoolClient + <> cmdStakePool @ApiStakePool stakePoolClient <> cmdNetwork networkClient <> cmdVersion <> cmdKey diff --git a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metadata.hs b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metadata.hs index 4d3aefc28ce..8c658c8d2c8 100644 --- a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metadata.hs +++ b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metadata.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -12,8 +14,14 @@ -- external registry. module Cardano.Pool.Jormungandr.Metadata - ( -- * Fetching metadata - MetadataConfig (..) + ( -- * Types + StakePoolMetadata(..) + , ApiStakePool (..) + , ApiStakePoolMetrics (..) + , sameStakePoolMetadata + + -- * Fetching metadata + , MetadataConfig (..) , cacheArchive , getMetadataConfig , getStakePoolMetadata @@ -36,7 +44,7 @@ import Cardano.BM.Data.Tracer import Cardano.Wallet.Api.Types ( ApiT (..) ) import Cardano.Wallet.Primitive.Types - ( PoolOwner (..), StakePoolMetadata (..) ) + ( PoolId, PoolOwner (..), StakePoolTicker ) import Codec.Archive.Zip ( EntrySelector , ZipArchive @@ -55,13 +63,25 @@ import Control.Monad.IO.Class import Control.Tracer ( Tracer, contramap, traceWith ) import Data.Aeson - ( eitherDecodeStrict ) + ( FromJSON (..) + , ToJSON (..) + , camelTo2 + , eitherDecodeStrict + , fieldLabelModifier + , genericParseJSON + , genericToJSON + , omitNothingFields + ) import Data.Either ( isLeft ) import Data.List ( find ) import Data.Maybe ( fromMaybe ) +import Data.Quantity + ( Percentage, Quantity (..) ) +import Data.Text + ( Text ) import Data.Text.Class ( ToText (..) ) import Data.Time.Clock @@ -74,6 +94,8 @@ import Network.HTTP.Client ( HttpException, parseUrlThrow ) import Network.HTTP.Simple ( httpSink ) +import Numeric.Natural + ( Natural ) import System.Directory ( createDirectoryIfMissing, getModificationTime, removeFile ) import System.Environment @@ -83,11 +105,78 @@ import System.FilePath import System.IO ( IOMode (WriteMode), hTell, withFile ) +import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import qualified Data.Conduit.Combinators as Conduit import qualified Data.Map.Strict as Map import qualified Data.Text as T +-- | Information about a stake pool, published by a stake pool owner in the +-- stake pool registry. +-- +-- The wallet searches for registrations involving the owner, to find metadata +-- for a given PoolID. +-- +-- The metadata information is not used directly by cardano-wallet, but rather +-- passed straight through to API consumers. +data StakePoolMetadata = StakePoolMetadata + { owner :: PoolOwner + -- ^ Bech32-encoded ed25519 public key. + , ticker :: StakePoolTicker + -- ^ Very short human-readable ID for the stake pool. + , name :: Text + -- ^ Name of the stake pool. + , description :: Maybe Text + -- ^ Short description of the stake pool. + , homepage :: Text + -- ^ Absolute URL for the stake pool's homepage link. + , pledgeAddress :: Text + -- ^ Bech32-encoded address. + } deriving (Eq, Show, Generic) + +-- | Returns 'True' iff metadata is exactly equal, modulo 'PoolOwner'. +sameStakePoolMetadata :: StakePoolMetadata -> StakePoolMetadata -> Bool +sameStakePoolMetadata a b = a { owner = same } == b { owner = same } + where + same = PoolOwner mempty + +data ApiStakePool = ApiStakePool + { id :: !(ApiT PoolId) + , metrics :: !ApiStakePoolMetrics + , apparentPerformance :: !Double + , metadata :: !(Maybe (ApiT StakePoolMetadata)) + , cost :: !(Quantity "lovelace" Natural) + , margin :: !(Quantity "percent" Percentage) + , desirability :: !Double + , saturation :: !Double + } deriving (Eq, Generic, Show) + +data ApiStakePoolMetrics = ApiStakePoolMetrics + { controlledStake :: !(Quantity "lovelace" Natural) + , producedBlocks :: !(Quantity "block" Natural) + } deriving (Eq, Generic, Show) + +instance FromJSON (ApiT StakePoolMetadata) where + parseJSON = fmap ApiT . genericParseJSON defaultRecordTypeOptions +instance ToJSON (ApiT StakePoolMetadata) where + toJSON = genericToJSON defaultRecordTypeOptions . getApiT + +instance FromJSON ApiStakePool where + parseJSON = genericParseJSON defaultRecordTypeOptions +instance ToJSON ApiStakePool where + toJSON = genericToJSON defaultRecordTypeOptions + +instance FromJSON ApiStakePoolMetrics where + parseJSON = genericParseJSON defaultRecordTypeOptions +instance ToJSON ApiStakePoolMetrics where + toJSON = genericToJSON defaultRecordTypeOptions + +defaultRecordTypeOptions :: Aeson.Options +defaultRecordTypeOptions = Aeson.defaultOptions + { fieldLabelModifier = camelTo2 '_' . dropWhile (== '_') + , omitNothingFields = True + } + {------------------------------------------------------------------------------- Fetching metadata from a registry -------------------------------------------------------------------------------} diff --git a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs index b111728353f..8768844fc83 100644 --- a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs +++ b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs @@ -50,7 +50,12 @@ import Cardano.BM.Data.Tracer import Cardano.Pool.DB ( DBLayer (..), ErrPointAlreadyExists ) import Cardano.Pool.Jormungandr.Metadata - ( RegistryLog, getMetadataConfig, getStakePoolMetadata ) + ( RegistryLog + , StakePoolMetadata + , getMetadataConfig + , getStakePoolMetadata + , sameStakePoolMetadata + ) import Cardano.Pool.Jormungandr.Performance ( readPoolsPerformances ) import Cardano.Pool.Jormungandr.Ranking @@ -78,8 +83,6 @@ import Cardano.Wallet.Primitive.Types , ProtocolParameters , SlotId , StakePool (..) - , StakePoolMetadata (..) - , sameStakePoolMetadata ) import Cardano.Wallet.Unsafe ( unsafeMkPercentage ) diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs index 53538695309..7b0660cf61b 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr.hs @@ -61,6 +61,8 @@ import Cardano.DB.Sqlite ( DBLog ) import Cardano.Launcher ( ProcessHasExited (..) ) +import Cardano.Pool.Jormungandr.Metadata + ( ApiStakePool ) import Cardano.Pool.Jormungandr.Metrics ( ErrListStakePools , StakePoolLayer (..) @@ -75,7 +77,7 @@ import Cardano.Wallet.Api import Cardano.Wallet.Api.Server ( HostPreference, Listen (..), ListenError (..) ) import Cardano.Wallet.Api.Types - ( ApiJormungandrStakePool, DecodeAddress, EncodeAddress ) + ( DecodeAddress, EncodeAddress ) import Cardano.Wallet.DB.Sqlite ( DefaultFieldValues (..), PersistState ) import Cardano.Wallet.Jormungandr.Api.Server @@ -259,7 +261,7 @@ serveWallet Tracers{..} sTolerance databaseDir hostPref listen backend beforeMai sockAddr <- getSocketName socket let settings = Warp.defaultSettings & setBeforeMainLoop (beforeMainLoop sockAddr nPort gp) - let application = Server.serve (Proxy @(ApiV2 n ApiJormungandrStakePool)) + let application = Server.serve (Proxy @(ApiV2 n ApiStakePool)) $ server byron icarus jormungandr pools ntp Server.start settings apiServerTracer tlsConfig socket application where diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs index 14e9a1d8195..601cda88c0d 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs @@ -22,6 +22,8 @@ module Cardano.Wallet.Jormungandr.Api.Server import Prelude +import Cardano.Pool.Jormungandr.Metadata + ( ApiStakePool (..), ApiStakePoolMetrics (..), StakePoolMetadata ) import Cardano.Pool.Jormungandr.Metrics ( ErrListStakePools (..), StakePoolLayer (..) ) import Cardano.Wallet @@ -84,12 +86,7 @@ import Cardano.Wallet.Api.Server , withLegacyLayer' ) import Cardano.Wallet.Api.Types - ( ApiErrorCode (..) - , ApiJormungandrStakePool (..) - , ApiJormungandrStakePoolMetrics (..) - , ApiT (..) - , SomeByronWalletPostData (..) - ) + ( ApiErrorCode (..), ApiT (..), SomeByronWalletPostData (..) ) import Cardano.Wallet.Primitive.AddressDerivation ( DelegationAddress (..), NetworkDiscriminant (..) ) import Cardano.Wallet.Primitive.AddressDerivation.Byron @@ -103,7 +100,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Random import Cardano.Wallet.Primitive.AddressDiscovery.Sequential ( SeqState ) import Cardano.Wallet.Primitive.Types - ( StakePool (..), StakePoolMetadata, WalletId ) + ( StakePool (..), WalletId ) import Control.Applicative ( liftA2 ) import Data.Generics.Internal.VL.Lens @@ -135,7 +132,7 @@ server -> jormungandr -> StakePoolLayer ErrListStakePools IO -> NtpClient - -> Server (Api n ApiJormungandrStakePool) + -> Server (Api n ApiStakePool) server byron icarus jormungandr spl ntp = wallets :<|> addresses @@ -178,7 +175,7 @@ server byron icarus jormungandr spl ntp = (\_ -> throwError err501) :<|> (\_ _ -> throwError err501) - stakePools :: Server (StakePools n ApiJormungandrStakePool) + stakePools :: Server (StakePools n ApiStakePool) stakePools = (listPools spl) :<|> joinStakePool jormungandr (knownStakePools spl) :<|> quitStakePool jormungandr @@ -281,18 +278,18 @@ listPools => StakePoolLayer e IO -> ApiT WalletId -- ^ Not needed, but there for consistency with haskell node. - -> Handler [ApiJormungandrStakePool] + -> Handler [ApiStakePool] listPools spl _walletId = - liftHandler $ map (uncurry mkApiJormungandrStakePool) <$> listStakePools spl + liftHandler $ map (uncurry mkApiStakePool) <$> listStakePools spl where - mkApiJormungandrStakePool + mkApiStakePool :: StakePool -> Maybe StakePoolMetadata - -> ApiJormungandrStakePool - mkApiJormungandrStakePool sp meta = - ApiJormungandrStakePool + -> ApiStakePool + mkApiStakePool sp meta = + ApiStakePool (ApiT $ view #poolId sp) - (ApiJormungandrStakePoolMetrics + (ApiStakePoolMetrics (Quantity $ fromIntegral $ getQuantity $ stake sp) (Quantity $ fromIntegral $ getQuantity $ production sp)) (sp ^. #performance) diff --git a/lib/jormungandr/test/data/Cardano/Wallet/Api/ApiStakePool.json b/lib/jormungandr/test/data/Cardano/Wallet/Api/ApiStakePool.json new file mode 100644 index 00000000000..264b8f7f2b5 --- /dev/null +++ b/lib/jormungandr/test/data/Cardano/Wallet/Api/ApiStakePool.json @@ -0,0 +1,309 @@ +{ + "seed": -5072594604095361809, + "samples": [ + { + "saturation": 0.7724797283930844, + "metrics": { + "controlled_stake": { + "quantity": 511562896898, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 9785888, + "unit": "block" + } + }, + "cost": { + "quantity": 56, + "unit": "lovelace" + }, + "margin": { + "quantity": 61.49, + "unit": "percent" + }, + "apparent_performance": 1.8187137861237368, + "metadata": { + "homepage": "|\u001c\u0003󉳌s𗍵𛬸!D򰄾~#\u0011\u0013򭢔𿺼\u001c\u0006\u0001񤧓򓾪𿉓U\u0018񂾺+iSZ\u0019;]RjJt񥖈/ZwG𚪩񯁅+PiqkNw;S5\r򜳖S񈼁|e򼬤򱂈+", + "owner": "ed25519_pk1gv7ut3y70urr3fykmtsxns32ntypeaqk5zpqlpe49fyy307pp8mqc37fk7", + "name": "\u001cf흖W򧘘2󍲆\\\u000e", + "ticker": "n󯕄𾮣80", + "pledge_address": "\u000e򿺂q𪎉\u001f{!K\u0012\u001a􂫫񾾚AV𦃏!\u00075e\nI\n\u0003^~", + "description": "<1𷛻X󡎹)\u0014\u000fX.\u000eQU\t0\u000c-FX𼥂B{+\u001buD􃃋}񻭮\u0017#c\u0011񿺴ZU񂫄򋺷l󠓞𰏝|񴱎\u0019\u001b񈫈󄅽c𑵴𼒣񐂑u\r,T)񯥩Sl𫴢;D5\u001bi󟨓3󾝗󳅼a+I𹩋(񇫆n\u0012󟂥+1\t?i\u0005R]v2fV񥷲\u000c.󡶍\u001dU󈮏\u0012𖿶8J&r􊮬𾌣鵿\u0019򌂀񛑽v5􃵚\u0019𨤾\u001cEc9)񵙯hgnC|E\u000c𦚈+I񇊠󦷒\n\u0006DV\u0017vc󀷻#\u0010nP6򡴥|,J\"`PW$Gy\u000b)\u0000\tBu^Q󑭾Zr\u0001񰡋G\r1$񟉉o딍􌙡򍸳T\\5󡫵򹡲r\u001b𿮾i\u000bT𲱓\u001bfK򙜁z\\pX7񣱡O\u0019g\u0019\u0006iw~󡋴9\u001a𻙠󡴹+\rx񐓺򧸴c5L }M!梯o/󝌳x6eO󝂦򀪯򛑤)\u0010&U[򁎱 🵠f񉄰\u001a\u0001" + }, + "id": "cca7cdcbec80aa69ff4494501d45474c8654784c0cf3ead0c8dcab84cd36902e", + "desirability": 38.14660395154822 + }, + { + "saturation": 0.9302655380240705, + "metrics": { + "controlled_stake": { + "quantity": 63415384930, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 10235498, + "unit": "block" + } + }, + "cost": { + "quantity": 110, + "unit": "lovelace" + }, + "margin": { + "quantity": 80.6, + "unit": "percent" + }, + "apparent_performance": 1.9389702100188426, + "metadata": { + "homepage": "W􌓧񳘲\u001c}\u001c*񺴿:}:;N\u000e󕬶\np񧌢W", + "owner": "ed25519_pk1u49qdxl6keesl5l6ulmlqt6ufs2m69al7mtyjfads63cd4x8s52slmaut4", + "name": "𑿻\u001e$󘾙\u0013a[5\u0002\u0008\\uF򧄓􇻡M񍰢U+b\u001f>a+\u0004\\aQ", + "ticker": "󹨅}񋵂󀻵", + "pledge_address": "򄯶󂀌񷶯󅇁-.*𷺃\u00065'3𽟵[C𞿗JKQy$\u0005􂖚򞰮\u0000q\u00026)>3n}N:\"Gg󂽕 i󜎀򚎴񼴌󆺀\u0013", + "description": "\u0012}1\u0007,M1{R񵽆򺾨򂬞􋜼+\u0011\u0018j\u0002|0|\u001a=Z\u000e󊀀tEr\n筭󿊁c\tk4\u0003c_\rb\u0003J𕹯Ywm\"2f|2A8񐛣򴮈\u001d󪯡E\u0012𐜫*󽂼\u0003?OrYA \u001e!~\u000f󙟄#󡹸h񐫅\u00146򞪝$L뎑􂘨0)񷶒\u0003󑖁3f^󔆜0 \u001e-񧿣\u0015~T\nQ󩝶=񄪡\u0008\u0000O\thP7\u0011K6&^ꀈ򰐶𒾟PXB\u00165𨯎x!\tbAM򄼔A󗜀W󪲐/}󝮋󺞖򢥰'$2B9񞳚\u000c\u0011" + }, + "id": "a3bb6b56c8620378fa42d26056846f92a02266a1945168b27b78d4634171897d", + "desirability": 82.53814324387344 + }, + { + "saturation": 0.14534161451124894, + "metrics": { + "controlled_stake": { + "quantity": 985984534323, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 14050042, + "unit": "block" + } + }, + "cost": { + "quantity": 145, + "unit": "lovelace" + }, + "margin": { + "quantity": 1.66, + "unit": "percent" + }, + "apparent_performance": 2.1924896868707866, + "metadata": { + "homepage": "}\u001d3𤔆󲞑dWx 5WN񌠵󒣐B\u0002iokQU龒򂽍G|q򉦇#^\t t;\u001f񦇨h6󿫽C:g𱋣", + "owner": "ed25519_pk1dx2ujrvl7syffha0csmxeh5zd0ueqwl5mh405jq6t58wz2hmumlsvgamuf", + "name": ";ty񰻓\u000eS񸡁u?\u001eC񘂇,-󮯒?򽪇", + "ticker": "e𬬍5", + "pledge_address": ">򩦍󿀏\u0010.", + "description": "󫚺󖱫i<\u000e,n\u0000󞰱\u0001𞺞T񯄦$OCa]R\u0014󒅲\u0008fx􉶕\u001bt)\u0015hY󥈄\u0018\u0004B\u0015?\t\u000e\u0007\u0000񽆓6xC" + }, + "id": "8eefa9ec540186248b64cd467715ae166cc512faa1504a3faeb1836f72ec0baa", + "desirability": 45.52094337214425 + }, + { + "saturation": 1.6383418614731213, + "metrics": { + "controlled_stake": { + "quantity": 118159885576, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 12189626, + "unit": "block" + } + }, + "cost": { + "quantity": 26, + "unit": "lovelace" + }, + "margin": { + "quantity": 91.51, + "unit": "percent" + }, + "apparent_performance": 4.2358670389951545, + "metadata": { + "homepage": "\u0006>A񘊭\u0011񻝕C`dC)3񡅄􅁞󗊲󻟲󉖄hD0𛹳7\u001b\u001b󲃾*$󰻙񮵉@~񽗨򽡉M\u00046$\u0004\u0010\u0014(I\u0002\u0014c\u0004C\u0008\u0002J𢯏>𒳽\".򫂬󛯖􆔮蘜򬶻􏯳\"\"g쀕𐯽", + "owner": "ed25519_pk142r5g9jl6ps9ke2dth3t25xm0pjpuj802crzl326zt0v0l8vpgjq2djlgg", + "name": "񁔘󅖽򕖖?`@3L1=18\u0012y\u0004󚏥<򉫇\u0006o*y@2}Z𹌯:.W\u0007}LIG'rLP56:m\u000e", + "ticker": "*X𻛤\u0003I", + "pledge_address": "򍇂\u0008Mb?z\u0003\u001b\u001d=xf𰺷1x5󨡩􈹱", + "description": "5󡋾\u0014:\u0013pᤊ\u0019Z򔃇󬉘K󈩦\u0010$$xVnq(\u001du7#k򺓃p'a/\u001e6񖒕2~󤙢񽒐򺴟𖷶񜇲\u001e񿺐\u0012\u0014^\u0015j\u0008?L񷨯{\tW1j{@;\t򥃉*𰰘(ypFc\u0011ady0\u000e\u0003!~=)O򈜥}\r֎NSN󾽑0󔆈𓉵H􅇕\u0000Z&QQV(l/f\u000b7[𖻣\u0005\u000bjz\u0013񣤽v\u001d\u0007T+2^yYo󞹝H\u0016v\u0017Rr򃢆=񜕐𧺼5􅤍Y󇍧@&񊸥GGrr[\rUpX5#1K\u0005f\u0013񼗃4󥏥򬔊rl򾃣|g𿇹\u0017\u0012\u0000\u0015[:B,𵨻\u000b\u00163EEz򄍬\u0008F]\u001aov񏁐b򙹜񏬶񕯿\u000f\u0008k𦞥򔆟󭿨d7􍅥\u001d(b\u000e" + }, + "id": "5297f24bcafebbb40c4b7087be414548654918f2373305d2d169344b2a18750b", + "desirability": 20.877044184351547 + }, + { + "saturation": 1.8348622415027995, + "metrics": { + "controlled_stake": { + "quantity": 811381995279, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 15546967, + "unit": "block" + } + }, + "cost": { + "quantity": 129, + "unit": "lovelace" + }, + "margin": { + "quantity": 80.56, + "unit": "percent" + }, + "apparent_performance": 1.0208921995543974, + "metadata": { + "homepage": "\u000e5s𜈑9H", + "owner": "ed25519_pk1vk832dj7v74ryz5fygu033v09z5zwkls836lrtvrfdjtk4ec0eaquqgfnh", + "name": "kW󜫨\",95\u0003M9𩯝\u0006n5xcfFA\u0017*mV󉾯򿾺J", + "ticker": "񄅵X\u0012$", + "pledge_address": "1\u000b", + "description": ">񤿯\u0014\u001fvZ R񎼛X𿻦@Ha󛂃B\u0006:񫙆􅘏\u001d?lCP=\n/󣏵󩋭M\u0012񂅀\u001d񯢊RN%L9n\u0017 a򀰑=OE:=[q6 ᑛ*\u000e,l󽩭𑦯{Nxv#-N\u001b+|\"X\u0008E/L\u0001򵈧b}󺂸񏾰A6𘳧\u0004􉂓Q7򫦢x4`B ?􅒜󤏼񹍃u1q\u0015k\u0011nN񀤭F󃊟𝐊[q<\u000cR\u00182jy/lt򍎹\u001d\u001fvpC!\u0019o\u0005(h􂕪R.pw𽷆\t%󇡀7T\u0019\u000c4+󈫥󍐋Q󮄲" + }, + "id": "f9f158b2f00b28efc219030dd9b1c28445d65e17b71ca4bca4df39b7c7de42ca", + "desirability": 98.94931204740077 + }, + { + "saturation": 0.4621603870305182, + "metrics": { + "controlled_stake": { + "quantity": 577379520103, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 16645001, + "unit": "block" + } + }, + "cost": { + "quantity": 221, + "unit": "lovelace" + }, + "margin": { + "quantity": 55.28, + "unit": "percent" + }, + "apparent_performance": 3.510284498914203, + "id": "c555faa7988239e93b52aba57b1451469b1de10d84afc624f7c6675ec76223f3", + "desirability": 23.186953161363398 + }, + { + "saturation": 0.6941486242848474, + "metrics": { + "controlled_stake": { + "quantity": 715002824251, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 4221754, + "unit": "block" + } + }, + "cost": { + "quantity": 55, + "unit": "lovelace" + }, + "margin": { + "quantity": 30.99, + "unit": "percent" + }, + "apparent_performance": 4.543440492601911, + "metadata": { + "homepage": "󰞹򊎃gY\u0005񔊞\u001eFPi񜵸A\u0007^\rar)񢜫񟉛\u0000_7󡬋󎾈-𷉝~q󺑓5\u000e6\u0000i+\u0017Q\u00069g,WE𒶎\u000f 󑒛v񅄯!^&{􎑯,\u0010()򹟇\u00159󡟆P-\u000c\u0012 O,\"{\u0005\u0013󙶙HG/I(𼙯m", + "owner": "ed25519_pk1p2x442652t4g6v9djfux7528nhu5xxknq8evdqsfuktuakk0tnwqq0lwhf", + "name": "r`9\u001c\u0007}Z񝊖 \u000b󴽸􌋠+\u001e\\񇁚^k[\u0014RR󣧫\u001f\u000c1񏦀/𬊒?\u0014V򨄍S򅁩\u0007\u000cx\u0015^󤦭*Y7󡍖\u0007S󴃼sy*v󒴎QQ48", + "description": "0d0)󈈭fF򃩢񊝬F[t1c\u0012C򜶵K8󬯲D𔑳񱪏8f\u001a!\u0000,󓦘󗰆L(6h8a@d󌶱\u001dA" + }, + "id": "1c0afc4f851c347e5a448ce627306254778ec7f5595e9a04a5b963cf23ff37e8", + "desirability": 50.219284629108984 + }, + { + "saturation": 0.3330227673008932, + "metrics": { + "controlled_stake": { + "quantity": 313659814531, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 9657330, + "unit": "block" + } + }, + "cost": { + "quantity": 5, + "unit": "lovelace" + }, + "margin": { + "quantity": 96.8, + "unit": "percent" + }, + "apparent_performance": 2.228449174403779, + "id": "0e991c64178c78f2c5cae4f0587854f27971aa5d0ea1a07d8a4689603571d711", + "desirability": 12.251272400551272 + }, + { + "saturation": 1.8471918739431505, + "metrics": { + "controlled_stake": { + "quantity": 239922781656, + "unit": "lovelace" + }, + "produced_blocks": { + "quantity": 13855738, + "unit": "block" + } + }, + "cost": { + "quantity": 217, + "unit": "lovelace" + }, + "margin": { + "quantity": 10.48, + "unit": "percent" + }, + "apparent_performance": 0.9899810574667411, + "metadata": { + "homepage": "W\u0005:󐱭`𶬦Mq*X\u0017Mn<*򉝙6m`R\u0007a~\u000c񃞰򷿱󤜉c蜈Qiu򙳒", + "owner": "ed25519_pk1xlxypjq90vemy2p4j9jgh758l3kpzardjunrrs2yj8vg5drjqjxsxln99c", + "name": "󈜘o!Cy\u0010B\u001f do eventually "Listing stake pools shows expected information" $ do - r <- request @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Default Empty + r <- request @[ApiStakePool] ctx Link.listJormungandrStakePools Default Empty expectResponseCode HTTP.status200 r verify r [ expectListSize 3 @@ -232,7 +233,7 @@ spec = do eventuallyUsingDelay (50*ms) "Shows error when listing stake pools on epoch boundaries" $ do - r <- request @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Default Empty + r <- request @[ApiStakePool] ctx Link.listJormungandrStakePools Default Empty verify r [ expectResponseCode HTTP.status503 , expectErrorMessage @@ -246,7 +247,7 @@ spec = do let nWithoutMetadata = length . filter (isNothing . view #metadata) (_, pools) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty (poolIdA, poolAOwner) <- registerStakePool nPort feePolicy WithMetadata (poolIdB, _poolBOwner) <- registerStakePool nPort feePolicy WithoutMetadata @@ -254,7 +255,7 @@ spec = do waitForNextEpoch ctx (_, pools') <- eventually "Stake pools are listed again" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty nWithoutMetadata pools' `shouldBe` nWithoutMetadata pools + 1 nWithMetadata pools' `shouldBe` nWithMetadata pools + 2 @@ -271,7 +272,7 @@ spec = do it "STAKE_POOLS_JOIN_01 - Can join a stakepool" $ \(_,_,ctx) -> do w <- fixtureWallet ctx (_, p:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty -- Join a pool joinStakePool @n ctx (p ^. #id) (w, fixturePassphrase) >>= flip verify @@ -293,7 +294,7 @@ spec = do it "STAKE_POOLS_JOIN_01 - Controlled stake increases when joining" $ \(_,_,ctx) -> do w <- fixtureWallet ctx (_, Right (p:_)) <- eventually "Stake pools are listed" $ - request @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Default Empty + request @[ApiStakePool] ctx Link.listJormungandrStakePools Default Empty -- Join a pool joinStakePool @n ctx (p ^. #id) (w, fixturePassphrase) >>= flip verify @@ -316,7 +317,7 @@ spec = do let existingPoolStake = getQuantity $ p ^. #metrics . #controlledStake let contributedStake = faucetUtxoAmt - fee eventually "Controlled stake increases for the stake pool" $ do - v <- request @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Default Empty + v <- request @[ApiStakePool] ctx Link.listJormungandrStakePools Default Empty verify v [ expectListField 0 (#metrics . #controlledStake) (.> Quantity (existingPoolStake + contributedStake)) @@ -327,7 +328,7 @@ spec = do it "STAKE_POOLS_JOIN_04 - Rewards accumulate and stop" $ \(_,_,ctx) -> do w <- fixtureWallet ctx (_, p:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty -- Join a pool joinStakePool @n ctx (p ^. #id) (w, fixturePassphrase) >>= flip verify @@ -386,7 +387,7 @@ spec = do \Delegate, stop in the next epoch, and still earn rewards" $ \(_,_,ctx) -> do w <- fixtureWallet ctx (_, p1:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty joinStakePool @n ctx (p1 ^. #id) (w, fixturePassphrase) >>= flip verify [ expectResponseCode HTTP.status202 @@ -420,7 +421,7 @@ spec = do it "STAKE_POOLS_JOIN_01x - \ \I can join if I have just the right amount" $ \(_,_,ctx) -> do (_, p:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty let (fee, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1 w <- fixtureWalletWith @n ctx [fee] joinStakePool @n ctx (p ^. #id) (w, "Secure Passphrase")>>= flip verify @@ -432,7 +433,7 @@ spec = do it "STAKE_POOLS_JOIN_01x - \ \I cannot join if I have not enough fee to cover" $ \(_,_,ctx) -> do (_, p:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty let (fee, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1 w <- fixtureWalletWith @n ctx [fee - 1] r <- joinStakePool @n ctx (p ^. #id) (w, "Secure Passphrase") @@ -441,7 +442,7 @@ spec = do it "STAKE_POOLS_JOIN_01x - I cannot join stake-pool with 0 balance" $ \(_,_,ctx) -> do (_, p:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty w <- emptyWallet ctx let (fee, _) = ctx ^. #_feeEstimator $ DelegDescription 0 0 1 r <- joinStakePool @n ctx (p ^. #id) (w, "Secure Passphrase") @@ -500,7 +501,7 @@ spec = do \ If a wallet joins a stake pool, others are not affected" $ \(_,_,ctx) -> do (wA, wB) <- (,) <$> fixtureWallet ctx <*> fixtureWallet ctx (_, p:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty -- Join a pool joinStakePool @n ctx (p ^. #id) (wA, fixturePassphrase) >>= flip verify @@ -537,7 +538,7 @@ spec = do describe "STAKE_POOLS_JOIN_02 - Passphrase must be correct to join" $ do let verifyIt ctx wallet pass expectations = do (_, p:_) <- eventually "Stake pools are listed" $ do - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty w <- wallet ctx r <- joinStakePool @n ctx (p ^. #id) (w, pass) verify r expectations @@ -584,7 +585,7 @@ spec = do let verifyIt ctx doStakePool pass expec = do (_, p:_) <- eventually "Stake pools are listed" $ do - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty w <- emptyWallet ctx r <- doStakePool ctx (p ^. #id) (w, T.pack pass) expectResponseCode HTTP.status400 r @@ -599,7 +600,7 @@ spec = do describe "STAKE_POOLS_JOIN/QUIT_02 - Passphrase must be text" $ do let verifyIt ctx sPoolEndp = do (_, p:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty w <- emptyWallet ctx let payload = Json [json| { "passphrase": 123 } |] r <- request @(ApiTransaction n) ctx (sPoolEndp p w) @@ -613,7 +614,7 @@ spec = do it "STAKE_POOLS_JOIN_03 - Byron wallet cannot join stake pool" $ \(_,_,ctx) -> do (_, p:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty w <- emptyRandomWallet ctx r <- joinStakePool @n ctx (p ^. #id) (w, "Secure Passprase") expectResponseCode HTTP.status404 r @@ -626,7 +627,7 @@ spec = do -- value) and therefore, the random selection has no influence. it "STAKE_POOLS_ESTIMATE_FEE_01 - fee matches eventual cost" $ \(_,_,ctx) -> do (_, p:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty w <- fixtureWallet ctx r <- delegationFee ctx w verify r @@ -694,7 +695,7 @@ spec = do it "STAKE_POOL_NEXT_01 - Can join/re-join another/quit stake pool" $ \(_,_,ctx) -> do (_, p1:p2:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty w <- fixtureWallet ctx request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify @@ -763,7 +764,7 @@ spec = do it "STAKE_POOL_NEXT_02 - Override join with join in the same epoch =>\ \ delegating to the last one in the end" $ \(_,_,ctx) -> do (_, p1:p2:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty w <- fixtureWallet ctx request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty @@ -795,7 +796,7 @@ spec = do \ and 2nd in epoch X + 3" $ \(_,_,ctx) -> do (_, p1:p2:_) <- eventually "Stake pools are listed" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty w <- fixtureWallet ctx request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify @@ -857,11 +858,11 @@ joinStakePoolWithWalletBalance ) => (Context t) -> [Natural] - -> IO (ApiWallet, ApiJormungandrStakePool) + -> IO (ApiWallet, ApiStakePool) joinStakePoolWithWalletBalance ctx balance = do w <- fixtureWalletWith @n ctx balance (_, p:_) <- eventually "Stake pools are listed in joinStakePoolWithWalletBalance" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty r <- joinStakePool @n ctx (p ^. #id) (w, "Secure Passphrase") expectResponseCode HTTP.status202 r -- Verify the certificate was discovered @@ -876,11 +877,11 @@ joinStakePoolWithWalletBalance ctx balance = do joinStakePoolWithFixtureWallet :: forall n t. (DecodeAddress n) => (Context t) - -> IO (ApiWallet, ApiJormungandrStakePool) + -> IO (ApiWallet, ApiStakePool) joinStakePoolWithFixtureWallet ctx = do w <- fixtureWallet ctx (_, p:_) <- eventually "Stake pools are listed in joinStakePoolWithFixtureWallet" $ - unsafeRequest @[ApiJormungandrStakePool] ctx Link.listJormungandrStakePools Empty + unsafeRequest @[ApiStakePool] ctx Link.listJormungandrStakePools Empty r <- joinStakePool @n ctx (p ^. #id) (w, fixturePassphrase) expectResponseCode HTTP.status202 r -- Verify the certificate was discovered diff --git a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetadataSpec.hs b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetadataSpec.hs index fe3004d534f..650f3c936f1 100644 --- a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetadataSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetadataSpec.hs @@ -12,6 +12,7 @@ import Cardano.Pool.Jormungandr.Metadata , MetadataConfig (..) , RegistryLog (..) , RegistryLogMsg (..) + , StakePoolMetadata (..) , cacheArchive , getMetadataConfig , getStakePoolMetadata @@ -19,7 +20,7 @@ import Cardano.Pool.Jormungandr.Metadata import Cardano.Wallet.Api.Types ( ApiT (..) ) import Cardano.Wallet.Primitive.Types - ( PoolOwner (..), StakePoolMetadata (..), StakePoolTicker ) + ( PoolOwner (..), StakePoolTicker ) import Cardano.Wallet.Unsafe ( unsafeFromText ) import Codec.Archive.Zip diff --git a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs index 017311a197f..e01c01ecbf2 100644 --- a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs @@ -26,7 +26,7 @@ import Cardano.Pool.DB import Cardano.Pool.DB.MVar ( newDBLayer ) import Cardano.Pool.Jormungandr.Metadata - ( envVarMetadataRegistry ) + ( StakePoolMetadata (..), envVarMetadataRegistry, sameStakePoolMetadata ) import Cardano.Pool.Jormungandr.Metrics ( Block (..) , ErrListStakePools (..) @@ -64,13 +64,11 @@ import Cardano.Wallet.Primitive.Types , ProtocolParameters (..) , SlotId (..) , SlotLength (..) - , StakePoolMetadata (..) , StartTime (..) , TxParameters (..) , flatSlot , flatSlot , fromFlatSlot - , sameStakePoolMetadata , slotParams , slotSucc ) diff --git a/lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/ApiSpec.hs b/lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/ApiSpec.hs index d86f0f6e770..b98828e9648 100644 --- a/lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/ApiSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/ApiSpec.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -12,6 +14,10 @@ module Cardano.Wallet.Jormungandr.ApiSpec import Prelude +import Cardano.Pool.Jormungandr.Metadata + ( ApiStakePool (..), ApiStakePoolMetrics (..), StakePoolMetadata (..) ) +import Cardano.Wallet.Api + ( ListStakePools ) import Cardano.Wallet.Jormungandr.Api.Types ( AccountState (..) , ApiStakeDistribution (..) @@ -22,37 +28,68 @@ import Cardano.Wallet.Jormungandr.Api.Types import Cardano.Wallet.Jormungandr.Binary ( Block ) import Cardano.Wallet.Primitive.Types - ( PoolId (..) ) + ( PoolId (..), PoolOwner (..), StakePoolTicker (..) ) import Cardano.Wallet.Unsafe - ( unsafeFromText ) + ( unsafeFromText, unsafeMkPercentage ) import Control.Monad ( replicateM ) +import Control.Monad.IO.Class + ( liftIO ) import Data.Aeson - ( eitherDecode ) + ( FromJSON, ToJSON, eitherDecode ) import Data.Aeson.QQ ( aesonQQ ) import Data.Either ( isLeft ) +import Data.FileEmbed + ( embedFile, makeRelativeToProject ) +import Data.List + ( foldl' ) +import Data.Maybe + ( fromMaybe ) import Data.Proxy ( Proxy (..) ) import Data.Quantity - ( Quantity (..) ) + ( Percentage (..), Quantity (..) ) +import Data.Swagger + ( Definitions, NamedSchema (..), Schema, ToSchema (..) ) +import Data.Swagger.Declare + ( Declare ) +import Data.Text + ( Text ) import Data.Text.Class ( ToText (..) ) +import Data.Typeable + ( Typeable ) import Data.Word - ( Word64 ) + ( Word64, Word8 ) +import Numeric.Natural + ( Natural ) import Servant.API ( MimeUnrender (..) ) +import Servant.Swagger.Test + ( validateEveryToJSON ) +import System.Environment + ( lookupEnv ) +import System.FilePath + ( () ) import Test.Aeson.Internal.RoundtripSpecs ( roundtripSpecs ) import Test.Hspec ( Spec, describe, it, shouldBe, shouldSatisfy ) import Test.QuickCheck - ( Arbitrary (..), applyArbitrary3 ) + ( Arbitrary (..), Gen, applyArbitrary3, choose, frequency, vector ) +import Test.Utils.Paths + ( getTestData ) +import qualified Cardano.Wallet.Api.Types as W import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Data.Yaml as Yaml +import qualified Test.Utils.Roundtrip as Utils spec :: Spec spec = do @@ -152,13 +189,68 @@ spec = do mimeUnrender (Proxy @JormungandrBinary) "" `shouldSatisfy` (isLeft @_ @Block) + describe + "verify that every type used with JSON content type in a servant API \ + \has compatible ToJSON and ToSchema instances using validateToJSON." $ do + validateEveryToJSON + (Proxy :: Proxy (ListStakePools ApiStakePool)) + + + describe + "can perform roundtrip JSON serialization & deserialization, \ + \and match existing golden files" $ do + jsonRoundtripAndGolden $ Proxy @ApiStakePool + jsonRoundtripAndGolden $ Proxy @ApiStakePoolMetrics + where decodeJSON = eitherDecode :: BL.ByteString -> Either String StakeApiResponse + jsonRoundtripAndGolden + :: forall a. (Arbitrary a, ToJSON a, FromJSON a, Typeable a) + => Proxy a + -> Spec + jsonRoundtripAndGolden = Utils.jsonRoundtripAndGolden + ($(getTestData) "Cardano" "Wallet" "Api") {------------------------------------------------------------------------------- Arbitrary Instances -------------------------------------------------------------------------------} +-- | Specification file, embedded at compile-time and decoded right away +specification :: Aeson.Value +specification = + unsafeDecode bytes + where + bytes = $( + let swaggerYaml = "../../specifications/api/swagger.yaml" + in liftIO (lookupEnv "SWAGGER_YAML") >>= + maybe (makeRelativeToProject swaggerYaml) pure >>= + embedFile + ) + unsafeDecode = + either (error . (msg <>) . show) Prelude.id . Yaml.decodeEither' + msg = "Whoops! Failed to parse or find the api specification document: " + +-- | Utility function to provide an ad-hoc 'ToSchema' instance for a definition: +-- we simply look it up within the Swagger specification. +declareSchemaForDefinition :: Text -> Declare (Definitions Schema) NamedSchema +declareSchemaForDefinition ref = do + let json = foldl' unsafeLookupKey specification ["components","schemas",ref] + case Aeson.eitherDecode' (Aeson.encode json) of + Left err -> error $ + "unable to decode schema for definition '" <> T.unpack ref <> "': " <> show err + Right schema -> + return $ NamedSchema (Just ref) schema + +unsafeLookupKey :: Aeson.Value -> Text -> Aeson.Value +unsafeLookupKey json k = case json of + Aeson.Object m -> fromMaybe bombMissing (HM.lookup k m) + m -> bombNotObject m + where + bombNotObject m = + error $ "given JSON value is NOT an object: " <> show m + bombMissing = + error $ "no value found in map for key: " <> T.unpack k + instance Arbitrary AccountState where arbitrary = applyArbitrary3 AccountState @@ -178,6 +270,71 @@ instance Arbitrary (Quantity "transaction-count" Word64) where arbitrary = Quantity <$> arbitrary shrink (Quantity q) = Quantity <$> shrink q +instance Arbitrary a => Arbitrary (W.ApiT a) where + arbitrary = W.ApiT <$> arbitrary + shrink = fmap W.ApiT . shrink . W.getApiT + +instance Arbitrary ApiStakePoolMetrics where + arbitrary = do + stakes <- Quantity . fromIntegral <$> choose (1::Integer, 1_000_000_000_000) + blocks <- Quantity . fromIntegral <$> choose (1::Integer, 22_600_000) + pure $ ApiStakePoolMetrics stakes blocks + +instance Arbitrary ApiStakePool where + arbitrary = ApiStakePool + <$> arbitrary + <*> arbitrary + <*> choose (0.0, 5.0) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> choose (0.0, 100.0) + <*> choose (0.0, 2.0) + +instance Arbitrary (Quantity "lovelace" Natural) where + shrink (Quantity 0) = [] + shrink _ = [Quantity 0] + arbitrary = Quantity . fromIntegral <$> (arbitrary @Word8) + +instance Arbitrary (Quantity "percent" Percentage) where + shrink _ = [] + arbitrary = Quantity <$> genPercentage + where + genPercentage = unsafeMkPercentage . fromRational . toRational <$> genDouble + where + genDouble :: Gen Double + genDouble = choose (0, 1) + +instance Arbitrary StakePoolMetadata where + arbitrary = StakePoolMetadata + <$> arbitrary + <*> arbitrary + <*> arbitraryText 50 + <*> arbitraryMaybeText 255 + <*> arbitraryText 100 + <*> arbitraryText 50 + where + arbitraryText maxLen = do + len <- choose (1, maxLen) + T.pack <$> vector len + arbitraryMaybeText maxLen = frequency + [ (9, Just <$> arbitraryText maxLen) + , (1, pure Nothing) ] + +instance Arbitrary PoolOwner where + arbitrary = PoolOwner . BS.pack <$> vector 32 + +instance Arbitrary StakePoolTicker where + arbitrary = unsafeFromText . T.pack <$> do + len <- choose (3, 5) + replicateM len arbitrary + +instance ToSchema ApiStakePool where + declareNamedSchema _ = declareSchemaForDefinition "ApiJormungandrStakePool" + +instance ToSchema ApiStakePoolMetrics where + declareNamedSchema _ = declareSchemaForDefinition "ApiJormungandrStakePoolMetrics" + {------------------------------------------------------------------------------- Test data -------------------------------------------------------------------------------} From fc7b95d18bcb4b609771cd97f6e8bf98beb892df Mon Sep 17 00:00:00 2001 From: IOHK Date: Wed, 17 Jun 2020 15:58:57 +0000 Subject: [PATCH 14/14] Regenerate nix --- nix/.stack.nix/cardano-wallet-jormungandr.nix | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/nix/.stack.nix/cardano-wallet-jormungandr.nix b/nix/.stack.nix/cardano-wallet-jormungandr.nix index 7e5d6cf98eb..6ae40d31abb 100644 --- a/nix/.stack.nix/cardano-wallet-jormungandr.nix +++ b/nix/.stack.nix/cardano-wallet-jormungandr.nix @@ -138,6 +138,7 @@ (hsPkgs."deepseq" or (errorHandler.buildDepError "deepseq")) (hsPkgs."directory" or (errorHandler.buildDepError "directory")) (hsPkgs."filepath" or (errorHandler.buildDepError "filepath")) + (hsPkgs."file-embed" or (errorHandler.buildDepError "file-embed")) (hsPkgs."fmt" or (errorHandler.buildDepError "fmt")) (hsPkgs."generic-arbitrary" or (errorHandler.buildDepError "generic-arbitrary")) (hsPkgs."generic-lens" or (errorHandler.buildDepError "generic-lens")) @@ -151,11 +152,15 @@ (hsPkgs."QuickCheck" or (errorHandler.buildDepError "QuickCheck")) (hsPkgs."safe" or (errorHandler.buildDepError "safe")) (hsPkgs."servant" or (errorHandler.buildDepError "servant")) + (hsPkgs."servant-swagger" or (errorHandler.buildDepError "servant-swagger")) + (hsPkgs."swagger2" or (errorHandler.buildDepError "swagger2")) (hsPkgs."temporary" or (errorHandler.buildDepError "temporary")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."text-class" or (errorHandler.buildDepError "text-class")) (hsPkgs."time" or (errorHandler.buildDepError "time")) (hsPkgs."transformers" or (errorHandler.buildDepError "transformers")) + (hsPkgs."unordered-containers" or (errorHandler.buildDepError "unordered-containers")) + (hsPkgs."yaml" or (errorHandler.buildDepError "yaml")) (hsPkgs."zip" or (errorHandler.buildDepError "zip")) ]; build-tools = [