feat: Add Custom Blockfrost URL Support

cabal.project

@@ -46,6 +46,14 @@ source-repository-package
 package postgresql-libpq
   flags: +use-pkg-config
 
+source-repository-package
+  type: git
+  location: https://github.com/blockfrost/blockfrost-haskell
+  tag: client-0.11.0.0
+  subdir: blockfrost-client
+          blockfrost-client-core
+          blockfrost-api
+
 -- Temporary until latest version is available on Hackage (or CHaP for that matter). Track https://github.com/IntersectMBO/cardano-addresses/issues/294.
 source-repository-package
   type: git

src/GeniusYield/GYConfig.hs

@@ -99,6 +99,7 @@ data GYLayer1ProviderInfo
   | GYOgmiosKupo {cpiOgmiosUrl :: !Text, cpiKupoUrl :: !Text, cpiMempoolCache :: !(Maybe MempoolCacheSettings), cpiLocalTxSubmissionCache :: !(Maybe LocalTxSubmissionCacheSettings)}
   | GYMaestro {cpiMaestroToken :: !(Confidential Text), cpiTurboSubmit :: !(Maybe Bool)}
   | GYBlockfrost {cpiBlockfrostKey :: !(Confidential Text)}
+  | GYBlockfrostCustom {cpiBlockfrostUrl :: !Text, cpiMaybeBlockfrostKey :: !(Maybe (Confidential Text))}
   deriving stock Show
 
 $( deriveFromJSON
@@ -130,13 +131,15 @@ The supported providers. The options are:
 - Ogmios node instance along with Kupo
 - Maestro blockchain API, provided its API token.
 - Blockfrost API, provided its API key.
+- Custom Blockfrost instance, provided its URL and optional API key.
 
 In JSON format, this essentially corresponds to:
 
 = { socketPath: FilePath, kupoUrl: string, mempoolCache: { cacheInterval: number }, localTxSubmissionCache: { cacheInterval: number } }
 | { ogmiosUrl: string, kupoUrl: string, mempoolCache: { cacheInterval: number }, localTxSubmissionCache: { cacheInterval: number } }
 | { maestroToken: string, turboSubmit: boolean }
 | { blockfrostKey: string }
+| { blockfrostUrl: string, maybeBlockfrostKey: string? }
 
 The constructor tags don't need to appear in the JSON.
 -}
@@ -165,6 +168,7 @@ isMaestro _ = False
 
 isBlockfrost :: GYCoreProviderInfo -> Bool
 isBlockfrost (GYCoreLayer1ProviderInfo GYBlockfrost {}) = True
+isBlockfrost (GYCoreLayer1ProviderInfo GYBlockfrostCustom {}) = True
 isBlockfrost _ = False
 
 findMaestroTokenAndNetId :: [GYCoreConfig] -> IO (Text, GYNetworkId)
@@ -399,6 +403,32 @@ withCfgProviders
             , Blockfrost.blockfrostProposals proj
             , Blockfrost.blockfrostMempoolTxs proj
             )
+        GYBlockfrostCustom url mkey -> do
+          let key = maybe "" id $ coerce mkey
+              proj = Blockfrost.networkIdToProjectCustom url key
+          blockfrostSlotActions <- makeSlotActions slotCachingTime $ Blockfrost.blockfrostGetSlotOfCurrentBlock proj
+          blockfrostGetParams <-
+            makeGetParameters
+              (Blockfrost.blockfrostProtocolParams proj)
+              (Blockfrost.blockfrostSystemStart proj)
+              (Blockfrost.blockfrostEraHistory proj)
+              (Blockfrost.blockfrostGetSlotOfCurrentBlock proj)
+          pure
+            ( blockfrostGetParams
+            , blockfrostSlotActions
+            , Blockfrost.blockfrostQueryUtxo proj
+            , Blockfrost.blockfrostLookupDatum proj
+            , Blockfrost.blockfrostSubmitTx proj
+            , Blockfrost.blockfrostAwaitTxConfirmed proj
+            , Blockfrost.blockfrostStakeAddressInfo proj
+            , Blockfrost.blockfrostGovState proj
+            , Blockfrost.blockfrostDRepState proj
+            , Blockfrost.blockfrostDRepsState proj
+            , Blockfrost.blockfrostStakePools proj
+            , Blockfrost.blockfrostConstitution proj
+            , Blockfrost.blockfrostProposals proj
+            , Blockfrost.blockfrostMempoolTxs proj
+            )
 
 logTiming :: GYProviders -> GYProviders
 logTiming providers@GYProviders {..} =

