diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 0f311d8e..9f6723ba 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -207,11 +207,11 @@ jobs: - name: Generate documentation (cabal haddock) run: cabal haddock --html --hyperlink-source --haddock-options="--use-unicode" --haddock-quickjump - name: Upload haddock documentation - uses: actions/upload-pages-artifact@v1.0.8 + uses: actions/upload-pages-artifact@v3.0.1 with: path: ./dist-newstyle/build/x86_64-linux/ghc-9.6.5/${{env.ATLAS_VERSION}}/doc/html/atlas-cardano/ - name: Upload artifacts - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: - name: source-distribution-file + name: source-distribution-file-${{ matrix.runs-on }} path: ./dist-newstyle/sdist/${{env.ATLAS_VERSION}}.tar.gz diff --git a/CHANGELOG.md b/CHANGELOG.md index 2520cfa0..28fb078f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +## 0.11.1 + +* Adds support of Ogmios-Kupo provider, see section on providers at https://atlas-app.io/getting-started/endpoints. +* `ToJSON` instance for `GYTxOutRefCbor`. +* New `GeniusYield.Debug` module to perform Atlas's operation from repl. + ## 0.11.0 * Allows reference scripts to be of version greater than the minimum supported constrained version of `GYTxSkeleton`. Thanks [@SeungheonOh](https://github.com/SeungheonOh) for finding [this bug](https://github.com/geniusyield/atlas/issues/404)! Please visit the linked issue for more details. diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index 4dc10da2..36edd3ca 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: atlas-cardano -version: 0.11.0 +version: 0.11.1 synopsis: Application backend for Plutus smart contracts on Cardano description: Atlas is an all-in-one, Haskell-native application backend for writing off-chain code for on-chain Plutus smart contracts. @@ -86,6 +86,7 @@ library GeniusYield.Providers.Kupo GeniusYield.Providers.Maestro GeniusYield.Providers.Node + GeniusYield.Providers.Ogmios GeniusYield.Providers.Sentry GeniusYield.ReadJSON GeniusYield.Scripts.TestToken diff --git a/src/GeniusYield/Debug.hs b/src/GeniusYield/Debug.hs index cd3852d8..65ec93ae 100644 --- a/src/GeniusYield/Debug.hs +++ b/src/GeniusYield/Debug.hs @@ -1,17 +1,17 @@ module GeniusYield.Debug ( - coreConfigIO - , startDebugCps - , testCps - , stopDebugCps - , eval' - , GYNetworkId (..) + coreConfigIO, + startDebugCps, + testCps, + stopDebugCps, + eval', + GYNetworkId (..), ) where -import Control.Concurrent (MVar, newEmptyMVar, forkIO, putMVar, readMVar, takeMVar) -import GeniusYield.Types (GYProviders, GYNetworkId (..)) +import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, readMVar, takeMVar) +import Control.Monad (void) import GeniusYield.GYConfig (GYCoreConfig, coreConfigIO, withCfgProviders) import GeniusYield.TxBuilder (GYTxGameMonadIO, runGYTxGameMonadIO) -import Control.Monad (void) +import GeniusYield.Types (GYNetworkId (..), GYProviders) {- diff --git a/src/GeniusYield/GYConfig.hs b/src/GeniusYield/GYConfig.hs index fdc64606..c0a975a6 100644 --- a/src/GeniusYield/GYConfig.hs +++ b/src/GeniusYield/GYConfig.hs @@ -16,6 +16,7 @@ module GeniusYield.GYConfig ( coreProviderIO, findMaestroTokenAndNetId, isNodeKupo, + isOgmiosKupo, isMaestro, isBlockfrost, ) where @@ -43,6 +44,7 @@ import GeniusYield.Providers.Kupo qualified as KupoApi import GeniusYield.Providers.Maestro qualified as MaestroApi import GeniusYield.Providers.Node (nodeGetDRepState, nodeGetDRepsState, nodeStakeAddressInfo) import GeniusYield.Providers.Node qualified as Node +import GeniusYield.Providers.Ogmios qualified as OgmiosApi import GeniusYield.ReadJSON (readJSON) import GeniusYield.Types @@ -67,6 +69,7 @@ The supported providers. The options are: In JSON format, this essentially corresponds to: = { socketPath: FilePath, kupoUrl: string } +| { ogmiosUrl: string, kupoUrl: string } | { maestroToken: string, turboSubmit: boolean } | { blockfrostKey: string } @@ -74,6 +77,7 @@ The constructor tags don't need to appear in the JSON. -} data GYCoreProviderInfo = GYNodeKupo {cpiSocketPath :: !FilePath, cpiKupoUrl :: !Text} + | GYOgmiosKupo {cpiOgmiosUrl :: !Text, cpiKupoUrl :: !Text} | GYMaestro {cpiMaestroToken :: !(Confidential Text), cpiTurboSubmit :: !(Maybe Bool)} | GYBlockfrost {cpiBlockfrostKey :: !(Confidential Text)} deriving stock Show @@ -93,6 +97,10 @@ isNodeKupo :: GYCoreProviderInfo -> Bool isNodeKupo GYNodeKupo {} = True isNodeKupo _ = False +isOgmiosKupo :: GYCoreProviderInfo -> Bool +isOgmiosKupo GYOgmiosKupo {} = True +isOgmiosKupo _ = False + isMaestro :: GYCoreProviderInfo -> Bool isMaestro GYMaestro {} = True isMaestro _ = False @@ -178,6 +186,28 @@ withCfgProviders , nodeGetDRepsState info , Node.nodeStakePools info ) + GYOgmiosKupo ogmiosUrl kupoUrl -> do + oEnv <- OgmiosApi.newOgmiosApiEnv $ Text.unpack ogmiosUrl + kEnv <- KupoApi.newKupoApiEnv $ Text.unpack kupoUrl + ogmiosSlotActions <- makeSlotActions slotCachingTime $ OgmiosApi.ogmiosGetSlotOfCurrentBlock oEnv + ogmiosGetParams <- + makeGetParameters + (OgmiosApi.ogmiosProtocolParameters oEnv) + (OgmiosApi.ogmiosStartTime oEnv) + (OgmiosApi.ogmiosEraSummaries oEnv) + (OgmiosApi.ogmiosGetSlotOfCurrentBlock oEnv) + pure + ( ogmiosGetParams + , ogmiosSlotActions + , KupoApi.kupoQueryUtxo kEnv + , KupoApi.kupoLookupDatum kEnv + , OgmiosApi.ogmiosSubmitTx oEnv + , KupoApi.kupoAwaitTxConfirmed kEnv + , OgmiosApi.ogmiosStakeAddressInfo oEnv + , OgmiosApi.ogmiosGetDRepState oEnv + , OgmiosApi.ogmiosGetDRepsState oEnv + , OgmiosApi.ogmiosStakePools oEnv + ) GYMaestro (Confidential apiToken) turboSubmit -> do maestroApiEnv <- MaestroApi.networkIdToMaestroEnv apiToken cfgNetworkId maestroSlotActions <- makeSlotActions slotCachingTime $ MaestroApi.maestroGetSlotOfCurrentBlock maestroApiEnv diff --git a/src/GeniusYield/Providers/Ogmios.hs b/src/GeniusYield/Providers/Ogmios.hs new file mode 100644 index 00000000..bce7f7c9 --- /dev/null +++ b/src/GeniusYield/Providers/Ogmios.hs @@ -0,0 +1,612 @@ +{- | +Module : GeniusYield.Providers.Ogmios +Description : Ogmios provider for remote node connection. +Copyright : (c) 2025 GYELD GMBH +License : Apache 2.0 +Maintainer : support@geniusyield.co +Stability : develop +-} +module GeniusYield.Providers.Ogmios ( + OgmiosApiEnv, + newOgmiosApiEnv, + OgmiosProviderException (..), + ogmiosSubmitTx, + ogmiosProtocolParameters, + ogmiosGetSlotOfCurrentBlock, + ogmiosStakePools, + ogmiosGetDRepsState, + ogmiosGetDRepState, + ogmiosStakeAddressInfo, + ogmiosStartTime, + ogmiosEraSummaries, +) where + +import Cardano.Api qualified as Api +import Cardano.Api.Ledger qualified as Api.L +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api.S +import Cardano.Ledger.Alonzo.PParams qualified as Ledger +import Cardano.Ledger.Conway.PParams ( + ConwayPParams (..), + THKD (..), + ) +import Cardano.Ledger.Plutus qualified as Ledger +import Cardano.Slotting.Slot qualified as CSlot +import Cardano.Slotting.Time qualified as CTime +import Control.Monad ((<=<)) +import Data.Aeson (Value (Null), object, withArray, withObject, (.:), (.:?), (.=)) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust, listToMaybe) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Word (Word64) +import Deriving.Aeson +import GHC.Int (Int64) +import GeniusYield.Imports +import GeniusYield.Providers.Common ( + SubmitTxException (..), + newServantClientEnv, + parseEraHist, + ) +import GeniusYield.Types hiding (poolId) +import Maestro.Types.V1 (AsAda (..), AsBytes, AsLovelace (..), CostModel, EpochNo, EpochSize, EpochSlotLength, EraBound, LowerFirst, MaestroRational, MemoryCpuWith, MinFeeReferenceScripts, ProtocolParametersUpdateStakePool, ProtocolVersion) +import Maestro.Types.V1 qualified as Maestro +import Ouroboros.Consensus.HardFork.History qualified as Ouroboros +import Servant.API ( + JSON, + Post, + ReqBody, + (:>), + type (:<|>) (..), + ) +import Servant.Client ( + ClientEnv, + ClientError, + ClientM, + client, + runClientM, + ) +import Test.Cardano.Ledger.Core.Rational (unsafeBoundRational) + +{- $setup + +>>> :set -XOverloadedStrings -XTypeApplications +>>> import qualified Data.Aeson as Aeson +-} + +newtype OgmiosApiEnv = OgmiosApiEnv ClientEnv + +{- | Returns a new 'OgmiosApiEnv' given the base url to query from. + +>>> env <- newOgmiosApiEnv "http://localhost:1337" +-} +newOgmiosApiEnv :: String -> IO OgmiosApiEnv +newOgmiosApiEnv baseUrl = OgmiosApiEnv <$> newServantClientEnv baseUrl + +-- | Exceptions. +data OgmiosProviderException + = -- | Error from the Ogmios API. + OgmiosApiError !Text !ClientError + | -- | Received error response. + OgmiosErrorResponse !Text !Value + | -- | The API returned an unexpected number of era summaries. + OgmiosIncorrectEraHistoryLength ![EraSummary] + deriving stock (Eq, Show) + deriving anyclass Exception + +{-# INLINEABLE runOgmiosClient #-} +runOgmiosClient :: OgmiosApiEnv -> ClientM a -> IO (Either ClientError a) +runOgmiosClient (OgmiosApiEnv cEnv) c = runClientM c cEnv + +{-# INLINEABLE handleOgmiosError #-} +handleOgmiosError :: Text -> Either ClientError (OgmiosResponse a) -> IO a +handleOgmiosError locationInfo = + either + (throwIO . OgmiosApiError locationInfo) + -- `OgmiosResponse` would likely be `Right` as in case of error, we are in `ClientError` case. We need to make use of something like `WithStatus` for `OgmiosErrorResponse` to be actually useful. + (`reduceOgmiosResponse` (throwIO . OgmiosErrorResponse locationInfo)) + +{-# INLINEABLE reduceOgmiosResponse #-} +reduceOgmiosResponse :: Applicative f => OgmiosResponse a -> (Value -> f a) -> f a +reduceOgmiosResponse res e = case response res of + Left err -> e err + Right a -> pure a + +class ToJSONRPC a where + toMethod :: a -> Text + toParams :: a -> Maybe Value + +instance ToJSONRPC GYTx where + toMethod = const "submitTransaction" + toParams tx = Just $ toJSON $ Map.fromList [("transaction" :: Text, Map.fromList [("cbor" :: Text, txToHex tx)])] + +newtype OgmiosRequest a = OgmiosRequest a + +instance ToJSONRPC a => ToJSON (OgmiosRequest a) where + toJSON (OgmiosRequest a) = + object + [ "jsonrpc" .= ("2.0" :: Text) + , "method" .= toMethod a + , "params" .= toParams a + ] + +newtype OgmiosResponse a = OgmiosResponse + { response :: Either Value a + } + deriving stock Show + +instance FromJSON a => FromJSON (OgmiosResponse a) where + parseJSON = withObject "OgmiosResponse" $ \o -> do + result <- o .: "result" + case result of + Null -> OgmiosResponse . Left <$> o .: "error" + _ -> OgmiosResponse . Right <$> parseJSON result + +newtype TxIdResponse = TxIdResponse + { txid :: GYTxId + } + deriving stock (Show, Generic) + deriving FromJSON via CustomJSON '[FieldLabelModifier '[StripPrefix "tx"]] TxIdResponse + +newtype TxSubmissionResponse = TxSubmissionResponse + { transaction :: TxIdResponse + } + deriving stock (Show, Generic) + deriving anyclass FromJSON + +data OgmiosPP = OgmiosPP + +instance ToJSONRPC OgmiosPP where + toMethod = const "queryLedgerState/protocolParameters" + toParams = const Nothing + +data OgmiosTip = OgmiosTip + +instance ToJSONRPC OgmiosTip where + toMethod = const "queryLedgerState/tip" + toParams = const Nothing + +newtype OgmiosTipResponse = OgmiosTipResponse {slot :: GYSlot} + deriving stock (Show, Generic) + deriving anyclass FromJSON + +data OgmiosStakePools = OgmiosStakePools + +instance ToJSONRPC OgmiosStakePools where + toMethod = const "queryLedgerState/stakePools" + toParams = const Nothing + +type OgmiosStakePoolsResponse = Map GYStakePoolIdBech32 Value + +instance ToJSONRPC (Set.Set (GYCredential 'GYKeyRoleDRep)) where + toMethod = const "queryLedgerState/delegateRepresentatives" + toParams creds = + let (scriptCreds, keyCreds) = + Set.foldl' + ( \(!scriptCredsAcc, !keyCredsAcc) -> \case + GYCredentialByKey kh -> (scriptCredsAcc, kh : keyCredsAcc) + GYCredentialByScript sh -> (sh : scriptCredsAcc, keyCredsAcc) + ) + (mempty, mempty) + creds + in Just $ object ["scripts" .= scriptCreds, "keys" .= keyCreds] + +newtype AsEpoch = AsEpoch + { asEpochEpoch :: Natural + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "asEpoch", LowerFirst]] AsEpoch + +data OgmiosMetadata = OgmiosMetadata + { metadataUrl :: !GYUrl + , metadataHash :: !GYAnchorDataHash + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "metadata", LowerFirst]] OgmiosMetadata + +data OgmiosDRepStateResponse = OgmiosDRepStateResponse + { ogDRepStateDeposit :: !AsAda + , ogDRepStateMandate :: !AsEpoch + , ogDRepStateCred :: !(GYCredential 'GYKeyRoleDRep) + , ogDRepStateDelegs :: !(Set (GYCredential 'GYKeyRoleStaking)) + , ogDRepStateAnchor :: !(Maybe OgmiosMetadata) + } + deriving stock Show + +data OgCredType = OgCredTypeVerificationKey | OgCredTypeScript + deriving stock (Show, Eq, Ord, Generic) + deriving FromJSON via CustomJSON '[ConstructorTagModifier '[StripPrefix "OgCredType", LowerFirst]] OgCredType + +-- >>> Aeson.eitherDecode @(OgmiosResponse [OgmiosDRepStateResponse]) "{\"jsonrpc\":\"2.0\",\"method\":\"queryLedgerState/delegateRepresentatives\",\"result\":[{\"type\":\"registered\",\"from\":\"verificationKey\",\"id\":\"03ccae794affbe27a5f5f74da6266002db11daa6ae446aea783b972d\",\"mandate\":{\"epoch\":214},\"deposit\":{\"ada\":{\"lovelace\":500000000}},\"stake\":{\"ada\":{\"lovelace\":36452103822}},\"delegators\":[{\"from\":\"verificationKey\",\"credential\":\"053560b718fc0983281ac64fd56449b744a38b067bfccee6a4a2f403\"},{\"from\":\"verificationKey\",\"credential\":\"5a3f8c1b91adc65e2faf7fee12dcd9fce630703f99a09df6a331b9ea\"},{\"from\":\"verificationKey\",\"credential\":\"7c30635e2d876b90c1d505851683201081e122fd6ac665d0c36c8593\"},{\"from\":\"verificationKey\",\"credential\":\"9e22d4e534f80dfbd5d23ab6f21a53999f0a2e97f83926d56f9ec3eb\"},{\"from\":\"verificationKey\",\"credential\":\"bcac8a19f17801a28c2a352be936018ec96b67c147a5030218810896\"},{\"from\":\"verificationKey\",\"credential\":\"d0f4075a0ab29c0f71c8310f0b3151fbfee6fdc2de910e2f3471455a\"}]}]}" +-- Right (OgmiosResponse {response = Right [OgmiosDRepStateResponse {ogDRepStateDeposit = AsAda {asAdaAda = AsLovelace {asLovelaceLovelace = 500000000}}, ogDRepStateMandate = AsEpoch {asEpochEpoch = 214}, ogDRepStateCred = GYCredentialByKey (GYKeyHash (GYKeyRoleDRep) "03ccae794affbe27a5f5f74da6266002db11daa6ae446aea783b972d"), ogDRepStateDelegs = fromList [GYCredentialByKey (GYKeyHash (GYKeyRoleStaking) "053560b718fc0983281ac64fd56449b744a38b067bfccee6a4a2f403"),GYCredentialByKey (GYKeyHash (GYKeyRoleStaking) "5a3f8c1b91adc65e2faf7fee12dcd9fce630703f99a09df6a331b9ea"),GYCredentialByKey (GYKeyHash (GYKeyRoleStaking) "7c30635e2d876b90c1d505851683201081e122fd6ac665d0c36c8593"),GYCredentialByKey (GYKeyHash (GYKeyRoleStaking) "9e22d4e534f80dfbd5d23ab6f21a53999f0a2e97f83926d56f9ec3eb"),GYCredentialByKey (GYKeyHash (GYKeyRoleStaking) "bcac8a19f17801a28c2a352be936018ec96b67c147a5030218810896"),GYCredentialByKey (GYKeyHash (GYKeyRoleStaking) "d0f4075a0ab29c0f71c8310f0b3151fbfee6fdc2de910e2f3471455a")], ogDRepStateAnchor = Nothing}]}) +instance {-# OVERLAPPING #-} FromJSON [OgmiosDRepStateResponse] where + parseJSON = withArray "[OgmiosDRepStateResponse]" $ \arr -> do + catMaybes <$> traverse parseDRepStateResponse (toList arr) + where + parseDRepStateResponse = withObject "OgmiosDRepStateResponse" $ \o -> do + drepType :: String <- o .: "type" + if drepType /= "registered" + then pure Nothing + else + Just <$> do + ogDRepStateDeposit <- o .: "deposit" + ogDRepStateMandate <- o .: "mandate" + credType <- o .: "from" + ogDRepStateCred <- case credType of + OgCredTypeVerificationKey -> GYCredentialByKey <$> o .: "id" + OgCredTypeScript -> GYCredentialByScript <$> o .: "id" + ogDRepStateDelegs <- do + delegs <- o .: "delegators" + Set.fromList + <$> traverse + ( \d -> do + delegCredType <- d .: "from" + case delegCredType of + OgCredTypeVerificationKey -> GYCredentialByKey <$> d .: "credential" + OgCredTypeScript -> GYCredentialByScript <$> d .: "credential" + ) + delegs + ogDRepStateAnchor <- o .:? "metadata" + pure $ OgmiosDRepStateResponse {..} + +instance ToJSONRPC GYStakeAddress where + toMethod = const "queryLedgerState/rewardAccountSummaries" + toParams (stakeAddressToCredential -> sc) = Just $ case sc of + GYCredentialByKey kh -> object ["keys" .= [kh]] + GYCredentialByScript sh -> object ["scripts" .= [sh]] + +newtype PoolId = PoolId + { poolId :: GYStakePoolIdBech32 + } + deriving stock (Show, Eq, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "pool", LowerFirst]] PoolId +data OgmiosStakeAddressInfo = OgmiosStakeAddressInfo + { delegate :: PoolId + , rewards :: AsAda + } + deriving stock (Show, Eq, Generic) + deriving anyclass FromJSON + +data OgmiosStartTime = OgmiosStartTime +instance ToJSONRPC OgmiosStartTime where + toMethod = const "queryNetwork/startTime" + toParams = const Nothing + +data OgmiosEraSummaries = OgmiosEraSummaries +instance ToJSONRPC OgmiosEraSummaries where + toMethod = const "queryLedgerState/eraSummaries" + toParams = const Nothing + +submitTx :: OgmiosRequest GYTx -> ClientM (OgmiosResponse TxSubmissionResponse) +protocolParams :: OgmiosRequest OgmiosPP -> ClientM (OgmiosResponse ProtocolParameters) +tip :: OgmiosRequest OgmiosTip -> ClientM (OgmiosResponse OgmiosTipResponse) +stakePools :: OgmiosRequest OgmiosStakePools -> ClientM (OgmiosResponse OgmiosStakePoolsResponse) +drepState :: OgmiosRequest (Set.Set (GYCredential 'GYKeyRoleDRep)) -> ClientM (OgmiosResponse [OgmiosDRepStateResponse]) +stakeAddressInfo :: OgmiosRequest GYStakeAddress -> ClientM (OgmiosResponse (Map Text OgmiosStakeAddressInfo)) +startTime :: OgmiosRequest OgmiosStartTime -> ClientM (OgmiosResponse GYTime) +eraSummaries :: OgmiosRequest OgmiosEraSummaries -> ClientM (OgmiosResponse [EraSummary]) + +type OgmiosApi = + ReqBody '[JSON] (OgmiosRequest GYTx) :> Post '[JSON] (OgmiosResponse TxSubmissionResponse) + :<|> ReqBody '[JSON] (OgmiosRequest OgmiosPP) :> Post '[JSON] (OgmiosResponse ProtocolParameters) + :<|> ReqBody '[JSON] (OgmiosRequest OgmiosTip) :> Post '[JSON] (OgmiosResponse OgmiosTipResponse) + :<|> ReqBody '[JSON] (OgmiosRequest OgmiosStakePools) :> Post '[JSON] (OgmiosResponse OgmiosStakePoolsResponse) + :<|> ReqBody '[JSON] (OgmiosRequest (Set.Set (GYCredential 'GYKeyRoleDRep))) :> Post '[JSON] (OgmiosResponse [OgmiosDRepStateResponse]) + :<|> ReqBody '[JSON] (OgmiosRequest GYStakeAddress) :> Post '[JSON] (OgmiosResponse (Map Text OgmiosStakeAddressInfo)) + :<|> ReqBody '[JSON] (OgmiosRequest OgmiosStartTime) :> Post '[JSON] (OgmiosResponse GYTime) + :<|> ReqBody '[JSON] (OgmiosRequest OgmiosEraSummaries) :> Post '[JSON] (OgmiosResponse [EraSummary]) + +submitTx :<|> protocolParams :<|> tip :<|> stakePools :<|> drepState :<|> stakeAddressInfo :<|> startTime :<|> eraSummaries = client @OgmiosApi Proxy + +-- | Submit a transaction to the node via Ogmios. +ogmiosSubmitTx :: OgmiosApiEnv -> GYSubmitTx +ogmiosSubmitTx env tx = do + TxSubmissionResponse (TxIdResponse txId) <- + handleOgmiosSubmitError + <=< runOgmiosClient env + $ submitTx (OgmiosRequest tx) + pure txId + where + handleOgmiosSubmitError = either submitE (`reduceOgmiosResponse` submitE) + submitE :: Show a => a -> IO b + submitE = throwIO . SubmitTxException . Text.pack . show + +-- Luckily, for protocol parameters, types are similar to ones defined in Maestro's Haskell SDK. Most of the below types (related to protocol parameters) mimics the ones defined in Maestro's Haskell SDK. +data ProtocolParametersUpdateDRep = ProtocolParametersUpdateDRep + { ppUpdateDrepEconomic :: !MaestroRational + , ppUpdateDrepGovernance :: !MaestroRational + , ppUpdateDrepNetwork :: !MaestroRational + , ppUpdateDrepTechnical :: !MaestroRational + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "ppUpdateDrep", LowerFirst]] ProtocolParametersUpdateDRep + +-- | DRep voting thresholds. +data DRepVotingThresholds = DRepVotingThresholds + { drepVotingThresholdsConstitution :: !MaestroRational + , drepVotingThresholdsConstitutionalCommittee :: !ConstitutionalCommittee + , drepVotingThresholdsHardForkInitiation :: !MaestroRational + , drepVotingThresholdsNoConfidence :: !MaestroRational + , drepVotingThresholdsProtocolParametersUpdate :: !ProtocolParametersUpdateDRep + , drepVotingThresholdsTreasuryWithdrawals :: !MaestroRational + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "drepVotingThresholds", LowerFirst]] DRepVotingThresholds + +data ConstitutionalCommittee = ConstitutionalCommittee + { constitutionalCommitteeDefault :: !MaestroRational + , constitutionalCommitteeStateOfNoConfidence :: !MaestroRational + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "constitutionalCommittee", LowerFirst]] ConstitutionalCommittee + +-- | Stake pool voting thresholds. +data StakePoolVotingThresholds = StakePoolVotingThresholds + { stakePoolVotingThresholdsConstitutionalCommittee :: !ConstitutionalCommittee + , stakePoolVotingThresholdsHardForkInitiation :: !MaestroRational + , stakePoolVotingThresholdsNoConfidence :: !MaestroRational + , stakePoolVotingThresholdsProtocolParametersUpdate :: !ProtocolParametersUpdateStakePool + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "stakePoolVotingThresholds", LowerFirst]] StakePoolVotingThresholds + +data CostModels = CostModels + { costModelsPlutusV1 :: !CostModel + , costModelsPlutusV2 :: !CostModel + , costModelsPlutusV3 :: !CostModel + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "costModels", Rename "PlutusV1" "plutus:v1", Rename "PlutusV2" "plutus:v2", Rename "PlutusV3" "plutus:v3"]] CostModels + +-- | Protocol parameters. +data ProtocolParameters = ProtocolParameters + { protocolParametersCollateralPercentage :: !Natural + , protocolParametersConstitutionalCommitteeMaxTermLength :: !Natural + , protocolParametersConstitutionalCommitteeMinSize :: !Natural + , protocolParametersDelegateRepresentativeDeposit :: !AsAda + , protocolParametersDelegateRepresentativeMaxIdleTime :: !Natural + , protocolParametersDelegateRepresentativeVotingThresholds :: !DRepVotingThresholds + , protocolParametersDesiredNumberOfStakePools :: !Natural + , protocolParametersGovernanceActionDeposit :: !AsAda + , protocolParametersGovernanceActionLifetime :: !Natural + , protocolParametersMaxBlockBodySize :: !AsBytes + , protocolParametersMaxBlockHeaderSize :: !AsBytes + , protocolParametersMaxCollateralInputs :: !Natural + , protocolParametersMaxExecutionUnitsPerBlock :: !(MemoryCpuWith Natural) + , protocolParametersMaxExecutionUnitsPerTransaction :: !(MemoryCpuWith Natural) + , protocolParametersMaxReferenceScriptsSize :: !AsBytes + , protocolParametersMaxTransactionSize :: !AsBytes + , protocolParametersMaxValueSize :: !AsBytes + , protocolParametersMinFeeCoefficient :: !Natural + , protocolParametersMinFeeConstant :: !AsAda + , protocolParametersMinFeeReferenceScripts :: !MinFeeReferenceScripts + , protocolParametersMinStakePoolCost :: !AsAda + , protocolParametersMinUtxoDepositCoefficient :: !Natural + , protocolParametersMonetaryExpansion :: !MaestroRational + , protocolParametersPlutusCostModels :: !CostModels + , protocolParametersScriptExecutionPrices :: !(MemoryCpuWith MaestroRational) + , protocolParametersStakeCredentialDeposit :: !AsAda + , protocolParametersStakePoolDeposit :: !AsAda + , protocolParametersStakePoolPledgeInfluence :: !MaestroRational + , protocolParametersStakePoolRetirementEpochBound :: !EpochNo + , protocolParametersStakePoolVotingThresholds :: !StakePoolVotingThresholds + , protocolParametersTreasuryExpansion :: !MaestroRational + , protocolParametersVersion :: !ProtocolVersion + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "protocolParameters", LowerFirst]] ProtocolParameters + +-- | Fetch protocol parameters. +ogmiosProtocolParameters :: OgmiosApiEnv -> IO ApiProtocolParameters +ogmiosProtocolParameters env = do + ProtocolParameters {..} <- + handleOgmiosError fn + <=< runOgmiosClient env + $ protocolParams (OgmiosRequest OgmiosPP) + pure $ + Ledger.PParams $ + ConwayPParams + { cppMinFeeA = THKD $ Ledger.Coin $ toInteger protocolParametersMinFeeCoefficient + , cppMinFeeB = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersMinFeeConstant + , cppMaxBBSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxBlockBodySize + , cppMaxTxSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxTransactionSize + , cppMaxBHSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxBlockHeaderSize + , cppKeyDeposit = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersStakeCredentialDeposit + , cppPoolDeposit = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersStakePoolDeposit + , cppEMax = + THKD $ + Ledger.EpochInterval . fromIntegral $ + Maestro.unEpochNo protocolParametersStakePoolRetirementEpochBound + , cppNOpt = THKD $ fromIntegral protocolParametersDesiredNumberOfStakePools + , cppA0 = THKD $ fromMaybe (error (errPath <> "Pool influence received from Maestro is out of bounds")) $ Ledger.boundRational $ Maestro.unMaestroRational protocolParametersStakePoolPledgeInfluence + , cppRho = THKD $ fromMaybe (error (errPath <> "Monetory expansion parameter received from Maestro is out of bounds")) $ Ledger.boundRational $ Maestro.unMaestroRational protocolParametersMonetaryExpansion + , cppTau = THKD $ fromMaybe (error (errPath <> "Treasury expansion parameter received from Maestro is out of bounds")) $ Ledger.boundRational $ Maestro.unMaestroRational protocolParametersTreasuryExpansion + , cppProtocolVersion = + Ledger.ProtVer + { Ledger.pvMajor = Ledger.mkVersion (Maestro.protocolVersionMajor protocolParametersVersion) & fromMaybe (error (errPath <> "Major version received from Maestro is out of bounds")) + , Ledger.pvMinor = Maestro.protocolVersionMinor protocolParametersVersion + } + , cppMinPoolCost = THKD $ Ledger.Coin $ toInteger $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersMinStakePoolCost + , cppCoinsPerUTxOByte = THKD $ Api.L.CoinPerByte $ Ledger.Coin $ toInteger protocolParametersMinUtxoDepositCoefficient + , cppCostModels = + THKD $ + Ledger.mkCostModels $ + Map.fromList + [ + ( Ledger.PlutusV1 + , either (error (errPath <> "Couldn't build PlutusV1 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV1 $ coerce @_ @[Int64] (costModelsPlutusV1 protocolParametersPlutusCostModels) + ) + , + ( Ledger.PlutusV2 + , either (error (errPath <> "Couldn't build PlutusV2 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV2 $ coerce @_ @[Int64] (costModelsPlutusV2 protocolParametersPlutusCostModels) + ) + , + ( Ledger.PlutusV3 + , either (error (errPath <> "Couldn't build PlutusV3 cost models")) id $ Ledger.mkCostModel Ledger.PlutusV3 $ coerce @_ @[Int64] (costModelsPlutusV3 protocolParametersPlutusCostModels) + ) + ] + , cppPrices = THKD $ Ledger.Prices {Ledger.prSteps = fromMaybe (error (errPath <> "Couldn't bound Maestro's cpu steps")) $ Ledger.boundRational $ Maestro.unMaestroRational $ Maestro.memoryCpuWithCpu protocolParametersScriptExecutionPrices, Ledger.prMem = fromMaybe (error (errPath <> "Couldn't bound Maestro's memory units")) $ Ledger.boundRational $ Maestro.unMaestroRational $ Maestro.memoryCpuWithMemory protocolParametersScriptExecutionPrices} + , cppMaxTxExUnits = + THKD $ + Ledger.OrdExUnits $ + Ledger.ExUnits + { Ledger.exUnitsSteps = + Maestro.memoryCpuWithCpu protocolParametersMaxExecutionUnitsPerTransaction + , Ledger.exUnitsMem = + Maestro.memoryCpuWithMemory protocolParametersMaxExecutionUnitsPerTransaction + } + , cppMaxBlockExUnits = + THKD $ + Ledger.OrdExUnits $ + Ledger.ExUnits + { Ledger.exUnitsSteps = + Maestro.memoryCpuWithCpu protocolParametersMaxExecutionUnitsPerBlock + , Ledger.exUnitsMem = + Maestro.memoryCpuWithMemory protocolParametersMaxExecutionUnitsPerBlock + } + , cppMaxValSize = THKD $ fromIntegral $ Maestro.asBytesBytes protocolParametersMaxValueSize + , cppCollateralPercentage = THKD $ fromIntegral protocolParametersCollateralPercentage + , cppMaxCollateralInputs = THKD $ fromIntegral protocolParametersMaxCollateralInputs + , cppPoolVotingThresholds = + THKD $ + Ledger.PoolVotingThresholds + { pvtPPSecurityGroup = unsafeBoundRational $ Maestro.unMaestroRational $ Maestro.ppUpdateStakePoolSecurity $ stakePoolVotingThresholdsProtocolParametersUpdate protocolParametersStakePoolVotingThresholds + , pvtMotionNoConfidence = unsafeBoundRational $ Maestro.unMaestroRational $ stakePoolVotingThresholdsNoConfidence protocolParametersStakePoolVotingThresholds + , pvtHardForkInitiation = unsafeBoundRational $ Maestro.unMaestroRational $ stakePoolVotingThresholdsHardForkInitiation protocolParametersStakePoolVotingThresholds + , pvtCommitteeNormal = unsafeBoundRational $ Maestro.unMaestroRational $ constitutionalCommitteeDefault $ stakePoolVotingThresholdsConstitutionalCommittee protocolParametersStakePoolVotingThresholds + , pvtCommitteeNoConfidence = unsafeBoundRational $ Maestro.unMaestroRational $ constitutionalCommitteeStateOfNoConfidence $ stakePoolVotingThresholdsConstitutionalCommittee protocolParametersStakePoolVotingThresholds + } + , cppDRepVotingThresholds = + THKD $ + Ledger.DRepVotingThresholds + { dvtUpdateToConstitution = unsafeBoundRational $ Maestro.unMaestroRational $ drepVotingThresholdsConstitution protocolParametersDelegateRepresentativeVotingThresholds + , dvtTreasuryWithdrawal = unsafeBoundRational $ Maestro.unMaestroRational $ drepVotingThresholdsTreasuryWithdrawals protocolParametersDelegateRepresentativeVotingThresholds + , dvtPPTechnicalGroup = unsafeBoundRational $ Maestro.unMaestroRational $ ppUpdateDrepTechnical $ drepVotingThresholdsProtocolParametersUpdate protocolParametersDelegateRepresentativeVotingThresholds + , dvtPPNetworkGroup = unsafeBoundRational $ Maestro.unMaestroRational $ ppUpdateDrepNetwork $ drepVotingThresholdsProtocolParametersUpdate protocolParametersDelegateRepresentativeVotingThresholds + , dvtPPGovGroup = unsafeBoundRational $ Maestro.unMaestroRational $ ppUpdateDrepGovernance $ drepVotingThresholdsProtocolParametersUpdate protocolParametersDelegateRepresentativeVotingThresholds + , dvtPPEconomicGroup = unsafeBoundRational $ Maestro.unMaestroRational $ ppUpdateDrepEconomic $ drepVotingThresholdsProtocolParametersUpdate protocolParametersDelegateRepresentativeVotingThresholds + , dvtMotionNoConfidence = unsafeBoundRational $ Maestro.unMaestroRational $ drepVotingThresholdsNoConfidence protocolParametersDelegateRepresentativeVotingThresholds + , dvtHardForkInitiation = unsafeBoundRational $ Maestro.unMaestroRational $ drepVotingThresholdsHardForkInitiation protocolParametersDelegateRepresentativeVotingThresholds + , dvtCommitteeNormal = unsafeBoundRational $ Maestro.unMaestroRational $ constitutionalCommitteeDefault $ drepVotingThresholdsConstitutionalCommittee protocolParametersDelegateRepresentativeVotingThresholds + , dvtCommitteeNoConfidence = unsafeBoundRational $ Maestro.unMaestroRational $ constitutionalCommitteeStateOfNoConfidence $ drepVotingThresholdsConstitutionalCommittee protocolParametersDelegateRepresentativeVotingThresholds + } + , cppCommitteeMinSize = THKD $ fromIntegral protocolParametersConstitutionalCommitteeMinSize + , cppCommitteeMaxTermLength = THKD (Ledger.EpochInterval $ fromIntegral protocolParametersConstitutionalCommitteeMaxTermLength) + , cppGovActionLifetime = THKD (Ledger.EpochInterval $ fromIntegral protocolParametersGovernanceActionLifetime) + , cppGovActionDeposit = THKD $ Ledger.Coin $ fromIntegral $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersGovernanceActionDeposit + , cppDRepDeposit = THKD $ Ledger.Coin $ fromIntegral $ Maestro.asLovelaceLovelace $ Maestro.asAdaAda protocolParametersDelegateRepresentativeDeposit + , cppDRepActivity = THKD (Ledger.EpochInterval $ fromIntegral protocolParametersDelegateRepresentativeMaxIdleTime) + , cppMinFeeRefScriptCostPerByte = THKD $ unsafeBoundRational $ Maestro.minFeeReferenceScriptsBase protocolParametersMinFeeReferenceScripts + } + where + errPath = "GeniusYield.Providers.Ogmios.ogmiosProtocolParameters: " + fn = "ogmiosProtocolParameters" + +-- | Get slot of current block. +ogmiosGetSlotOfCurrentBlock :: OgmiosApiEnv -> IO GYSlot +ogmiosGetSlotOfCurrentBlock env = do + OgmiosTipResponse s <- + handleOgmiosError fn + <=< runOgmiosClient env + $ tip (OgmiosRequest OgmiosTip) + pure s + where + fn = "ogmiosGetSlotOfCurrentBlock" + +ogmiosStakePools :: OgmiosApiEnv -> IO (Set.Set Api.S.PoolId) +ogmiosStakePools env = do + sps <- handleOgmiosError fn <=< runOgmiosClient env $ stakePools (OgmiosRequest OgmiosStakePools) + pure $ Set.map (stakePoolIdToApi . stakePoolIdFromBech32) $ Map.keysSet sps + where + fn = "ogmiosStakePools" + +ogmiosGetDRepsState :: OgmiosApiEnv -> Set.Set (GYCredential 'GYKeyRoleDRep) -> IO (Map.Map (GYCredential 'GYKeyRoleDRep) (Maybe GYDRepState)) +ogmiosGetDRepsState env dreps = do + drepStates <- handleOgmiosError fn <=< runOgmiosClient env $ drepState (OgmiosRequest dreps) + let foundStates = + Map.fromList $ + map + ( \s -> + ( ogDRepStateCred s + , Just $ + GYDRepState + { drepExpiry = ogDRepStateMandate s & asEpochEpoch & (GYEpochNo . fromIntegral) + , drepAnchor = + let man = ogDRepStateAnchor s + in man >>= \an -> Just $ GYAnchor (metadataUrl an) (metadataHash an) + , drepDeposit = ogDRepStateDeposit s & asAdaAda & asLovelaceLovelace + , drepDelegs = ogDRepStateDelegs s + } + ) + ) + drepStates + filteredFoundStates = Map.restrictKeys foundStates dreps + pure $ Set.foldl' (\mapAcc drep -> if Map.member drep mapAcc then mapAcc else Map.insert drep Nothing mapAcc) filteredFoundStates dreps + where + fn = "ogmiosGetDRepsState" + +ogmiosGetDRepState :: OgmiosApiEnv -> GYCredential 'GYKeyRoleDRep -> IO (Maybe GYDRepState) +ogmiosGetDRepState env drep = do + drepStates <- ogmiosGetDRepsState env $ Set.singleton drep + pure $ join $ Map.lookup drep drepStates + +ogmiosStakeAddressInfo :: OgmiosApiEnv -> GYStakeAddress -> IO (Maybe GYStakeAddressInfo) +ogmiosStakeAddressInfo env addr = do + mstakeAddressInfo <- handleOgmiosError fn <=< runOgmiosClient env $ stakeAddressInfo (OgmiosRequest addr) + pure $ listToMaybe $ map (\OgmiosStakeAddressInfo {..} -> GYStakeAddressInfo {gyStakeAddressInfoDelegatedPool = delegate & poolId & stakePoolIdFromBech32 & Just, gyStakeAddressInfoAvailableRewards = asAdaAda rewards & asLovelaceLovelace}) $ Map.elems mstakeAddressInfo + where + fn = "ogmiosStakeAddressInfo" + +ogmiosStartTime :: OgmiosApiEnv -> IO CTime.SystemStart +ogmiosStartTime env = do + gytime <- handleOgmiosError fn <=< runOgmiosClient env $ startTime (OgmiosRequest OgmiosStartTime) + pure $ CTime.SystemStart $ posixSecondsToUTCTime $ timeToPOSIX gytime + where + fn = "ogmiosStartTime" + +data EraParameters = EraParameters + { eraParametersEpochLength :: !EpochSize + , eraParametersSlotLength :: !EpochSlotLength + , eraParametersSafeZone :: !(Maybe Word64) + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "eraParameters", LowerFirst]] EraParameters + +data EraSummary = EraSummary + { eraSummaryStart :: !EraBound + -- ^ Start of this era. + , eraSummaryEnd :: !(Maybe EraBound) + -- ^ End of this era. + , eraSummaryParameters :: !EraParameters + -- ^ Parameters of this era. + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[StripPrefix "eraSummary", LowerFirst]] EraSummary + +-- Largely similar to how we handle for Maestro. +ogmiosEraSummaries :: OgmiosApiEnv -> IO Api.EraHistory +ogmiosEraSummaries env = do + eraSumms <- handleOgmiosError fn <=< runOgmiosClient env $ eraSummaries (OgmiosRequest OgmiosEraSummaries) + maybe (throwIO $ OgmiosIncorrectEraHistoryLength eraSumms) pure $ parseEraHist mkEra eraSumms + where + mkBound Maestro.EraBound {eraBoundEpoch, eraBoundSlot, eraBoundTime} = + Ouroboros.Bound + { boundTime = CTime.RelativeTime $ Maestro.eraBoundTimeSeconds eraBoundTime + , boundSlot = CSlot.SlotNo $ fromIntegral eraBoundSlot + , boundEpoch = CSlot.EpochNo $ fromIntegral eraBoundEpoch + } + mkEraParams EraParameters {eraParametersEpochLength, eraParametersSlotLength, eraParametersSafeZone} = + Ouroboros.EraParams + { eraEpochSize = CSlot.EpochSize $ fromIntegral eraParametersEpochLength + , eraSlotLength = CTime.mkSlotLength $ Maestro.epochSlotLengthMilliseconds eraParametersSlotLength / 1000 + , eraSafeZone = Ouroboros.StandardSafeZone $ fromJust eraParametersSafeZone + , eraGenesisWin = fromIntegral $ fromJust eraParametersSafeZone -- TODO: Get it from provider? It is supposed to be 3k/f where k is security parameter (at present 2160) and f is active slot coefficient. Usually ledger set the safe zone size such that it guarantees at least k blocks... + } + mkEra EraSummary {eraSummaryStart, eraSummaryEnd, eraSummaryParameters} = + Ouroboros.EraSummary + { eraStart = mkBound eraSummaryStart + , eraEnd = maybe Ouroboros.EraUnbounded (Ouroboros.EraEnd . mkBound) eraSummaryEnd + , eraParams = mkEraParams eraSummaryParameters + } + fn = "ogmiosEraSummaries" diff --git a/src/GeniusYield/Types/Anchor.hs b/src/GeniusYield/Types/Anchor.hs index 00dec82f..2b86346a 100644 --- a/src/GeniusYield/Types/Anchor.hs +++ b/src/GeniusYield/Types/Anchor.hs @@ -42,7 +42,7 @@ GYUrl (Url {urlToText = "https://geniusyield.co"}) -} newtype GYUrl = GYUrl Ledger.Url deriving stock Show - deriving newtype (Eq, Ord) + deriving newtype (Eq, Ord, FromJSON, ToJSON) -- | Convert a 'Text' to a 'GYUrl' checking that it is at most 128 bytes in the process. textToUrl :: MonadFail m => Text -> m GYUrl @@ -70,7 +70,7 @@ GYAnchorDataHash (SafeHash "511bc81dde11180838c562c82bb35f3223f46061ebde4a955c27 -} newtype GYAnchorDataHash = GYAnchorDataHash (Ledger.SafeHash Ledger.StandardCrypto Ledger.AnchorData) deriving stock Show - deriving newtype (Eq, Ord) + deriving newtype (Eq, Ord, FromJSON, ToJSON) {- | Convert a 'GYAnchorDataHash' to a 'ByteString'. >>> let h = hashAnchorData "Hello, World!" diff --git a/src/GeniusYield/Types/StakePoolId.hs b/src/GeniusYield/Types/StakePoolId.hs index 0ba0e0d8..2f7ae4f9 100644 --- a/src/GeniusYield/Types/StakePoolId.hs +++ b/src/GeniusYield/Types/StakePoolId.hs @@ -153,6 +153,9 @@ instance FromJSON GYStakePoolIdBech32 where Just stakePoolId -> return $ GYStakePoolIdBech32 stakePoolId Nothing -> fail "cannot deserialise stake pool id" +instance Aeson.FromJSONKey GYStakePoolIdBech32 where + fromJSONKey = Aeson.FromJSONKeyTextParser (either (fail . Text.unpack) pure . Web.parseUrlPiece) + {- | >>> Aeson.encode (Swagger.toSchema (Proxy :: Proxy GYStakePoolIdBech32)) diff --git a/src/GeniusYield/Types/Tx.hs b/src/GeniusYield/Types/Tx.hs index 6dc12ab6..2f80dcc4 100644 --- a/src/GeniusYield/Types/Tx.hs +++ b/src/GeniusYield/Types/Tx.hs @@ -98,6 +98,9 @@ import GeniusYield.Types.PlutusVersion ( newtype GYTx = GYTx (Api.Tx ApiEra) +instance IsString GYTx where + fromString = either error id . txFromHexE + {- | >>> txToApi <$> (Aeson.fromJSON @GYTx $ Aeson.toJSON tx) @@ -150,7 +153,10 @@ instance Printf.PrintfArg GYTx where Just (ShelleyTx ShelleyBasedEraConway (AlonzoTx {body = TxBodyConstr ConwayTxBodyRaw {ctbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "677b32cca6387836fc53ec35b4060800893c22edc1e1d20ff74c42e67aca1e21"}) (TxIx {unTxIx = 1}),TxIn (TxId {unTxId = SafeHash "f13e16fafb7df5fbdff775d949a28edd586a3e0426739bc782c9f5d82ecdb70a"}) (TxIx {unTxIx = 0})], ctbrCollateralInputs = fromList [TxIn (TxId {unTxId = SafeHash "c816519a759e300acc16d1e2812500392c85ae6d5af886dd154c9084a610a120"}) (TxIx {unTxIx = 0})], ctbrReferenceInputs = fromList [TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 0}),TxIn (TxId {unTxId = SafeHash "16647d6365020555d905d6e0edcf08b90a567886f875b40b3d7cec1c70482624"}) (TxIx {unTxIx = 1})], ctbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Testnet (ScriptHashObj (ScriptHash "44376a5f63342097a4f20401088c62da272639e60644a9ec1d70f444")) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 103400000) (MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])])),DatumHash (SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"),SNothing), sizedSize = 167},Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 997296677) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}]}, ctbrCollateralReturn = SJust (Sized {sizedValue = (Addr Testnet (KeyHashObj (KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"})) (StakeRefBase (KeyHashObj (KeyHash {unKeyHash = "1d3554e12c8aed91818a0600a57bea9d50e509beda567387d1247315"}))),MaryValue (Coin 4486868) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 65}), ctbrTotalCollateral = SJust (Coin 513132), ctbrCerts = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, ctbrTxfee = Coin 342088, ctbrVldt = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, ctbrReqSignerHashes = fromList [], ctbrMint = MultiAsset (fromList [(PolicyID {policyID = ScriptHash "53827a77e4ed3d5c211706708c0aa9b9a3be19db901b1cbf7fa515b8"},fromList [("b7f1e540a130b7d9010c9ad87f284d914ab9753ae846c9b5221436086efe5f01",1)])]), ctbrScriptIntegrityHash = SJust (SafeHash "a23cebd1aef6f5c9a3bb5c4469bc0b5c316a7090c6306109ebe6ce1d088b3fe5"), ctbrAuxDataHash = SJust (AuxiliaryDataHash {unsafeAuxiliaryDataHash = SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"}), ctbrTxNetworkId = SNothing, ctbrVotingProcedures = VotingProcedures {unVotingProcedures = fromList []}, ctbrProposalProcedures = OSet {osSSeq = StrictSeq {fromStrict = fromList []}, osSet = fromList []}, ctbrCurrentTreasuryValue = SNothing, ctbrTreasuryDonation = Coin 0} (blake2b_256: SafeHash "dfd37a5f16ecb4203ff240e0c426890f8c400e1ddfbdf1accaeb8cc348fa3b5c"), wits = AlonzoTxWitsRaw {atwrAddrTxWits = fromList [WitVKeyInternal {wvkKey = VKey (VerKeyEd25519DSIGN "e8807993d91ac035385bea2cc7577876d1ed3ca05b78ac0fc1be65b741c61957"), wvkSig = SignedDSIGN (SigEd25519DSIGN "9a37152ba1fe5b8a2026eca077d1e154795812bdc8008c43cd6028d08485062f91a980f88f0739cfb1763117debe6673f0fc0ffb2362659b89449a1b30a49d08"), wvkKeyHash = KeyHash {unKeyHash = "99f8985db8b9076f61ecec59eca67e30224dc20afb40491aecc6aa97"}, wvkBytes = "\130X \232\128y\147\217\SUB\192\&58[\234,\199Wxv\209\237<\160[x\172\SI\193\190e\183A\198\EMWX@\154\&7\NAK+\161\254[\138 &\236\160w\209\225TyX\DC2\189\200\NUL\140C\205`(\208\132\133\ACK/\145\169\128\248\143\a9\207\177v1\ETB\222\190fs\240\252\SI\251#be\155\137D\154\ESC0\164\157\b"}], atwrBootAddrTxWits = fromList [], atwrScriptTxWits = fromList [], atwrDatsTxWits = TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList [(SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575",DataConstr Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151",Constr 0 [Constr 0 [B "\153\248\152]\184\185\aoa\236\236Y\236\166~0\"M\194\n\251@I\SUB\236\198\170\151"],Constr 0 [Constr 0 [Constr 0 [B "\GS5T\225,\138\237\145\129\138\ACK\NUL\165{\234\157P\229\t\190\218Vs\135\209$s\NAK"]]]],Constr 0 [B "",B ""],I 100000000,I 100000000,Constr 0 [B "\198\230[\167\135\139/\142\160\173\&9(}>/\210V\220\\A`\252\EM\189\244\196\216~",B "tGENS"],Constr 0 [I 1,I 1],B "\183\241\229@\161\&0\183\217\SOH\f\154\216\DEL(M\145J\185u:\232F\201\181\"\DC46\bn\254_\SOH",Constr 1 [],Constr 1 [],I 0,I 1000000,I 1000000,Constr 0 [I 1000000,I 300000,I 0],I 0] (blake2b_256: SafeHash "7caffd4aa6d4942ad42cf8d109feee13994ab5dc3bd657a571b70d679538d575"))]} (blake2b_256: SafeHash "f9be8c20a8c55a5c744f293db49f89505a82a2ce89ad86479f95983e044b4fe9"), atwrRdmrsTxWits = RedeemersConstr fromList [(ConwayMinting (AsIx {unAsIx = 0}),(DataConstr Constr 0 [Constr 0 [Constr 0 [B "g{2\204\166\&8x6\252S\236\&5\180\ACK\b\NUL\137<\"\237\193\225\210\SI\247LB\230z\202\RS!"],I 1]] (blake2b_256: SafeHash "63392b71d2cdffc553e10e7804c08897c9eb5a2ca6d83e647bf523796ca35741"),WrapExUnits {unWrapExUnits = ExUnits' {exUnitsMem' = 726550, exUnitsSteps' = 231770400}}))] (blake2b_256: SafeHash "df0708c4c44f7ff380ded920ebe4e51be34b100e9235df0294cb64948c047c0f")} (blake2b_256: SafeHash "0a0052247e0995d8010860a20560f5cd9faf78b057fa6cd1f367fd900f8248fa"), isValid = IsValid True, auxiliaryData = SJust (AuxiliaryDataConstr AlonzoTxAuxDataRaw {atadrMetadata = fromList [(674,Map [(S "msg",List [S "GeniusYield: Order placed"])])], atadrTimelock = StrictSeq {fromStrict = fromList []}, atadrPlutus = fromList []} (blake2b_256: SafeHash "37c0555635ab7e45ec39bd8feb873080d036c9a67c4cdd0c85e1c5291b0482f2"))})) -} txFromHex :: String -> Maybe GYTx -txFromHex s = rightToMaybe $ txFromHexBS $ BS8.pack s +txFromHex s = rightToMaybe $ txFromHexE s + +txFromHexE :: String -> Either String GYTx +txFromHexE s = txFromHexBS $ BS8.pack s {- | diff --git a/tests/GeniusYield/Test/Providers/Mashup.hs b/tests/GeniusYield/Test/Providers/Mashup.hs index f7f24a03..2592bde0 100644 --- a/tests/GeniusYield/Test/Providers/Mashup.hs +++ b/tests/GeniusYield/Test/Providers/Mashup.hs @@ -123,7 +123,7 @@ providersMashupTests configs = handler :: SubmitTxException -> IO GYTxId handler e = let errorText = show e - in ( if "BadInputsUTxO" `isInfixOf` errorText + in ( if "BadInputsUTxO" `isInfixOf` errorText || "unknownOutputReferences" `isInfixOf` errorText then pure "6c751d3e198c5608dfafdfdffe16aeac8a28f88f3a769cf22dd45e8bc84f47e8" -- Any transaction ID. else error $ "Not satisfied, error text: " <> errorText