Fix queryPoolFetchRetry

This query was incorrectly putting the Bech32 pool indentifier into
the pool URL field of the PoolFetchRetry struct (both were of type
`Text` in the database schema).

Instead of just fixing this in a simple/naive manner, the PoolUrl type
was pushed into the schema (no migration needed) to make querying that
field type safe.

Closes: #1347

Author: erikd

cardano-db-sync/app/test-http-get-json-metadata.hs

@@ -147,12 +147,12 @@ queryTestOfflineData = do
       )
   pure . organise $ map (convert . unValue4) res
   where
-    convert :: (Text, Text, ByteString, PoolHashId) -> (PoolHashId, TestOffline)
+    convert :: (Text, PoolUrl, ByteString, PoolHashId) -> (PoolHashId, TestOffline)
     convert (tname, url, hash, poolId) =
       ( poolId
       , TestOffline
           { toTicker = tname
-          , toUrl = PoolUrl url
+          , toUrl = url
           , toHash = PoolMetaHash hash
           }
       )

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs

@@ -26,7 +26,7 @@ import Cardano.Api.Shelley (
 import Cardano.BM.Trace (Trace, logDebug, logInfo, logWarning)
 import Cardano.Crypto.Hash (hashToBytes)
 import qualified Cardano.Crypto.Hashing as Crypto
-import Cardano.Db (DbLovelace (..), DbWord64 (..))
+import Cardano.Db (DbLovelace (..), DbWord64 (..), PoolUrl (..))
 import qualified Cardano.Db as DB
 import Cardano.DbSync.Api
 import Cardano.DbSync.Cache
@@ -540,7 +540,7 @@ insertMetaDataRef poolId txId md =
   lift . DB.insertPoolMetadataRef $
     DB.PoolMetadataRef
       { DB.poolMetadataRefPoolId = poolId
-      , DB.poolMetadataRefUrl = Ledger.urlToText (Shelley._poolMDUrl md)
+      , DB.poolMetadataRefUrl = PoolUrl $ Ledger.urlToText (Shelley._poolMDUrl md)
       , DB.poolMetadataRefHash = Shelley._poolMDHash md
       , DB.poolMetadataRefRegisteredTxId = txId
       }

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Offline/Http.hs

@@ -32,7 +32,7 @@ import Network.HTTP.Client (HttpException (..))
 import qualified Network.HTTP.Client as Http
 import qualified Network.HTTP.Types as Http
 
--- |Fetch error for the HTTP client fetching the pool offline metadata.
+-- | Fetch error for the HTTP client fetching the pool offline metadata.
 data FetchError
   = FEHashMismatch !PoolUrl !Text !Text
   | FEDataTooLong !PoolUrl

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Offline/Query.hs

@@ -6,7 +6,7 @@ module Cardano.DbSync.Era.Shelley.Offline.Query (
 ) where
 
 import Cardano.Db (
-  EntityField (PoolHashId, PoolHashView, PoolMetadataRefHash, PoolMetadataRefId, PoolMetadataRefPoolId, PoolMetadataRefUrl, PoolOfflineDataPmrId, PoolOfflineFetchErrorFetchTime, PoolOfflineFetchErrorId, PoolOfflineFetchErrorPmrId, PoolOfflineFetchErrorPoolId, PoolOfflineFetchErrorRetryCount),
+  EntityField (PoolHashId, PoolMetadataRefHash, PoolMetadataRefId, PoolMetadataRefPoolId, PoolMetadataRefUrl, PoolOfflineDataPmrId, PoolOfflineFetchErrorFetchTime, PoolOfflineFetchErrorId, PoolOfflineFetchErrorPmrId, PoolOfflineFetchErrorPoolId, PoolOfflineFetchErrorRetryCount),
   PoolHash,
   PoolHashId,
   PoolMetaHash (PoolMetaHash),
@@ -15,7 +15,7 @@ import Cardano.Db (
   PoolOfflineData,
   PoolOfflineFetchError,
   PoolOfflineFetchErrorId,
-  PoolUrl (PoolUrl),
+  PoolUrl,
  )
 import Cardano.DbSync.Era.Shelley.Offline.FetchQueue (newRetry, retryAgain)
 import Cardano.DbSync.Types (PoolFetchRetry (..))
@@ -92,13 +92,13 @@ queryNewPoolFetch now = do
         pure $ max_ (pmr ^. PoolMetadataRefId)
 
     convert ::
-      (Value PoolHashId, Value PoolMetadataRefId, Value Text, Value ByteString) ->
+      (Value PoolHashId, Value PoolMetadataRefId, Value PoolUrl, Value ByteString) ->
       PoolFetchRetry
     convert (Value phId, Value pmrId, Value url, Value pmh) =
       PoolFetchRetry
         { pfrPoolHashId = phId
         , pfrReferenceId = pmrId
-        , pfrPoolUrl = PoolUrl url
+        , pfrPoolUrl = url
         , pfrPoolMDHash = Just $ PoolMetaHash pmh
         , pfrRetry = newRetry now
         }
@@ -120,7 +120,7 @@ queryPoolFetchRetry _now = do
     pure
       ( pofe ^. PoolOfflineFetchErrorFetchTime
       , pofe ^. PoolOfflineFetchErrorPmrId
-      , ph ^. PoolHashView
+      , pmr ^. PoolMetadataRefUrl
       , pmr ^. PoolMetadataRefHash
       , ph ^. PoolHashId
       , pofe ^. PoolOfflineFetchErrorRetryCount
@@ -138,13 +138,13 @@ queryPoolFetchRetry _now = do
         pure $ max_ (pofe ^. PoolOfflineFetchErrorId)
 
     convert ::
-      (Value UTCTime, Value PoolMetadataRefId, Value Text, Value ByteString, Value PoolHashId, Value Word) ->
+      (Value UTCTime, Value PoolMetadataRefId, Value PoolUrl, Value ByteString, Value PoolHashId, Value Word) ->
       PoolFetchRetry
     convert (Value time, Value pmrId, Value url, Value pmh, Value phId, Value rCount) =
       PoolFetchRetry
         { pfrPoolHashId = phId
         , pfrReferenceId = pmrId
-        , pfrPoolUrl = PoolUrl url
+        , pfrPoolUrl = url
         , pfrPoolMDHash = Just $ PoolMetaHash pmh
         , pfrRetry = retryAgain (Time.utcTimeToPOSIXSeconds time) rCount
         }

cardano-db/src/Cardano/Db/Schema.hs

@@ -18,6 +18,9 @@
 module Cardano.Db.Schema where
 
 import Cardano.Db.Schema.Orphans ()
+import Cardano.Db.Schema.Types (
+  PoolUrl,
+ )
 import Cardano.Db.Types (
   DbInt65,
   DbLovelace,
@@ -220,7 +223,7 @@ share
 
   PoolMetadataRef
     poolId              PoolHashId          noreference
-    url                 Text
+    url                 PoolUrl             sqltype=varchar
     hash                ByteString          sqltype=hash32type
     registeredTxId      TxId                noreference     -- Only used for rollback.
     UniquePoolMetadataRef poolId url hash

cardano-db/src/Cardano/Db/Schema/Orphans.hs

@@ -3,6 +3,9 @@
 
 module Cardano.Db.Schema.Orphans () where
 
+import Cardano.Db.Schema.Types (
+  PoolUrl (..),
+ )
 import Cardano.Db.Types (
   DbInt65 (..),
   DbLovelace (..),
@@ -73,6 +76,13 @@ instance PersistField DbWord64 where
   fromPersistValue x =
     Left $ mconcat ["Failed to parse Haskell type DbWord64: ", Text.pack (show x)]
 
+instance PersistField PoolUrl where
+  toPersistValue = PersistText . unPoolUrl
+  fromPersistValue (PersistText txt) = Right $ PoolUrl txt
+  fromPersistValue (PersistByteString bs) = Right $ PoolUrl (Text.decodeLatin1 bs)
+  fromPersistValue x =
+    Left $ mconcat ["Failed to parse Haskell type PoolUrl: ", Text.pack (show x)]
+
 instance PersistField RewardSource where
   toPersistValue = PersistText . showRewardSource
   fromPersistValue (PersistLiteral bs) = Right $ readRewardSource (Text.decodeLatin1 bs)

cardano-db/test/Test/IO/Cardano/Db/Insert.hs

@@ -181,7 +181,7 @@ poolMetadataRef :: TxId -> PoolHashId -> PoolMetadataRef
 poolMetadataRef txid phid =
   PoolMetadataRef
     { poolMetadataRefPoolId = phid
-    , poolMetadataRefUrl = "best.pool.com"
+    , poolMetadataRefUrl = PoolUrl "best.pool.com"
     , poolMetadataRefHash = mkHash 32 '4'
     , poolMetadataRefRegisteredTxId = txid
     }