src/GeniusYield/Providers/Blockfrost.hs

@@ -17,6 +17,7 @@ module GeniusYield.Providers.Blockfrost (
   blockfrostProposals,
   blockfrostMempoolTxs,
   networkIdToProject,
+  networkIdToProjectCustom,
   BlockfrostProviderException (..),
 ) where
 
@@ -141,7 +142,7 @@ blockfrostAwaitTxConfirmed proj p@GYAwaitTxParameters {..} txId = blpAwaitTx 0
   blpAwaitTx attempt = do
     eTxInfo <- blockfrostQueryTx proj txId
     case eTxInfo of
-      Left Blockfrost.BlockfrostNotFound ->
+      Left (Blockfrost.BlockfrostNotFound _) ->
         threadDelay checkInterval
           >> blpAwaitTx (attempt + 1)
       Left err -> throwBlpvApiError "AwaitTx" err
@@ -154,7 +155,7 @@ blockfrostAwaitTxConfirmed proj p@GYAwaitTxParameters {..} txId = blpAwaitTx 0
   blpAwaitBlock attempt blockHash = do
     eBlockInfo <- blockfrostQueryBlock proj blockHash
     case eBlockInfo of
-      Left Blockfrost.BlockfrostNotFound ->
+      Left (Blockfrost.BlockfrostNotFound _) ->
         threadDelay checkInterval
           >> blpAwaitBlock (attempt + 1) blockHash
       Left err -> throwBlpvApiError "AwaitBlock" err
@@ -257,7 +258,7 @@ blockfrostUtxosAtAddress proj addr mAssetClass = do
  where
   locationIdent = "AddressUtxos"
   -- This particular error is fine in this case, we can just return empty list.
-  handler (Left Blockfrost.BlockfrostNotFound) = pure []
+  handler (Left (Blockfrost.BlockfrostNotFound _)) = pure []
   handler other = handleBlockfrostError locationIdent other
 
 blockfrostUtxosWithAsset :: Blockfrost.Project -> GYNonAdaToken -> IO GYUTxOs
@@ -276,7 +277,7 @@ blockfrostUtxosWithAsset proj ac = do
   locationIdent = "UtxosWithAsset"
   addressFromBlockfrost addr = maybeToRight DeserializeErrorAddress $ addressFromTextMaybe $ Blockfrost.unAddress addr
   -- This particular error is fine in this case, we can just return empty list.
-  handler (Left Blockfrost.BlockfrostNotFound) = pure []
+  handler (Left (Blockfrost.BlockfrostNotFound _)) = pure []
   handler other = handleBlockfrostError locationIdent other
 
 blockfrostUtxosAtPaymentCredential :: Blockfrost.Project -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs
@@ -298,7 +299,7 @@ blockfrostUtxosAtPaymentCredential proj cred mAssetClass = do
  where
   locationIdent = "PaymentCredentialUtxos"
   -- This particular error is fine in this case, we can just return empty list.
-  handler (Left Blockfrost.BlockfrostNotFound) = pure []
+  handler (Left (Blockfrost.BlockfrostNotFound _)) = pure []
   handler other = handleBlockfrostError locationIdent other
 
 blockfrostUtxosAtTxOutRef :: Blockfrost.Project -> GYTxOutRef -> IO (Maybe GYUTxO)
