Provide PoolId to the SMASH url builder

  SMASH just undergone a breaking change in its API, going from:

  ```
  GET api/v1/metadata/{hash}
  ```

  to

  ```
  GET api/v1/metadata/{poolId}/{hash}
  ```

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

@@ -151,7 +151,7 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
 
     , unfetchedPoolMetadataRefs
         :: Int
-        -> stm [(StakePoolMetadataUrl, StakePoolMetadataHash)]
+        -> stm [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
         -- ^ Read the list of metadata remaining to fetch from remote server,
         -- possibly empty if every pool already has an associated metadata
         -- cached.

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

@@ -262,7 +262,7 @@ mListRegisteredPools db@PoolDatabase{registrations} =
 
 mUnfetchedPoolMetadataRefs
     :: Int
-    -> ModelPoolOp [(StakePoolMetadataUrl, StakePoolMetadataHash)]
+    -> ModelPoolOp [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)]
 mUnfetchedPoolMetadataRefs n db@PoolDatabase{registrations,metadata} =
     ( Right (toTuple <$> take n (Map.elems unfetched))
     , db
@@ -277,9 +277,9 @@ mUnfetchedPoolMetadataRefs n db@PoolDatabase{registrations,metadata} =
 
     toTuple
         :: PoolRegistrationCertificate
-        -> (StakePoolMetadataUrl, StakePoolMetadataHash)
-    toTuple PoolRegistrationCertificate{poolMetadata} =
-        (metadataUrl, metadataHash)
+        -> (PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)
+    toTuple PoolRegistrationCertificate{poolId,poolMetadata} =
+        (poolId, metadataUrl, metadataHash)
       where
         Just (metadataUrl, metadataHash) = poolMetadata
 

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

@@ -261,14 +261,18 @@ newDBLayer trace fp timeInterpreter = do
 
         , unfetchedPoolMetadataRefs = \limit -> do
             let nLimit = T.pack (show limit)
+            let poolId        = fieldName (DBField PoolRegistrationPoolId)
             let metadataHash  = fieldName (DBField PoolRegistrationMetadataHash)
             let metadataUrl   = fieldName (DBField PoolRegistrationMetadataUrl)
             let retryAfter    = fieldName (DBField PoolFetchAttemptsRetryAfter)
             let registrations = tableName (DBField PoolRegistrationMetadataHash)
             let fetchAttempts = tableName (DBField PoolFetchAttemptsMetadataHash)
             let metadata      = tableName (DBField PoolMetadataHash)
             let query = T.unwords
-                    [ "SELECT", "a." <> metadataUrl, ",", "a." <> metadataHash
+                    [ "SELECT"
+                        , "a." <> poolId, ","
+                        , "a." <> metadataUrl, ","
+                        , "a." <> metadataHash
                     , "FROM", registrations, "AS a"
                     , "LEFT JOIN", fetchAttempts, "AS b"
                     , "ON"
@@ -298,9 +302,10 @@ newDBLayer trace fp timeInterpreter = do
                     , ";"
                     ]
 
-            let safeCast (Single a, Single b) = (,)
+            let safeCast (Single a, Single b, Single c) = (,,)
                     <$> fromPersistValue a
                     <*> fromPersistValue b
+                    <*> fromPersistValue c
 
             rights . fmap safeCast <$> rawSql query []
 

lib/core/src/Cardano/Pool/Metadata.hs

@@ -35,7 +35,8 @@ import Cardano.BM.Data.Tracer
 import Cardano.Wallet.Primitive.AddressDerivation
     ( hex )
 import Cardano.Wallet.Primitive.Types
-    ( StakePoolMetadata (..)
+    ( PoolId
+    , StakePoolMetadata (..)
     , StakePoolMetadataHash (..)
     , StakePoolMetadataUrl (..)
     )
@@ -104,35 +105,44 @@ newManager = HTTPS.newTlsManagerWith
 
 -- | Simply return a pool metadata url, unchanged
 identityUrlBuilder
-    :: StakePoolMetadataUrl
+    :: PoolId
+    -> StakePoolMetadataUrl
     -> StakePoolMetadataHash
     -> Either HttpException URI
-identityUrlBuilder (StakePoolMetadataUrl url) _ =
+identityUrlBuilder _ (StakePoolMetadataUrl url) _ =
     maybe (Left e) Right $ parseURI (T.unpack url)
   where
     e = InvalidUrlException (T.unpack url) "Invalid URL"
 
 -- | Build a URL from a metadata hash compatible with an aggregation registry
 registryUrlBuilder
     :: URI
+    -> PoolId
     -> StakePoolMetadataUrl
     -> StakePoolMetadataHash
     -> Either HttpException URI
-registryUrlBuilder baseUrl _ (StakePoolMetadataHash bytes) =
+registryUrlBuilder baseUrl pid _ (StakePoolMetadataHash bytes) =
     Right $ baseUrl
-        { uriPath = "/" <> intercalate "/" (pathSegments baseUrl ++ [hash])
+        { uriPath = "/" <> intercalate "/"
+            (pathSegments baseUrl ++ [pidStr,hashStr])
         }
   where
-    hash = T.unpack $ T.decodeUtf8 $ convertToBase Base16 bytes
+    hashStr = T.unpack $ T.decodeUtf8 $ convertToBase Base16 bytes
+    pidStr  = T.unpack $ toText pid
 
 fetchFromRemote
     :: Tracer IO StakePoolMetadataFetchLog
-    -> [StakePoolMetadataUrl -> StakePoolMetadataHash -> Either HttpException URI]
+    -> [   PoolId
+        -> StakePoolMetadataUrl
+        -> StakePoolMetadataHash
+        -> Either HttpException URI
+       ]
     -> Manager
+    -> PoolId
     -> StakePoolMetadataUrl
     -> StakePoolMetadataHash
     -> IO (Maybe StakePoolMetadata)
-fetchFromRemote tr builders manager url hash = runExceptTLog $ do
+fetchFromRemote tr builders manager pid url hash = runExceptTLog $ do
     chunk <- getChunk `fromFirst` builders
     when (blake2b256 chunk /= coerce hash) $ throwE $ mconcat
         [ "Metadata hash mismatch. Saw: "
@@ -159,7 +169,7 @@ fetchFromRemote tr builders manager url hash = runExceptTLog $ do
     fromFirst _ [] =
         throwE "Metadata server(s) didn't reply in a timely manner."
     fromFirst action (builder:rest) = do
-        uri <- withExceptT show $ except $ builder url hash
+        uri <- withExceptT show $ except $ builder pid url hash
         action uri >>= \case
             Nothing -> do
                 liftIO $ traceWith tr $ MsgFetchPoolMetadataFallback uri (null rest)

lib/core/test/unit/Cardano/Pool/DB/Properties.hs

@@ -849,22 +849,22 @@ prop_unfetchedPoolMetadataRefs DBLayer{..} entries =
         assertWith "fewer unfetchedPoolMetadataRefs than registrations"
             (length refs <= length entries)
         assertWith "all metadata hashes are indeed known"
-            (all ((`elem` hashes) . snd) refs)
+            (all ((`elem` hashes) . (\(_,_,c) -> c)) refs)
         assertWith "no duplicate"
             (L.nub refs == refs)
 
     propInteractionWithPutPoolMetadata = do
         refs <- run . atomically $ unfetchedPoolMetadataRefs 10
         unless (null refs) $ do
-            let [(url, hash)] = take 1 refs
+            let [(_, url, hash)] = take 1 refs
             metadata <- pick $ genStakePoolMetadata url
             run . atomically $ putPoolMetadata hash metadata
             refs' <- run . atomically $ unfetchedPoolMetadataRefs 10
             monitor $ counterexample $ unlines
                 [ "Read from DB (" <> show (length refs') <> "): " <> show refs'
                 ]
             assertWith "fetching metadata removes it from unfetchedPoolMetadataRefs"
-                (hash `notElem` (snd <$> refs'))
+                (hash `notElem` ((\(_,_,c) -> c) <$> refs'))
 
 prop_unfetchedPoolMetadataRefsIgnoring
     :: DBLayer IO
@@ -892,7 +892,7 @@ prop_unfetchedPoolMetadataRefsIgnoring DBLayer{..} entries =
             [ "Read from DB (" <> show (length refs) <> "): " <> show refs
             ]
         assertWith "recently failed URLs are ignored"
-            (recent `notElem` refs)
+            (recent `notElem` ((\(_,b,c) -> (b,c)) <$> refs))
 
 -- | successive readSystemSeed yield the exact same value
 prop_readSystemSeedIdempotent

lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs

@@ -545,16 +545,17 @@ monitorStakePools tr gp nl db@DBLayer{..} = do
 monitorMetadata
     :: Tracer IO StakePoolLog
     -> GenesisParameters
-    -> (   StakePoolMetadataUrl
+    -> (   PoolId
+        -> StakePoolMetadataUrl
         -> StakePoolMetadataHash
         -> IO (Maybe StakePoolMetadata)
        )
     -> DBLayer IO
     -> IO ()
 monitorMetadata tr gp fetchMetadata DBLayer{..} = forever $ do
     refs <- atomically (unfetchedPoolMetadataRefs 100)
-    successes <- fmap catMaybes $ forM refs $ \(url, hash) -> do
-        fetchMetadata url hash >>= \case
+    successes <- fmap catMaybes $ forM refs $ \(pid, url, hash) -> do
+        fetchMetadata pid url hash >>= \case
             Nothing -> Nothing <$ do
                 atomically $ putFetchAttempt (url, hash)