diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index 17a0ed21..1f430b8c 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -79,6 +79,7 @@ library GeniusYield.Providers.CachedQueryUTxOs GeniusYield.Providers.Common GeniusYield.Providers.GCP + GeniusYield.Providers.Hydra GeniusYield.Providers.Kupo GeniusYield.Providers.Maestro GeniusYield.Providers.Node @@ -309,6 +310,7 @@ test-suite atlas-tests GeniusYield.Test.GYTxBody GeniusYield.Test.GYTxOutRefCbor GeniusYield.Test.GYTxSkeleton + GeniusYield.Test.Hydra GeniusYield.Test.Providers GeniusYield.Test.Providers.Mashup GeniusYield.Test.RefInput diff --git a/src/GeniusYield/GYConfig.hs b/src/GeniusYield/GYConfig.hs index fdceb440..54338ad1 100644 --- a/src/GeniusYield/GYConfig.hs +++ b/src/GeniusYield/GYConfig.hs @@ -10,6 +10,8 @@ Stability : develop module GeniusYield.GYConfig ( GYCoreConfig (..), Confidential (..), + GYLayer1ProviderInfo (..), + GYLayer2ProviderInfo (..), GYCoreProviderInfo (..), withCfgProviders, coreConfigIO, @@ -41,9 +43,12 @@ import GeniusYield.Providers.Blockfrost qualified as Blockfrost -- import qualified GeniusYield.Providers.CachedQueryUTxOs as CachedQuery +import Control.Applicative ((<|>)) import Data.Sequence qualified as Seq import GeniusYield.Providers.CacheLocal import GeniusYield.Providers.CacheMempool (augmentQueryUTxOWithMempool) +import GeniusYield.Providers.Hydra +import GeniusYield.Providers.Hydra qualified as Hydra import GeniusYield.Providers.Kupo qualified as KupoApi import GeniusYield.Providers.Maestro qualified as MaestroApi import GeniusYield.Providers.Node (nodeGetDRepState, nodeGetDRepsState, nodeGetGovState, nodeStakeAddressInfo) @@ -89,6 +94,35 @@ $( deriveFromJSON ''LocalTxSubmissionCacheSettings ) +data GYLayer1ProviderInfo + = GYNodeKupo {cpiSocketPath :: !FilePath, cpiKupoUrl :: !Text, cpiMempoolCache :: !(Maybe MempoolCacheSettings), cpiLocalTxSubmissionCache :: !(Maybe LocalTxSubmissionCacheSettings)} + | GYOgmiosKupo {cpiOgmiosUrl :: !Text, cpiKupoUrl :: !Text, cpiMempoolCache :: !(Maybe MempoolCacheSettings), cpiLocalTxSubmissionCache :: !(Maybe LocalTxSubmissionCacheSettings)} + | GYMaestro {cpiMaestroToken :: !(Confidential Text), cpiTurboSubmit :: !(Maybe Bool)} + | GYBlockfrost {cpiBlockfrostKey :: !(Confidential Text)} + deriving stock Show + +$( deriveFromJSON + defaultOptions + { fieldLabelModifier = \fldName -> case drop 3 fldName of x : xs -> toLower x : xs; [] -> [] + , sumEncoding = UntaggedValue + } + ''GYLayer1ProviderInfo + ) + +data GYLayer2ProviderInfo + = GYHydraNodeKupo {l2piHydraHeadNodeUrl :: !Text, l2piHydraKupoUrl :: !Text, l2piLayer1ProviderInfo :: !GYLayer1ProviderInfo} + deriving stock Show + +$( deriveFromJSON + defaultOptions + { fieldLabelModifier = \fldName -> case drop 4 fldName of x : xs -> toLower x : xs; [] -> [] + , sumEncoding = UntaggedValue + } + ''GYLayer2ProviderInfo + ) + +-- TODO: Update this haddock? Or just share link to atlas docs. + {- | The supported providers. The options are: @@ -107,37 +141,30 @@ In JSON format, this essentially corresponds to: The constructor tags don't need to appear in the JSON. -} data GYCoreProviderInfo - = GYNodeKupo {cpiSocketPath :: !FilePath, cpiKupoUrl :: !Text, cpiMempoolCache :: !(Maybe MempoolCacheSettings), cpiLocalTxSubmissionCache :: !(Maybe LocalTxSubmissionCacheSettings)} - | GYOgmiosKupo {cpiOgmiosUrl :: !Text, cpiKupoUrl :: !Text, cpiMempoolCache :: !(Maybe MempoolCacheSettings), cpiLocalTxSubmissionCache :: !(Maybe LocalTxSubmissionCacheSettings)} - | GYMaestro {cpiMaestroToken :: !(Confidential Text), cpiTurboSubmit :: !(Maybe Bool)} - | GYBlockfrost {cpiBlockfrostKey :: !(Confidential Text)} + = GYCoreLayer1ProviderInfo GYLayer1ProviderInfo + | GYCoreLayer2ProviderInfo GYLayer2ProviderInfo deriving stock Show -$( deriveFromJSON - defaultOptions - { fieldLabelModifier = \fldName -> case drop 3 fldName of x : xs -> toLower x : xs; [] -> [] - , sumEncoding = UntaggedValue - } - ''GYCoreProviderInfo - ) +instance FromJSON GYCoreProviderInfo where + parseJSON v = (GYCoreLayer1ProviderInfo <$> parseJSON v) <|> (GYCoreLayer2ProviderInfo <$> parseJSON v) coreProviderIO :: FilePath -> IO GYCoreProviderInfo coreProviderIO = readJSON isNodeKupo :: GYCoreProviderInfo -> Bool -isNodeKupo GYNodeKupo {} = True +isNodeKupo (GYCoreLayer1ProviderInfo GYNodeKupo {}) = True isNodeKupo _ = False isOgmiosKupo :: GYCoreProviderInfo -> Bool -isOgmiosKupo GYOgmiosKupo {} = True +isOgmiosKupo (GYCoreLayer1ProviderInfo GYOgmiosKupo {}) = True isOgmiosKupo _ = False isMaestro :: GYCoreProviderInfo -> Bool -isMaestro GYMaestro {} = True +isMaestro (GYCoreLayer1ProviderInfo GYMaestro {}) = True isMaestro _ = False isBlockfrost :: GYCoreProviderInfo -> Bool -isBlockfrost GYBlockfrost {} = True +isBlockfrost (GYCoreLayer1ProviderInfo GYBlockfrost {}) = True isBlockfrost _ = False findMaestroTokenAndNetId :: [GYCoreConfig] -> IO (Text, GYNetworkId) @@ -148,7 +175,7 @@ findMaestroTokenAndNetId configs = do Just conf -> do let netId = cfgNetworkId conf case cfgCoreProvider conf of - GYMaestro (Confidential token) _ -> return (token, netId) + GYCoreLayer1ProviderInfo (GYMaestro (Confidential token) _) -> return (token, netId) _ -> throwIO $ userError "Missing Maestro Token" {- | @@ -200,7 +227,62 @@ withCfgProviders f = do (gyGetParameters, gySlotActions', gyQueryUTxO', gyLookupDatum, gySubmitTx, gyAwaitTxConfirmed, gyGetStakeAddressInfo, gyGetGovState, gyGetDRepState, gyGetDRepsState, gyGetStakePools, gyGetConstitution, gyGetProposals, gyGetMempoolTxs) <- case cfgCoreProvider of - GYNodeKupo path kupoUrl mmempoolCache mlocalTxSubCache -> do + GYCoreLayer1ProviderInfo l1ProviderInfo -> resolveLayer1ProviderInfo l1ProviderInfo + GYCoreLayer2ProviderInfo (GYHydraNodeKupo headNodeUrl kupoUrl l1i) -> do + (l1gyGetParameters, l1gySlotActions, _l1gyQueryUTxO, _l1gyLookupDatum, _l1gySubmitTx, _l1gyAwaitTxConfirmed, l1gyGetStakeAddressInfo, l1gyGetGovState, l1gyGetDRepState, l1gyGetDRepsState, l1gyGetStakePools, l1gyGetConstitution, l1gyGetProposals, l1gyGetMempoolTxs) <- resolveLayer1ProviderInfo l1i + henv <- newHydraApiEnv $ Text.unpack headNodeUrl + kEnv <- KupoApi.newKupoApiEnv $ Text.unpack kupoUrl + let queryUtxo = KupoApi.kupoQueryUtxo kEnv + pure + ( l1gyGetParameters {gyGetProtocolParameters' = Hydra.hydraProtocolParameters henv} -- Hack for now. + , l1gySlotActions + , queryUtxo + , KupoApi.kupoLookupDatum kEnv + , Hydra.hydraSubmitTx henv + , KupoApi.kupoAwaitTxConfirmed kEnv + , l1gyGetStakeAddressInfo + , l1gyGetGovState + , l1gyGetDRepState + , l1gyGetDRepsState + , l1gyGetStakePools + , l1gyGetConstitution + , l1gyGetProposals + , l1gyGetMempoolTxs + ) + + bracket (mkLogEnv ns cfgLogging) closeScribes $ \logEnv -> do + let gyLog' = + GYLogConfiguration + { cfgLogNamespace = mempty + , cfgLogContexts = mempty + , cfgLogDirector = Left logEnv + } + (gyQueryUTxO, gySlotActions) <- + {-if cfgUtxoCacheEnable + then do + (gyQueryUTxO, purgeCache) <- CachedQuery.makeCachedQueryUTxO gyQueryUTxO' gyLog' + -- waiting for the next block will purge the utxo cache. + let gySlotActions = gySlotActions' { gyWaitForNextBlock' = purgeCache >> gyWaitForNextBlock' gySlotActions'} + pure (gyQueryUTxO, gySlotActions, f) + else -} pure (gyQueryUTxO', gySlotActions') + let f' = + maybe + f + ( \case + True -> f . logTiming + False -> f + ) + cfgLogTiming + e <- try $ f' GYProviders {..} + case e of + Right a -> pure a + Left (err :: SomeException) -> do + logRun gyLog' GYError ((printf "ERROR: %s" $ show err) :: String) + throwIO err + where + resolveLayer1ProviderInfo cfgCoreL1Provider = do + case cfgCoreL1Provider of + (GYNodeKupo path kupoUrl mmempoolCache mlocalTxSubCache) -> do let info = nodeConnectInfo path cfgNetworkId kEnv <- KupoApi.newKupoApiEnv $ Text.unpack kupoUrl nodeSlotActions <- makeSlotActions slotCachingTime $ Node.nodeGetSlotOfCurrentBlock info @@ -231,7 +313,7 @@ withCfgProviders , Node.nodeProposals info , Node.nodeMempoolTxs info ) - GYOgmiosKupo ogmiosUrl kupoUrl mmempoolCache mlocalTxSubCache -> do + (GYOgmiosKupo ogmiosUrl kupoUrl mmempoolCache mlocalTxSubCache) -> do oEnv <- OgmiosApi.newOgmiosApiEnv $ Text.unpack ogmiosUrl kEnv <- KupoApi.newKupoApiEnv $ Text.unpack kupoUrl ogmiosSlotActions <- makeSlotActions slotCachingTime $ OgmiosApi.ogmiosGetSlotOfCurrentBlock oEnv @@ -267,7 +349,7 @@ withCfgProviders , OgmiosApi.ogmiosProposals oEnv , OgmiosApi.ogmiosMempoolTxsWs oEnv ) - GYMaestro (Confidential apiToken) turboSubmit -> do + (GYMaestro (Confidential apiToken) turboSubmit) -> do maestroApiEnv <- MaestroApi.networkIdToMaestroEnv apiToken cfgNetworkId maestroSlotActions <- makeSlotActions slotCachingTime $ MaestroApi.maestroGetSlotOfCurrentBlock maestroApiEnv maestroGetParams <- @@ -292,7 +374,7 @@ withCfgProviders , MaestroApi.maestroProposals maestroApiEnv , MaestroApi.maestroMempoolTxs maestroApiEnv ) - GYBlockfrost (Confidential key) -> do + (GYBlockfrost (Confidential key)) -> do let proj = Blockfrost.networkIdToProject cfgNetworkId key blockfrostSlotActions <- makeSlotActions slotCachingTime $ Blockfrost.blockfrostGetSlotOfCurrentBlock proj blockfrostGetParams <- @@ -318,36 +400,6 @@ withCfgProviders , Blockfrost.blockfrostMempoolTxs proj ) - bracket (mkLogEnv ns cfgLogging) closeScribes $ \logEnv -> do - let gyLog' = - GYLogConfiguration - { cfgLogNamespace = mempty - , cfgLogContexts = mempty - , cfgLogDirector = Left logEnv - } - (gyQueryUTxO, gySlotActions) <- - {-if cfgUtxoCacheEnable - then do - (gyQueryUTxO, purgeCache) <- CachedQuery.makeCachedQueryUTxO gyQueryUTxO' gyLog' - -- waiting for the next block will purge the utxo cache. - let gySlotActions = gySlotActions' { gyWaitForNextBlock' = purgeCache >> gyWaitForNextBlock' gySlotActions'} - pure (gyQueryUTxO, gySlotActions, f) - else -} pure (gyQueryUTxO', gySlotActions') - let f' = - maybe - f - ( \case - True -> f . logTiming - False -> f - ) - cfgLogTiming - e <- try $ f' GYProviders {..} - case e of - Right a -> pure a - Left (err :: SomeException) -> do - logRun gyLog' GYError ((printf "ERROR: %s" $ show err) :: String) - throwIO err - logTiming :: GYProviders -> GYProviders logTiming providers@GYProviders {..} = GYProviders diff --git a/src/GeniusYield/Providers/Common.hs b/src/GeniusYield/Providers/Common.hs index 4ba1e83c..5139ccc1 100644 --- a/src/GeniusYield/Providers/Common.hs +++ b/src/GeniusYield/Providers/Common.hs @@ -12,6 +12,7 @@ module GeniusYield.Providers.Common ( SubmitTxException (..), datumFromCBOR, newServantClientEnv, + newManager, fromJson, makeLastEraEndUnbounded, parseEraHist, @@ -112,12 +113,15 @@ silenceHeadersClientError other = other newServantClientEnv :: String -> IO Servant.ClientEnv newServantClientEnv baseUrl = do url <- Servant.parseBaseUrl baseUrl - manager <- - if Servant.baseUrlScheme url == Servant.Https - then HttpClient.newManager HttpClientTLS.tlsManagerSettings - else HttpClient.newManager HttpClient.defaultManagerSettings + manager <- newManager url pure $ Servant.mkClientEnv manager url +newManager :: Servant.BaseUrl -> IO HttpClient.Manager +newManager url = + if Servant.baseUrlScheme url == Servant.Https + then HttpClient.newManager HttpClientTLS.tlsManagerSettings + else HttpClient.newManager HttpClient.defaultManagerSettings + fromJson :: FromData a => LBS.ByteString -> Either SomeDeserializeError a fromJson b = do v <- first (DeserializeErrorAeson . Text.pack) $ Aeson.eitherDecode b diff --git a/src/GeniusYield/Providers/Hydra.hs b/src/GeniusYield/Providers/Hydra.hs new file mode 100644 index 00000000..67d4c288 --- /dev/null +++ b/src/GeniusYield/Providers/Hydra.hs @@ -0,0 +1,101 @@ +module GeniusYield.Providers.Hydra ( + HydraApiEnv, + newHydraApiEnv, + HydraProviderException (..), + hydraSubmitTx, + hydraProtocolParameters, +) where + +import Cardano.Api qualified as Api +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as BSL +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE +import GeniusYield.Imports (Exception, Generic, throwIO, (&)) +import GeniusYield.Providers.Common ( + newServantClientEnv, + ) +import GeniusYield.Types +import Network.WebSockets qualified as WS +import Servant.API ( + Get, + JSON, + (:>), + ) +import Servant.Client ( + BaseUrl (..), + ClientEnv, + ClientError, + ClientM, + baseUrl, + client, + runClientM, + ) + +newtype HydraApiEnv = HydraApiEnv {clientEnv :: ClientEnv} + +{- | Returns a new 'HydraApiEnv' given the base url to query from. + +>>> env <- newHydraApiEnv "http://localhost:4002" +-} +newHydraApiEnv :: String -> IO HydraApiEnv +newHydraApiEnv baseUrl = HydraApiEnv <$> newServantClientEnv baseUrl + +-- | Exceptions. +data HydraProviderException + = -- | Error from the Hydra API. + HydraApiError !Text !(Either ClientError Text) + | -- | Unable to decode response given by Hydra under Websocket connection. + HydraWebsocketDecodeError + -- | Received response. + !Text + deriving stock (Eq, Show) + deriving anyclass Exception + +{-# INLINEABLE runHydraClient #-} +runHydraClient :: HydraApiEnv -> ClientM a -> IO (Either ClientError a) +runHydraClient (HydraApiEnv cEnv) c = runClientM c cEnv + +{-# INLINEABLE handleHydraError #-} +handleHydraError :: Text -> Either ClientError a -> IO a +handleHydraError locationInfo = + either + (throwIO . HydraApiError locationInfo . Left) + pure + +processWSResponse :: Aeson.FromJSON a => Text -> IO a +processWSResponse msg = + case Aeson.eitherDecode (BSL.fromStrict $ TE.encodeUtf8 msg) of + Left err -> throwIO . HydraWebsocketDecodeError $ "error: " <> Text.pack err <> " while processing message: " <> msg + Right a -> pure a + +type HydraApi = "protocol-parameters" :> Get '[JSON] ApiProtocolParameters + +protocolParams :: ClientM ApiProtocolParameters +protocolParams = client @HydraApi Proxy + +hydraProtocolParameters :: HydraApiEnv -> IO ApiProtocolParameters +hydraProtocolParameters env = do + runHydraClient env protocolParams >>= handleHydraError "hydraProtocolParameters" + +newtype HydraTransactionId = HydraTransactionId {transactionId :: GYTxId} + deriving newtype Show + deriving stock Generic + deriving anyclass Aeson.FromJSON + +hydraSubmitTx :: HydraApiEnv -> GYSubmitTx +hydraSubmitTx (baseUrl . clientEnv -> BaseUrl {..}) tx = do + let newTxJson = + Aeson.object + [ "tag" Aeson..= ("NewTx" :: Text) + , "transaction" Aeson..= Aeson.toJSON (txToApi tx & Api.serialiseToTextEnvelope Nothing) + ] + WS.runClient baseUrlHost baseUrlPort baseUrlPath $ \conn -> do + WS.sendTextData conn $ TE.decodeUtf8 $ BSL.toStrict $ Aeson.encode newTxJson + -- ignore the greetings response. + (_ :: Text) <- WS.receiveData conn + txResponse <- WS.receiveData conn + txId <- processWSResponse @HydraTransactionId txResponse + pure $ transactionId txId diff --git a/src/GeniusYield/Test/Clb.hs b/src/GeniusYield/Test/Clb.hs index 5a818060..23677e01 100644 --- a/src/GeniusYield/Test/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -331,6 +331,8 @@ instance Monad m => GYTxQueryMonad (GYTxMonadClbT m) where proposals _actionIds = error "CLB does not support fetching of proposals" + govState = error "CLB does not support fetching of governance state" + -- Note, we need to define only one of drepState or drepsState unless required for performace reasons as they have default definition in terms of each other. slotConfig = do diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index ab32b114..2f90d9ab 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -161,8 +161,20 @@ buildUnsignedTxBody :: [(GYProposalProcedurePB, GYTxBuildWitness v)] -> Natural -> m (Either GYBuildTxError GYTxBody) -buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata vps pps donation = buildTxLoop cstrat extraLovelaceStart +buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata vps pps donation = + buildTxLoop + cstrat + ( if feea + feeb + ceiling (Ledger.unboundRational prMem) + ceiling (Ledger.unboundRational prSteps) == 0 + then + -- Fee not at all required. + 0 + else extraLovelaceStart + ) where + pp = gyBTxEnvProtocolParams env + feea = pp ^. ppMinFeeAL + feeb = pp ^. ppMinFeeBL + Ledger.Prices {prMem, prSteps} = pp ^. ppPricesL certsFinalised = finaliseTxCert (gyBTxEnvProtocolParams env) <$> certs step :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError ([GYTxInDetailed v], GYUTxOs, [GYTxOut v])) diff --git a/tests/GeniusYield/Test/Hydra.hs b/tests/GeniusYield/Test/Hydra.hs new file mode 100644 index 00000000..00e56749 --- /dev/null +++ b/tests/GeniusYield/Test/Hydra.hs @@ -0,0 +1,42 @@ +module GeniusYield.Test.Hydra ( + hydraTests, +) where + +import GeniusYield.GYConfig +import GeniusYield.Imports ((&)) +import GeniusYield.TxBuilder +import GeniusYield.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) + +aliceKey :: GYSigningKey 'GYKeyRolePayment +aliceKey = "5f9b911a636479ed83ba601ccfcba0ab9a558269dc19fdea910d27e5cdbb5fc8" + +aliceVKey :: GYVerificationKey GYKeyRolePayment +aliceVKey = getVerificationKey aliceKey + +aliceVKeyHash :: GYKeyHash GYKeyRolePayment +aliceVKeyHash = verificationKeyHash aliceVKey + +hydraTests :: TestTree +hydraTests = + testGroup + "hydra" + [ testCase "able to query, build and submit a hydra transaction" $ do + config <- coreConfigIO "secrets/hydra-config.json" + withCfgProviders config mempty $ \provider -> do + let nid = cfgNetworkId config + aliceAddress = addressFromPaymentKeyHash nid aliceVKeyHash + txBody <- + runGYTxBuilderMonadIO nid provider [aliceAddress] aliceAddress Nothing $ do + aliceUtxos <- utxosAtAddress aliceAddress Nothing + gyLogInfo' "" (show aliceUtxos) + let aliceUtxo = utxosToList aliceUtxos & head + let skel = mustHaveInput (GYTxIn (utxoRef aliceUtxo) GYTxInWitnessKey) + buildTxBody skel + print txBody + txId <- runGYTxMonadIO nid provider (AGYPaymentSigningKey aliceKey) Nothing [aliceAddress] aliceAddress Nothing $ do + signedTx <- signTxBody txBody + submitTx signedTx + print txId + ] diff --git a/tests/GeniusYield/Test/Providers/Mashup.hs b/tests/GeniusYield/Test/Providers/Mashup.hs index 50ef8f1d..ae7f9bda 100644 --- a/tests/GeniusYield/Test/Providers/Mashup.hs +++ b/tests/GeniusYield/Test/Providers/Mashup.hs @@ -191,6 +191,6 @@ supportedProviders = filter isProviderSupported isProviderSupported :: GYCoreConfig -> Bool isProviderSupported (cfgCoreProvider -> cp) = case cp of - GYMaestro {} -> False - GYBlockfrost {} -> False + GYCoreLayer1ProviderInfo GYMaestro {} -> False + GYCoreLayer1ProviderInfo GYBlockfrost {} -> False _anyOther -> True