Try #1763:

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

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.
+
+    , readPoolMetadataRef
+        :: 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

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

@@ -24,11 +24,14 @@ import Cardano.Pool.DB.Model
     , PoolErr (..)
     , emptyPoolDatabase
     , mCleanPoolProduction
+    , mDeletePoolMetadataRef
     , mListRegisteredPools
+    , mPutPoolMetadataRef
     , mPutPoolProduction
     , mPutPoolRegistration
     , mPutStakeDistribution
     , mReadCursor
+    , mReadPoolMetadataRef
     , mReadPoolProduction
     , mReadPoolRegistration
     , mReadStakeDistribution
@@ -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
+
+        , readPoolMetadataRef = \a0 ->
+            modifyMVar db (pure . swap . mReadPoolMetadataRef a0)
+
         , readSystemSeed =
             modifyMVar db (fmap swap . mReadSystemSeed)
 

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

@@ -41,6 +41,9 @@ module Cardano.Pool.DB.Model
     , mPutPoolRegistration
     , mReadPoolRegistration
     , mListRegisteredPools
+    , mPutPoolMetadataRef
+    , mDeletePoolMetadataRef
+    , mReadPoolMetadataRef
     , 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 }
+    )
+
+mReadPoolMetadataRef :: Int -> PoolDatabase -> ([(PoolId, StakePoolMetadataRef)], PoolDatabase)
+mReadPoolMetadataRef 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
             }
         )

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]
+
+        , readPoolMetadataRef = \n -> do
+            fmap (fromPoolMetadataQueue . entityVal) <$> selectList [] [ LimitTo n ]
+
         , rollbackTo = \point -> do
             let (EpochNo epoch) = epochNumber point
             deleteWhere [ PoolProductionSlot >. point ]
@@ -240,6 +251,8 @@ newDBLayer trace fp = do
             deleteWhere ([] :: [Filter PoolOwner])
             deleteWhere ([] :: [Filter PoolRegistration])
             deleteWhere ([] :: [Filter StakeDistribution])
+            deleteWhere ([] :: [Filter PoolMetadata])
+            deleteWhere ([] :: [Filter PoolMetadataQueue])
 
         , atomically = runQuery
         })
@@ -326,3 +339,10 @@ fromStakeDistribution distribution =
     ( stakeDistributionPoolId distribution
     , Quantity (stakeDistributionStake distribution)
     )
+
+
+fromPoolMetadataQueue
+    :: PoolMetadataQueue
+    -> (PoolId, StakePoolMetadataRef)
+fromPoolMetadataQueue (PoolMetadataQueue poolId url hash) =
+    (poolId, StakePoolMetadataRef url hash)

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
 |]

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)