@@ -346,7 +347,7 @@ blockfrostUtxosAtTxOutRef proj ref = do
             }
  where
   -- This particular error is fine in this case, we can just return 'Nothing'.
-  handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing
+  handler (Left (Blockfrost.BlockfrostNotFound _)) = pure Nothing
   handler other = handleBlockfrostError locationIdent $ Just <$> other
   locationIdent = "TxUtxos(single)"
 
@@ -372,7 +373,7 @@ blockfrostUtxosAtTxOutRefs proj refs = do
           Blockfrost.getTxUtxos . Blockfrost.TxHash $
             Api.serialiseToRawBytesHexText txId
       case res of
-        Left Blockfrost.BlockfrostNotFound -> pure []
+        Left (Blockfrost.BlockfrostNotFound _) -> pure []
         Left err -> throwError err
         Right (Blockfrost._transactionUtxosOutputs -> outs) ->
           pure $
@@ -585,7 +586,7 @@ blockfrostLookupDatum p dh = do
     datumMaybe
  where
   -- This particular error is fine in this case, we can just return 'Nothing'.
-  handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing
+  handler (Left (Blockfrost.BlockfrostNotFound _)) = pure Nothing
   handler other = handleBlockfrostError locationIdent $ Just <$> other
   locationIdent = "LookupDatum"
 
@@ -598,7 +599,7 @@ blockfrostStakeAddressInfo p saddr = do
   Blockfrost.runBlockfrost p (Blockfrost.getAccount (Blockfrost.mkAddress $ stakeAddressToText saddr)) >>= handler
  where
   -- This particular error is fine.
-  handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing
+  handler (Left (Blockfrost.BlockfrostNotFound _)) = pure Nothing
   handler other =
     handleBlockfrostError "Account" $
       other <&> \accInfo ->
@@ -650,6 +651,20 @@ networkIdToProject nid pid =
     , projectId = pid
     }
 
+-- | Constructs a Blockfrost client with a custom URL.
+-- The custom URL should be the base URL for the Blockfrost instance (e.g., "https://custom.blockfrost.io")
+networkIdToProjectCustom ::
+  -- | The custom Blockfrost URL.
+  Text ->
+  -- | The Blockfrost project identifier (API key).
+  Text ->
+  Blockfrost.Project
+networkIdToProjectCustom url pid =
+  Blockfrost.Project
+    { projectEnv = Blockfrost.CustomURL (Text.unpack url)
+    , projectId = pid
+    }
+
 networkIdToBlockfrost :: GYNetworkId -> Blockfrost.Env
 networkIdToBlockfrost GYMainnet = Blockfrost.Mainnet
 networkIdToBlockfrost GYTestnetPreprod = Blockfrost.Preprod

tests/GeniusYield/Test/Config.hs

@@ -17,6 +17,7 @@ configTests =
     [ testCase "core-local" $ testParseResult isNodeKupo "core-local.json"
     , testCase "core-maestro" $ testParseResult isMaestro "core-maestro.json"
     , testCase "core-blockfrost" $ testParseResult isBlockfrost "core-blockfrost.json"
+    , testCase "core-blockfrost-custom" $ testParseResult isBlockfrost "core-blockfrost-custom.json"
     ]
 
 testParseResult :: (GYCoreProviderInfo -> Bool) -> FilePath -> IO ()

tests/GeniusYield/Test/Providers/Mashup.hs

@@ -193,4 +193,5 @@ isProviderSupported :: GYCoreConfig -> Bool
 isProviderSupported (cfgCoreProvider -> cp) = case cp of
   GYCoreLayer1ProviderInfo GYMaestro {} -> False
   GYCoreLayer1ProviderInfo GYBlockfrost {} -> False
+  GYCoreLayer1ProviderInfo GYBlockfrostCustom {} -> False
   _anyOther -> True

tests/mock-configs/core-blockfrost-custom.json

@@ -0,0 +1,4 @@
+{
+    "blockfrostUrl": "http://localhost:3000",
+    "maybeBlockfrostKey": "QED"
+}