From e52a873ed3b4c2d3b9cdb2aaff8c7e8985eec85a Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Thu, 5 Sep 2024 21:06:38 +0530 Subject: [PATCH] feat(#348): update formatter config --- fourmolu.yaml | 4 +- .../GeniusYield/OnChain/AStakeValidator.hs | 14 +- .../OnChain/Examples/ReadOracle.hs | 20 +- src-plutustx/GeniusYield/OnChain/TestToken.hs | 16 +- src/GeniusYield/Api/TestTokens.hs | 2 +- src/GeniusYield/CardanoApi/Query.hs | 4 +- src/GeniusYield/Examples/Gift.hs | 10 +- src/GeniusYield/Examples/Limbo.hs | 10 +- src/GeniusYield/Examples/Treat.hs | 10 +- src/GeniusYield/GYConfig.hs | 130 ++--- src/GeniusYield/HTTP/Errors.hs | 2 +- src/GeniusYield/Imports.hs | 10 +- src/GeniusYield/Providers/Blockfrost.hs | 222 ++++---- src/GeniusYield/Providers/Common.hs | 240 ++++----- src/GeniusYield/Providers/GCP.hs | 24 +- src/GeniusYield/Providers/Kupo.hs | 60 +-- src/GeniusYield/Providers/LiteChainIndex.hs | 106 ++-- src/GeniusYield/Providers/Maestro.hs | 230 ++++---- src/GeniusYield/Providers/Node.hs | 4 +- src/GeniusYield/Providers/Node/AwaitTx.hs | 42 +- src/GeniusYield/Providers/Node/Query.hs | 8 +- src/GeniusYield/Providers/Sentry.hs | 78 +-- src/GeniusYield/ReadJSON.hs | 2 +- src/GeniusYield/Swagger/Utils.hs | 2 +- src/GeniusYield/Test/Clb.hs | 310 +++++------ src/GeniusYield/Test/FeeTracker.hs | 68 +-- src/GeniusYield/Test/Privnet/Asserts.hs | 8 +- src/GeniusYield/Test/Privnet/Examples/Gift.hs | 10 +- src/GeniusYield/Test/Privnet/Setup.hs | 24 +- src/GeniusYield/Test/Privnet/Utils.hs | 2 +- src/GeniusYield/Test/Utils.hs | 84 +-- src/GeniusYield/Transaction.hs | 492 +++++++++--------- src/GeniusYield/Transaction/CBOR.hs | 64 +-- src/GeniusYield/Transaction/CoinSelection.hs | 288 +++++----- src/GeniusYield/Transaction/Common.hs | 24 +- src/GeniusYield/TxBuilder.hs | 36 +- src/GeniusYield/TxBuilder/Class.hs | 158 +++--- src/GeniusYield/TxBuilder/Common.hs | 102 ++-- src/GeniusYield/TxBuilder/Errors.hs | 6 +- src/GeniusYield/TxBuilder/IO/Builder.hs | 40 +- src/GeniusYield/TxBuilder/Query/Class.hs | 44 +- src/GeniusYield/Types/Ada.hs | 2 +- src/GeniusYield/Types/Address.hs | 62 +-- src/GeniusYield/Types/Certificate.hs | 18 +- src/GeniusYield/Types/Datum.hs | 4 +- src/GeniusYield/Types/Key.hs | 30 +- src/GeniusYield/Types/Ledger.hs | 2 +- src/GeniusYield/Types/Logging.hs | 50 +- src/GeniusYield/Types/OpenApi.hs | 42 +- src/GeniusYield/Types/PaymentKeyHash.hs | 10 +- src/GeniusYield/Types/Providers.hs | 96 ++-- src/GeniusYield/Types/PubKeyHash.hs | 12 +- src/GeniusYield/Types/Redeemer.hs | 4 +- src/GeniusYield/Types/Script.hs | 112 ++-- src/GeniusYield/Types/Script/SimpleScript.hs | 4 +- src/GeniusYield/Types/Slot.hs | 6 +- src/GeniusYield/Types/SlotConfig.hs | 242 ++++----- src/GeniusYield/Types/StakeKeyHash.hs | 2 +- src/GeniusYield/Types/Time.hs | 2 +- src/GeniusYield/Types/Tx.hs | 6 +- src/GeniusYield/Types/TxBody.hs | 32 +- src/GeniusYield/Types/TxCert/Internal.hs | 18 +- src/GeniusYield/Types/TxIn.hs | 40 +- src/GeniusYield/Types/TxMetadata.hs | 6 +- src/GeniusYield/Types/TxOut.hs | 32 +- src/GeniusYield/Types/TxOutRef.hs | 38 +- src/GeniusYield/Types/TxWdrl.hs | 18 +- src/GeniusYield/Types/UTxO.hs | 108 ++-- src/GeniusYield/Types/Value.hs | 88 ++-- src/GeniusYield/Types/Wallet.hs | 50 +- src/GeniusYield/Utils.hs | 4 +- .../Test/Unified/BetRef/PlaceBet.hs | 120 ++--- .../Test/Unified/BetRef/TakePot.hs | 112 ++-- .../Test/Unified/OnChain/BetRef.hs | 40 +- tests/GeniusYield/Test/CoinSelection.hs | 158 +++--- tests/GeniusYield/Test/GYTxBody.hs | 36 +- tests/GeniusYield/Test/GYTxSkeleton.hs | 8 +- .../Test/OnChain/GuessRefInputDatum.hs | 56 +- tests/GeniusYield/Test/Providers.hs | 136 ++--- tests/GeniusYield/Test/Providers/Mashup.hs | 6 +- tests/GeniusYield/Test/RefInput.hs | 6 +- tests/GeniusYield/Test/SlotConfig.hs | 36 +- 82 files changed, 2433 insertions(+), 2431 deletions(-) diff --git a/fourmolu.yaml b/fourmolu.yaml index c7f07713..2bd0fdce 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,7 +1,9 @@ indentation: 2 comma-style: leading record-brace-space: true -indent-wheres: true +indent-wheres: false respectful: true haddock-style: multi-line newlines-between-decls: 1 +single-constraint-parens: never +single-deriving-parens: never diff --git a/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs b/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs index 20a196a4..ba934b33 100644 --- a/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs +++ b/src-plutustx/GeniusYield/OnChain/AStakeValidator.hs @@ -20,12 +20,12 @@ mkAStakeValidator addr _ ctx' = case scriptContextPurpose ctx of Certifying _ -> () Rewarding _ -> if paidToAddress then () else error () _ -> error () - where - ctx :: ScriptContext - ctx = unsafeFromBuiltinData ctx' + where + ctx :: ScriptContext + ctx = unsafeFromBuiltinData ctx' - info :: TxInfo - info = scriptContextTxInfo ctx + info :: TxInfo + info = scriptContextTxInfo ctx - paidToAddress :: Bool - paidToAddress = any (\o -> txOutAddress o == addr) $ txInfoOutputs info + paidToAddress :: Bool + paidToAddress = any (\o -> txOutAddress o == addr) $ txInfoOutputs info diff --git a/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs b/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs index db0817fd..e29edb35 100644 --- a/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs +++ b/src-plutustx/GeniusYield/OnChain/Examples/ReadOracle.hs @@ -21,16 +21,16 @@ mkReadOracleValidator :: BuiltinData -> BuiltinData -> BuiltinData -> () mkReadOracleValidator _ _ ctx' | any (hasOutputDatum . txOutDatum) refins = () | otherwise = error () - where - ctx :: ScriptContext - ctx = unsafeFromBuiltinData ctx' + where + ctx :: ScriptContext + ctx = unsafeFromBuiltinData ctx' - info :: TxInfo - info = scriptContextTxInfo ctx + info :: TxInfo + info = scriptContextTxInfo ctx - refins :: [TxOut] - refins = map txInInfoResolved (txInfoReferenceInputs info) + refins :: [TxOut] + refins = map txInInfoResolved (txInfoReferenceInputs info) - hasOutputDatum :: OutputDatum -> Bool - hasOutputDatum (OutputDatum _) = True - hasOutputDatum _ = False + hasOutputDatum :: OutputDatum -> Bool + hasOutputDatum (OutputDatum _) = True + hasOutputDatum _ = False diff --git a/src-plutustx/GeniusYield/OnChain/TestToken.hs b/src-plutustx/GeniusYield/OnChain/TestToken.hs index 546e7f15..9eb450a2 100644 --- a/src-plutustx/GeniusYield/OnChain/TestToken.hs +++ b/src-plutustx/GeniusYield/OnChain/TestToken.hs @@ -25,14 +25,14 @@ mkTestTokenPolicy amt tn utxo _ ctx' | tn /= tn' = traceError "wrong token" | amt /= amt' = traceError "wrong amount" | otherwise = () - where - ctx :: ScriptContext - ctx = unsafeFromBuiltinData ctx' + where + ctx :: ScriptContext + ctx = unsafeFromBuiltinData ctx' - info :: TxInfo - info = scriptContextTxInfo ctx + info :: TxInfo + info = scriptContextTxInfo ctx - [(_, tn', amt')] = flattenValue $ txInfoMint info + [(_, tn', amt')] = flattenValue $ txInfoMint info - hasn'tUTxO :: Bool - hasn'tUTxO = all (\i -> txInInfoOutRef i /= utxo) $ txInfoInputs info + hasn'tUTxO :: Bool + hasn'tUTxO = all (\i -> txInInfoOutRef i /= utxo) $ txInfoInputs info diff --git a/src/GeniusYield/Api/TestTokens.hs b/src/GeniusYield/Api/TestTokens.hs index 45397c20..95cb8930 100644 --- a/src/GeniusYield/Api/TestTokens.hs +++ b/src/GeniusYield/Api/TestTokens.hs @@ -17,7 +17,7 @@ import GeniusYield.TxBuilder import GeniusYield.Types mintTestTokens :: - (GYTxUserQueryMonad m) => + GYTxUserQueryMonad m => GYTokenName -> Natural -> m (GYAssetClass, GYTxSkeleton 'PlutusV2) diff --git a/src/GeniusYield/CardanoApi/Query.hs b/src/GeniusYield/CardanoApi/Query.hs index cd12273b..27ce5ca6 100644 --- a/src/GeniusYield/CardanoApi/Query.hs +++ b/src/GeniusYield/CardanoApi/Query.hs @@ -31,8 +31,8 @@ import GeniusYield.Types ------------------------------------------------------------------------------- newtype CardanoQueryException = CardanoQueryException String - deriving stock (Show) - deriving anyclass (Exception) + deriving stock Show + deriving anyclass Exception ------------------------------------------------------------------------------- -- Low-level query runners diff --git a/src/GeniusYield/Examples/Gift.hs b/src/GeniusYield/Examples/Gift.hs index 77e70ec6..958ad285 100644 --- a/src/GeniusYield/Examples/Gift.hs +++ b/src/GeniusYield/Examples/Gift.hs @@ -30,12 +30,12 @@ giftScript = UPLC.LamAbs ann redeemerName $ UPLC.LamAbs ann scName $ UPLC.Var ann scName - where - ann = () + where + ann = () - datumName = UPLC.Name "datum" (UPLC.Unique 0) - redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) - scName = UPLC.Name "sc" (UPLC.Unique 2) + datumName = UPLC.Name "datum" (UPLC.Unique 0) + redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) + scName = UPLC.Name "sc" (UPLC.Unique 2) giftScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () giftScript' = toDeBruijn giftScript diff --git a/src/GeniusYield/Examples/Limbo.hs b/src/GeniusYield/Examples/Limbo.hs index 70c34d48..4c74da63 100644 --- a/src/GeniusYield/Examples/Limbo.hs +++ b/src/GeniusYield/Examples/Limbo.hs @@ -29,12 +29,12 @@ limboScript = UPLC.LamAbs ann redeemerName $ UPLC.LamAbs ann scName $ UPLC.Error ann - where - ann = () + where + ann = () - datumName = UPLC.Name "datum" (UPLC.Unique 0) - redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) - scName = UPLC.Name "sc" (UPLC.Unique 2) + datumName = UPLC.Name "datum" (UPLC.Unique 0) + redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) + scName = UPLC.Name "sc" (UPLC.Unique 2) limboScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () limboScript' = toDeBruijn limboScript diff --git a/src/GeniusYield/Examples/Treat.hs b/src/GeniusYield/Examples/Treat.hs index 50baaae1..d63a2788 100644 --- a/src/GeniusYield/Examples/Treat.hs +++ b/src/GeniusYield/Examples/Treat.hs @@ -37,12 +37,12 @@ treatScript = ann (UPLC.Builtin ann PLC.SerialiseData) (UPLC.Var ann scName) - where - ann = () + where + ann = () - datumName = UPLC.Name "datum" (UPLC.Unique 0) - redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) - scName = UPLC.Name "sc" (UPLC.Unique 2) + datumName = UPLC.Name "datum" (UPLC.Unique 0) + redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) + scName = UPLC.Name "sc" (UPLC.Unique 2) treatScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () treatScript' = toDeBruijn treatScript diff --git a/src/GeniusYield/GYConfig.hs b/src/GeniusYield/GYConfig.hs index 5810e92c..5a41c147 100644 --- a/src/GeniusYield/GYConfig.hs +++ b/src/GeniusYield/GYConfig.hs @@ -76,7 +76,7 @@ data GYCoreProviderInfo = GYNodeKupo {cpiSocketPath :: !FilePath, cpiKupoUrl :: !Text} | GYMaestro {cpiMaestroToken :: !(Confidential Text), cpiTurboSubmit :: !(Maybe Bool)} | GYBlockfrost {cpiBlockfrostKey :: !(Confidential Text)} - deriving stock (Show) + deriving stock Show $( deriveFromJSON defaultOptions @@ -130,7 +130,7 @@ data GYCoreConfig = GYCoreConfig } -- , cfgUtxoCacheEnable :: !Bool - deriving stock (Show) + deriving stock Show $( deriveFromJSON defaultOptions @@ -254,69 +254,69 @@ logTiming providers@GYProviders {..} = , gyGetStakeAddressInfo = gyGetStakeAddressInfo' , gyLog' = gyLog' } - where - wrap :: String -> IO a -> IO a - wrap msg m = do - (!a, !t) <- duration m - gyLog providers "" GYDebug $ msg <> " took " <> show t - pure a - - gyLookupDatum' :: GYLookupDatum - gyLookupDatum' = wrap "gyLookupDatum" . gyLookupDatum - - gySubmitTx' :: GYSubmitTx - gySubmitTx' = wrap "gySubmitTx" . gySubmitTx - - gyAwaitTxConfirmed' :: GYAwaitTx - gyAwaitTxConfirmed' p = wrap "gyAwaitTxConfirmed" . gyAwaitTxConfirmed p - - gySlotActions' :: GYSlotActions - gySlotActions' = - GYSlotActions - { gyGetSlotOfCurrentBlock' = wrap "gyGetSlotOfCurrentBlock" $ gyGetSlotOfCurrentBlock providers - , gyWaitForNextBlock' = wrap "gyWaitForNextBlock" $ gyWaitForNextBlock providers - , gyWaitUntilSlot' = wrap "gyWaitUntilSlot" . gyWaitUntilSlot providers - } - - gyGetParameters' :: GYGetParameters - gyGetParameters' = - GYGetParameters - { gyGetProtocolParameters' = wrap "gyGetProtocolParameters" $ gyGetProtocolParameters providers - , gyGetSystemStart' = wrap "gyGetSystemStart" $ gyGetSystemStart providers - , gyGetEraHistory' = wrap "gyGetEraHistory" $ gyGetEraHistory providers - , gyGetStakePools' = wrap "gyGetStakePools" $ gyGetStakePools providers - , gyGetSlotConfig' = wrap "gyGetSlotConfig" $ gyGetSlotConfig providers - } - - gyQueryUTxO' :: GYQueryUTxO - gyQueryUTxO' = - GYQueryUTxO - { gyQueryUtxosAtTxOutRefs' = wrap "gyQueryUtxosAtTxOutRefs" . gyQueryUtxosAtTxOutRefs providers - , gyQueryUtxosAtTxOutRefsWithDatums' = case gyQueryUtxosAtTxOutRefsWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ wrap "gyQueryUtxosAtTxOutRefsWithDatums" . q - , gyQueryUtxoAtTxOutRef' = wrap "gyQueryUtxoAtTxOutRef" . gyQueryUtxoAtTxOutRef providers - , gyQueryUtxoRefsAtAddress' = wrap "gyQueryUtxoRefsAtAddress" . gyQueryUtxoRefsAtAddress providers - , gyQueryUtxosAtAddress' = \addr mac -> wrap "gyQueryUtxosAtAddress'" $ gyQueryUtxosAtAddress providers addr mac - , gyQueryUtxosAtAddressWithDatums' = case gyQueryUtxosAtAddressWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ \addr mac -> wrap "gyQueryUtxosAtAddressWithDatums'" $ q addr mac - , gyQueryUtxosAtAddresses' = wrap "gyQueryUtxosAtAddresses" . gyQueryUtxosAtAddresses providers - , gyQueryUtxosAtAddressesWithDatums' = case gyQueryUtxosAtAddressesWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ wrap "gyQueryUtxosAtAddressesWithDatums" . q - , gyQueryUtxosAtPaymentCredential' = \cred -> wrap "gyQueryUtxosAtPaymentCredential" . gyQueryUtxosAtPaymentCredential providers cred - , gyQueryUtxosAtPaymentCredWithDatums' = case gyQueryUtxosAtPaymentCredWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ \cred mac -> wrap "gyQueryUtxosAtPaymentCredWithDatums" $ q cred mac - , gyQueryUtxosAtPaymentCredentials' = wrap "gyQueryUtxosAtPaymentCredentials" . gyQueryUtxosAtPaymentCredentials providers - , gyQueryUtxosAtPaymentCredsWithDatums' = case gyQueryUtxosAtPaymentCredsWithDatums' gyQueryUTxO of - Nothing -> Nothing - Just q -> Just $ wrap "gyQueryUtxosAtPaymentCredsWithDatums" . q - } - - gyGetStakeAddressInfo' :: GYStakeAddress -> IO (Maybe GYStakeAddressInfo) - gyGetStakeAddressInfo' = wrap "gyGetStakeAddressInfo" . gyGetStakeAddressInfo + where + wrap :: String -> IO a -> IO a + wrap msg m = do + (!a, !t) <- duration m + gyLog providers "" GYDebug $ msg <> " took " <> show t + pure a + + gyLookupDatum' :: GYLookupDatum + gyLookupDatum' = wrap "gyLookupDatum" . gyLookupDatum + + gySubmitTx' :: GYSubmitTx + gySubmitTx' = wrap "gySubmitTx" . gySubmitTx + + gyAwaitTxConfirmed' :: GYAwaitTx + gyAwaitTxConfirmed' p = wrap "gyAwaitTxConfirmed" . gyAwaitTxConfirmed p + + gySlotActions' :: GYSlotActions + gySlotActions' = + GYSlotActions + { gyGetSlotOfCurrentBlock' = wrap "gyGetSlotOfCurrentBlock" $ gyGetSlotOfCurrentBlock providers + , gyWaitForNextBlock' = wrap "gyWaitForNextBlock" $ gyWaitForNextBlock providers + , gyWaitUntilSlot' = wrap "gyWaitUntilSlot" . gyWaitUntilSlot providers + } + + gyGetParameters' :: GYGetParameters + gyGetParameters' = + GYGetParameters + { gyGetProtocolParameters' = wrap "gyGetProtocolParameters" $ gyGetProtocolParameters providers + , gyGetSystemStart' = wrap "gyGetSystemStart" $ gyGetSystemStart providers + , gyGetEraHistory' = wrap "gyGetEraHistory" $ gyGetEraHistory providers + , gyGetStakePools' = wrap "gyGetStakePools" $ gyGetStakePools providers + , gyGetSlotConfig' = wrap "gyGetSlotConfig" $ gyGetSlotConfig providers + } + + gyQueryUTxO' :: GYQueryUTxO + gyQueryUTxO' = + GYQueryUTxO + { gyQueryUtxosAtTxOutRefs' = wrap "gyQueryUtxosAtTxOutRefs" . gyQueryUtxosAtTxOutRefs providers + , gyQueryUtxosAtTxOutRefsWithDatums' = case gyQueryUtxosAtTxOutRefsWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ wrap "gyQueryUtxosAtTxOutRefsWithDatums" . q + , gyQueryUtxoAtTxOutRef' = wrap "gyQueryUtxoAtTxOutRef" . gyQueryUtxoAtTxOutRef providers + , gyQueryUtxoRefsAtAddress' = wrap "gyQueryUtxoRefsAtAddress" . gyQueryUtxoRefsAtAddress providers + , gyQueryUtxosAtAddress' = \addr mac -> wrap "gyQueryUtxosAtAddress'" $ gyQueryUtxosAtAddress providers addr mac + , gyQueryUtxosAtAddressWithDatums' = case gyQueryUtxosAtAddressWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ \addr mac -> wrap "gyQueryUtxosAtAddressWithDatums'" $ q addr mac + , gyQueryUtxosAtAddresses' = wrap "gyQueryUtxosAtAddresses" . gyQueryUtxosAtAddresses providers + , gyQueryUtxosAtAddressesWithDatums' = case gyQueryUtxosAtAddressesWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ wrap "gyQueryUtxosAtAddressesWithDatums" . q + , gyQueryUtxosAtPaymentCredential' = \cred -> wrap "gyQueryUtxosAtPaymentCredential" . gyQueryUtxosAtPaymentCredential providers cred + , gyQueryUtxosAtPaymentCredWithDatums' = case gyQueryUtxosAtPaymentCredWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ \cred mac -> wrap "gyQueryUtxosAtPaymentCredWithDatums" $ q cred mac + , gyQueryUtxosAtPaymentCredentials' = wrap "gyQueryUtxosAtPaymentCredentials" . gyQueryUtxosAtPaymentCredentials providers + , gyQueryUtxosAtPaymentCredsWithDatums' = case gyQueryUtxosAtPaymentCredsWithDatums' gyQueryUTxO of + Nothing -> Nothing + Just q -> Just $ wrap "gyQueryUtxosAtPaymentCredsWithDatums" . q + } + + gyGetStakeAddressInfo' :: GYStakeAddress -> IO (Maybe GYStakeAddressInfo) + gyGetStakeAddressInfo' = wrap "gyGetStakeAddressInfo" . gyGetStakeAddressInfo duration :: IO a -> IO (a, NominalDiffTime) duration m = do diff --git a/src/GeniusYield/HTTP/Errors.hs b/src/GeniusYield/HTTP/Errors.hs index 371d991e..b4cef36f 100644 --- a/src/GeniusYield/HTTP/Errors.hs +++ b/src/GeniusYield/HTTP/Errors.hs @@ -28,7 +28,7 @@ import GeniusYield.Imports type IsGYApiError :: Type -> Constraint class IsGYApiError e where toApiError :: e -> GYApiError - default toApiError :: (Exception e) => e -> GYApiError + default toApiError :: Exception e => e -> GYApiError toApiError e = someBackendError . Txt.pack $ displayException e {- | An example error code can be: "INSUFFICIENT_BALANCE" (i.e. diff --git a/src/GeniusYield/Imports.hs b/src/GeniusYield/Imports.hs index 027412b4..ab85ea46 100644 --- a/src/GeniusYield/Imports.hs +++ b/src/GeniusYield/Imports.hs @@ -79,7 +79,7 @@ import Data.Text.Lazy.Encoding qualified as LTE import GHC.TypeLits (ErrorMessage (..), TypeError) -- | Use 'TODO' instead of 'undefined's -pattern TODO :: () => (HasCallStack) => a +pattern TODO :: () => HasCallStack => a pattern TODO <- (todoMatch -> ()) where TODO = error "TODO" @@ -88,15 +88,15 @@ pattern TODO <- (todoMatch -> ()) todoMatch :: a -> () todoMatch _ = () -findFirst :: (Foldable f) => (a -> Maybe b) -> f a -> Maybe b +findFirst :: Foldable f => (a -> Maybe b) -> f a -> Maybe b findFirst f xs = getFirst (foldMap (coerce f) xs) -- poisonous instances -- (the orphan in plutus-ledger-api was removed in Feb 2022) -instance (TypeError ('Text "Forbidden FromJSON ByteString instance")) => FromJSON ByteString where +instance TypeError ('Text "Forbidden FromJSON ByteString instance") => FromJSON ByteString where parseJSON = error "FromJSON @ByteString" -instance (TypeError ('Text "Forbidden ToJSON ByteString instance")) => ToJSON ByteString where +instance TypeError ('Text "Forbidden ToJSON ByteString instance") => ToJSON ByteString where toJSON = error "ToJSON @ByteString" {- | Decode a lazy 'ByteString' containing UTF-8 encoded text. @@ -119,5 +119,5 @@ hush = either (const Nothing) Just __NOTE:__ This is also defined (& exported) in @transformers-0.6.0.0@, so should be removed once we upgrade to it. -} -hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b +hoistMaybe :: Applicative m => Maybe b -> MaybeT m b hoistMaybe = MaybeT . pure diff --git a/src/GeniusYield/Providers/Blockfrost.hs b/src/GeniusYield/Providers/Blockfrost.hs index 6b9fddd8..b44d0e10 100644 --- a/src/GeniusYield/Providers/Blockfrost.hs +++ b/src/GeniusYield/Providers/Blockfrost.hs @@ -62,7 +62,7 @@ data BlockfrostProviderException | BlpvUnsupportedOperation !Text | BlpvIncorrectEraHistoryLength ![Blockfrost.NetworkEraSummary] deriving stock (Eq, Show) - deriving anyclass (Exception) + deriving anyclass Exception throwBlpvApiError :: Text -> Blockfrost.BlockfrostError -> IO a throwBlpvApiError locationInfo = @@ -93,10 +93,10 @@ amountToValue (Blockfrost.AssetAmount sdiscr) = do cs <- Web.parseUrlPiece csPart tkName <- Web.parseUrlPiece tkNamePart pure . valueSingleton (GYToken cs tkName) $ Money.someDiscreteAmount sdiscr - where - csAndTkname = Money.someDiscreteCurrency sdiscr - -- Blockfrost uses no separator between CS and TkName. - (csPart, tkNamePart) = Text.splitAt 56 csAndTkname + where + csAndTkname = Money.someDiscreteCurrency sdiscr + -- Blockfrost uses no separator between CS and TkName. + (csPart, tkNamePart) = Text.splitAt 56 csAndTkname ------------------------------------------------------------------------------- -- Submit @@ -118,9 +118,9 @@ blockfrostSubmitTx proj tx = do . txIdFromHexE . Text.unpack $ Blockfrost.unTxHash txId - where - locationIdent = "SubmitTx" - handleBlockfrostSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersBlockfrostClientError) pure + where + locationIdent = "SubmitTx" + handleBlockfrostSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersBlockfrostClientError) pure ------------------------------------------------------------------------------- -- Await tx confirmation @@ -129,37 +129,37 @@ blockfrostSubmitTx proj tx = do -- | Awaits for the confirmation of a given 'GYTxId' blockfrostAwaitTxConfirmed :: Blockfrost.Project -> GYAwaitTx blockfrostAwaitTxConfirmed proj p@GYAwaitTxParameters {..} txId = blpAwaitTx 0 - where - blpAwaitTx :: Int -> IO () - blpAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p - blpAwaitTx attempt = do - eTxInfo <- blockfrostQueryTx proj txId - case eTxInfo of - Left Blockfrost.BlockfrostNotFound -> - threadDelay checkInterval - >> blpAwaitTx (attempt + 1) - Left err -> throwBlpvApiError "AwaitTx" err - Right txInfo -> - blpAwaitBlock attempt $ - Blockfrost._transactionBlock txInfo - - blpAwaitBlock :: Int -> Blockfrost.BlockHash -> IO () - blpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p - blpAwaitBlock attempt blockHash = do - eBlockInfo <- blockfrostQueryBlock proj blockHash - case eBlockInfo of - Left Blockfrost.BlockfrostNotFound -> - threadDelay checkInterval - >> blpAwaitBlock (attempt + 1) blockHash - Left err -> throwBlpvApiError "AwaitBlock" err - Right blockInfo - | attempt + 1 == maxAttempts -> - when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ - throwIO $ - GYAwaitTxException p - Right blockInfo -> - when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ - threadDelay checkInterval >> blpAwaitBlock (attempt + 1) blockHash + where + blpAwaitTx :: Int -> IO () + blpAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p + blpAwaitTx attempt = do + eTxInfo <- blockfrostQueryTx proj txId + case eTxInfo of + Left Blockfrost.BlockfrostNotFound -> + threadDelay checkInterval + >> blpAwaitTx (attempt + 1) + Left err -> throwBlpvApiError "AwaitTx" err + Right txInfo -> + blpAwaitBlock attempt $ + Blockfrost._transactionBlock txInfo + + blpAwaitBlock :: Int -> Blockfrost.BlockHash -> IO () + blpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p + blpAwaitBlock attempt blockHash = do + eBlockInfo <- blockfrostQueryBlock proj blockHash + case eBlockInfo of + Left Blockfrost.BlockfrostNotFound -> + threadDelay checkInterval + >> blpAwaitBlock (attempt + 1) blockHash + Left err -> throwBlpvApiError "AwaitBlock" err + Right blockInfo + | attempt + 1 == maxAttempts -> + when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ + throwIO $ + GYAwaitTxException p + Right blockInfo -> + when (Blockfrost._blockConfirmations blockInfo < toInteger confirmations) $ + threadDelay checkInterval >> blpAwaitBlock (attempt + 1) blockHash blockfrostQueryBlock :: Blockfrost.Project -> @@ -247,11 +247,11 @@ blockfrostUtxosAtAddress proj addr mAssetClass = do case traverse transformUtxo addrUtxos' of Left err -> throwIO $ BlpvDeserializeFailure locationIdent err Right x -> pure $ utxosFromList x - where - locationIdent = "AddressUtxos" - -- This particular error is fine in this case, we can just return empty list. - handler (Left Blockfrost.BlockfrostNotFound) = pure [] - handler other = handleBlockfrostError locationIdent other + where + locationIdent = "AddressUtxos" + -- This particular error is fine in this case, we can just return empty list. + handler (Left Blockfrost.BlockfrostNotFound) = pure [] + handler other = handleBlockfrostError locationIdent other blockfrostUtxosAtPaymentCredential :: Blockfrost.Project -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs blockfrostUtxosAtPaymentCredential proj cred mAssetClass = do @@ -269,11 +269,11 @@ blockfrostUtxosAtPaymentCredential proj cred mAssetClass = do case traverse transformUtxo credUtxos' of Left err -> throwIO $ BlpvDeserializeFailure locationIdent err Right x -> pure $ utxosFromList x - where - locationIdent = "PaymentCredentialUtxos" - -- This particular error is fine in this case, we can just return empty list. - handler (Left Blockfrost.BlockfrostNotFound) = pure [] - handler other = handleBlockfrostError locationIdent other + where + locationIdent = "PaymentCredentialUtxos" + -- This particular error is fine in this case, we can just return empty list. + handler (Left Blockfrost.BlockfrostNotFound) = pure [] + handler other = handleBlockfrostError locationIdent other blockfrostUtxosAtTxOutRef :: Blockfrost.Project -> GYTxOutRef -> IO (Maybe GYUTxO) blockfrostUtxosAtTxOutRef proj ref = do @@ -318,11 +318,11 @@ blockfrostUtxosAtTxOutRef proj ref = do , utxoOutDatum = d , utxoRefScript = ms } - where - -- This particular error is fine in this case, we can just return 'Nothing'. - handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing - handler other = handleBlockfrostError locationIdent $ Just <$> other - locationIdent = "TxUtxos(single)" + where + -- This particular error is fine in this case, we can just return 'Nothing'. + handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing + handler other = handleBlockfrostError locationIdent $ Just <$> other + locationIdent = "TxUtxos(single)" blockfrostUtxosAtTxOutRefs :: Blockfrost.Project -> [GYTxOutRef] -> IO GYUTxOs blockfrostUtxosAtTxOutRefs proj refs = do @@ -356,16 +356,16 @@ blockfrostUtxosAtTxOutRefs proj refs = do case Map.traverseWithKey (traverse . transformUtxoOutput) txUtxoMap' of Left err -> throwIO $ BlpvDeserializeFailure locationIndent err Right res -> pure . utxosFromList . concat $ Map.elems res - where - locationIndent = "TxUtxos" + where + locationIndent = "TxUtxos" - f :: - Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)] -> - (Api.S.TxId, [Blockfrost.UtxoOutput]) -> - IO (Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)]) - f m (tid, os) = do - xs <- forM os $ \o -> lookupScriptHashIO proj (Blockfrost._utxoOutputReferenceScriptHash o) >>= \ms -> return (o, ms) - return $ Map.insert tid xs m + f :: + Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)] -> + (Api.S.TxId, [Blockfrost.UtxoOutput]) -> + IO (Map Api.S.TxId [(Blockfrost.UtxoOutput, Maybe GYAnyScript)]) + f m (tid, os) = do + xs <- forM os $ \o -> lookupScriptHashIO proj (Blockfrost._utxoOutputReferenceScriptHash o) >>= \ms -> return (o, ms) + return $ Map.insert tid xs m -- | Helper to transform a 'Blockfrost.UtxoOutput' into a 'GYUTxO'. transformUtxoOutput :: Api.S.TxId -> (Blockfrost.UtxoOutput, Maybe GYAnyScript) -> Either SomeDeserializeError GYUTxO @@ -465,8 +465,8 @@ blockfrostProtocolParams nid proj = do , cppDRepActivity = THKD (Ledger.EpochInterval 0) , cppMinFeeRefScriptCostPerByte = THKD minBound } - where - errPath = "GeniusYield.Providers.Blockfrost.blockfrostProtocolParams: " + where + errPath = "GeniusYield.Providers.Blockfrost.blockfrostProtocolParams: " blockfrostStakePools :: Blockfrost.Project -> IO (Set Api.S.PoolId) blockfrostStakePools proj = do @@ -485,8 +485,8 @@ blockfrostStakePools proj = do -- Deserialization failure shouldn't happen on blockfrost returned pool id. Left err -> throwIO . BlpvDeserializeFailure locationIdent $ DeserializeErrorBech32 err Right has -> pure $ Set.fromList has - where - locationIdent = "ListPools" + where + locationIdent = "ListPools" blockfrostSystemStart :: Blockfrost.Project -> IO CTime.SystemStart blockfrostSystemStart proj = do @@ -497,26 +497,26 @@ blockfrostEraHistory :: Blockfrost.Project -> IO Api.EraHistory blockfrostEraHistory proj = do eraSumms <- Blockfrost.runBlockfrost proj Blockfrost.getNetworkEras >>= handleBlockfrostError "EraHistory" maybe (throwIO $ BlpvIncorrectEraHistoryLength eraSumms) pure $ parseEraHist mkEra eraSumms - where - mkBound Blockfrost.NetworkEraBound {_boundEpoch, _boundSlot, _boundTime} = - Ouroboros.Bound - { boundTime = CTime.RelativeTime _boundTime - , boundSlot = CSlot.SlotNo $ fromIntegral _boundSlot - , boundEpoch = CSlot.EpochNo $ fromIntegral _boundEpoch - } - mkEraParams Blockfrost.NetworkEraParameters {_parametersEpochLength, _parametersSlotLength, _parametersSafeZone} = - Ouroboros.EraParams - { eraEpochSize = CSlot.EpochSize $ fromIntegral _parametersEpochLength - , eraSlotLength = CTime.mkSlotLength _parametersSlotLength - , eraSafeZone = Ouroboros.StandardSafeZone _parametersSafeZone - , eraGenesisWin = fromIntegral _parametersSafeZone -- 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 Blockfrost.NetworkEraSummary {_networkEraStart, _networkEraEnd, _networkEraParameters} = - Ouroboros.EraSummary - { eraStart = mkBound _networkEraStart - , eraEnd = Ouroboros.EraEnd $ mkBound _networkEraEnd - , eraParams = mkEraParams _networkEraParameters - } + where + mkBound Blockfrost.NetworkEraBound {_boundEpoch, _boundSlot, _boundTime} = + Ouroboros.Bound + { boundTime = CTime.RelativeTime _boundTime + , boundSlot = CSlot.SlotNo $ fromIntegral _boundSlot + , boundEpoch = CSlot.EpochNo $ fromIntegral _boundEpoch + } + mkEraParams Blockfrost.NetworkEraParameters {_parametersEpochLength, _parametersSlotLength, _parametersSafeZone} = + Ouroboros.EraParams + { eraEpochSize = CSlot.EpochSize $ fromIntegral _parametersEpochLength + , eraSlotLength = CTime.mkSlotLength _parametersSlotLength + , eraSafeZone = Ouroboros.StandardSafeZone _parametersSafeZone + , eraGenesisWin = fromIntegral _parametersSafeZone -- 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 Blockfrost.NetworkEraSummary {_networkEraStart, _networkEraEnd, _networkEraParameters} = + Ouroboros.EraSummary + { eraStart = mkBound _networkEraStart + , eraEnd = Ouroboros.EraEnd $ mkBound _networkEraEnd + , eraParams = mkEraParams _networkEraParameters + } ------------------------------------------------------------------------------- -- Datum lookup @@ -538,11 +538,11 @@ blockfrostLookupDatum p dh = do Right bd -> pure $ datumFromPlutus' bd ) datumMaybe - where - -- This particular error is fine in this case, we can just return 'Nothing'. - handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing - handler other = handleBlockfrostError locationIdent $ Just <$> other - locationIdent = "LookupDatum" + where + -- This particular error is fine in this case, we can just return 'Nothing'. + handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing + handler other = handleBlockfrostError locationIdent $ Just <$> other + locationIdent = "LookupDatum" ------------------------------------------------------------------------------- -- Account info @@ -551,20 +551,20 @@ blockfrostLookupDatum p dh = do blockfrostStakeAddressInfo :: Blockfrost.Project -> GYStakeAddress -> IO (Maybe GYStakeAddressInfo) 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 other = - handleBlockfrostError "Account" $ - other <&> \accInfo -> - if Blockfrost._accountInfoActive accInfo - then - Just $ - GYStakeAddressInfo - { gyStakeAddressInfoDelegatedPool = Blockfrost._accountInfoPoolId accInfo >>= stakePoolIdFromTextMaybe . Blockfrost.unPoolId - , gyStakeAddressInfoAvailableRewards = fromInteger $ lovelacesToInteger $ Blockfrost._accountInfoWithdrawableAmount accInfo - } - else Nothing + where + -- This particular error is fine. + handler (Left Blockfrost.BlockfrostNotFound) = pure Nothing + handler other = + handleBlockfrostError "Account" $ + other <&> \accInfo -> + if Blockfrost._accountInfoActive accInfo + then + Just $ + GYStakeAddressInfo + { gyStakeAddressInfoDelegatedPool = Blockfrost._accountInfoPoolId accInfo >>= stakePoolIdFromTextMaybe . Blockfrost.unPoolId + , gyStakeAddressInfoAvailableRewards = fromInteger $ lovelacesToInteger $ Blockfrost._accountInfoWithdrawableAmount accInfo + } + else Nothing ------------------------------------------------------------------------------- -- Auxiliary functions @@ -599,12 +599,12 @@ datumFromBlockfrostCBOR d = do bs <- fromEither $ BS16.decode $ Text.encodeUtf8 t api <- fromEither $ Api.deserialiseFromCBOR Api.AsHashableScriptData bs return $ datumFromApi' api - where - t = Blockfrost._scriptDatumCborCbor d - e = DeserializeErrorHex t + where + t = Blockfrost._scriptDatumCborCbor d + e = DeserializeErrorHex t - fromEither :: Either e a -> Either SomeDeserializeError a - fromEither = first $ const e + fromEither :: Either e a -> Either SomeDeserializeError a + fromEither = first $ const e outDatumFromBlockfrost :: Maybe Blockfrost.DatumHash -> Maybe Blockfrost.InlineDatum -> Either SomeDeserializeError GYOutDatum outDatumFromBlockfrost mdh mind = do diff --git a/src/GeniusYield/Providers/Common.hs b/src/GeniusYield/Providers/Common.hs index 0f521ba2..19f48966 100644 --- a/src/GeniusYield/Providers/Common.hs +++ b/src/GeniusYield/Providers/Common.hs @@ -93,8 +93,8 @@ data SomeDeserializeError deriving stock (Eq, Show) newtype SubmitTxException = SubmitTxException Text - deriving stock (Show) - deriving anyclass (Exception) + deriving stock Show + deriving anyclass Exception -- FIXME: Temporary, until remote providers us with it. plutusV3CostModels :: [Char] -> (Ledger.Language, Ledger.CostModel) @@ -137,8 +137,8 @@ populateMissingProtocolParameters nid pp = , cppDRepActivity = THKD $ Ledger.EpochInterval 20 , cppMinFeeRefScriptCostPerByte = THKD $ unsafeBoundRational 15 } - where - commonPoolVotingThreshold = unsafeBoundRational (51 % 100) + where + commonPoolVotingThreshold = unsafeBoundRational (51 % 100) -- | Get datum from bytes. datumFromCBOR :: Text -> Either SomeDeserializeError GYDatum @@ -146,11 +146,11 @@ datumFromCBOR d = do bs <- fromEither $ BS16.decode $ Text.encodeUtf8 d api <- fromEither $ Api.deserialiseFromCBOR Api.AsHashableScriptData bs return $ datumFromApi' api - where - e = DeserializeErrorHex d + where + e = DeserializeErrorHex d - fromEither :: Either e a -> Either SomeDeserializeError a - fromEither = first $ const e + fromEither :: Either e a -> Either SomeDeserializeError a + fromEither = first $ const e {- | Remove request headers info from returned ClientError. @@ -170,7 +170,7 @@ newServantClientEnv baseUrl = do else HttpClient.newManager HttpClient.defaultManagerSettings pure $ Servant.mkClientEnv manager url -fromJson :: (FromData a) => LBS.ByteString -> Either SomeDeserializeError a +fromJson :: FromData a => LBS.ByteString -> Either SomeDeserializeError a fromJson b = do v <- first (DeserializeErrorAeson . Text.pack) $ Aeson.eitherDecode b x <- first DeserializeErrorScriptDataJson $ Api.scriptDataFromJson Api.ScriptDataJsonDetailedSchema v @@ -220,43 +220,43 @@ preprodEraHist = . NonEmptyCons maryEra . NonEmptyCons alonzoEra $ NonEmptyOne babbageEra - where - byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} - } - shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 0} - } - babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + where + byronEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} + } + shelleyEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 1728000, boundSlot = 86400, boundEpoch = 4} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + allegraEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2160000, boundSlot = 518400, boundEpoch = 5} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + maryEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 2592000, boundSlot = 950400, boundEpoch = 6} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + alonzoEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 3024000, boundSlot = 1382400, boundEpoch = 7} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 0} + } + babbageEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 5184000, boundSlot = 3542400, boundEpoch = 12} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } previewEraHist :: Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) previewEraHist = @@ -268,43 +268,43 @@ previewEraHist = . NonEmptyCons maryEra . NonEmptyCons alonzoEra $ NonEmptyOne babbageEra - where - byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} - } - shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + where + byronEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} + } + shelleyEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + allegraEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + maryEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + alonzoEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + babbageEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 259200, boundSlot = 259200, boundEpoch = 3} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } mainnetEraHist :: Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) mainnetEraHist = @@ -316,43 +316,43 @@ mainnetEraHist = . NonEmptyCons maryEra . NonEmptyCons alonzoEra $ NonEmptyOne babbageEra - where - byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} - } - shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } - babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} - } + where + byronEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 21600, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 4320, eraGenesisWin = 4320} + } + shelleyEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 89856000, boundSlot = 4492800, boundEpoch = 208} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + allegraEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 101952000, boundSlot = 16588800, boundEpoch = 236} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + maryEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 108432000, boundSlot = 23068800, boundEpoch = 251} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + alonzoEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 125280000, boundSlot = 39916800, boundEpoch = 290} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } + babbageEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 157680000, boundSlot = 72316800, boundEpoch = 365} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 432000, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 129600, eraGenesisWin = 129600} + } -- | Extract currency symbol & token name part of an `GYAssetClass` when it is of such a form. When input is @Just GYLovelace@ or @Nothing@, this function returns @Nothing@. extractAssetClass :: Maybe GYAssetClass -> Maybe (Text, Text) diff --git a/src/GeniusYield/Providers/GCP.hs b/src/GeniusYield/Providers/GCP.hs index ae7b8064..29a5ecbb 100644 --- a/src/GeniusYield/Providers/GCP.hs +++ b/src/GeniusYield/Providers/GCP.hs @@ -18,7 +18,7 @@ import Katip.Scribes.Handle import GeniusYield.Imports -gcpFormatter :: (LogItem a) => ItemFormatter a +gcpFormatter :: LogItem a => ItemFormatter a gcpFormatter withColor verb @@ -36,17 +36,17 @@ gcpFormatter LTxt.toStrict $ lazyDecodeUtf8Lenient $ Aeson.encode obj - where - obj = - Aeson.object - [ "severity" .= toGCPSeverity severity - , "message" .= TxtB.toLazyText msgBuilder - , "extraPayload" .= payloadObject verb payload - , "time" .= time - , "threadId" .= tid - , "logging.googleapis.com/sourceLocation" .= (toGCPLoc <$> locMaybe) - , "logging.googleapis.com/labels" .= Aeson.object ["namespaces" .= namespaces] - ] + where + obj = + Aeson.object + [ "severity" .= toGCPSeverity severity + , "message" .= TxtB.toLazyText msgBuilder + , "extraPayload" .= payloadObject verb payload + , "time" .= time + , "threadId" .= tid + , "logging.googleapis.com/sourceLocation" .= (toGCPLoc <$> locMaybe) + , "logging.googleapis.com/labels" .= Aeson.object ["namespaces" .= namespaces] + ] toGCPLoc :: Loc -> Value toGCPLoc Loc {loc_filename, loc_package, loc_module, loc_start = (!lineNum, _)} = diff --git a/src/GeniusYield/Providers/Kupo.hs b/src/GeniusYield/Providers/Kupo.hs index 6a2b9209..39c485a0 100644 --- a/src/GeniusYield/Providers/Kupo.hs +++ b/src/GeniusYield/Providers/Kupo.hs @@ -107,7 +107,7 @@ data KupoProviderException | -- | Received an absurd response from Kupo. This shouldn't ever happen. KupoAbsurdResponse !Text deriving stock (Eq, Show) - deriving anyclass (Exception) + deriving anyclass Exception {-# INLINEABLE handleKupoError #-} handleKupoError :: Text -> Either ClientError a -> IO a @@ -157,7 +157,7 @@ instance FromJSON KupoDatum where data KupoScriptLanguage = Native | PlutusV1 | PlutusV2 | PlutusV3 deriving stock (Eq, Ord, Show, Generic) - deriving (FromJSON) via CustomJSON '[ConstructorTagModifier '[Rename "Native" "native", Rename "PlutusV1" "plutus:v1", Rename "PlutusV2" "plutus:v2", Rename "PlutusV3" "plutus:v3"]] KupoScriptLanguage + deriving FromJSON via CustomJSON '[ConstructorTagModifier '[Rename "Native" "native", Rename "PlutusV1" "plutus:v1", Rename "PlutusV2" "plutus:v2", Rename "PlutusV3" "plutus:v3"]] KupoScriptLanguage newtype KupoScript = KupoScript (Maybe GYAnyScript) deriving stock (Eq, Show, Generic) @@ -215,13 +215,13 @@ instance FromJSON KupoValue where data KupoDatumType = Hash | Inline deriving stock (Show, Eq, Ord, Generic) - deriving (FromJSON) via CustomJSON '[ConstructorTagModifier '[LowerFirst]] KupoDatumType + deriving FromJSON via CustomJSON '[ConstructorTagModifier '[LowerFirst]] KupoDatumType newtype KupoCreatedAt = KupoCreatedAt { slotNo :: Word64 } deriving stock (Show, Eq, Ord, Generic) - deriving (FromJSON) via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoCreatedAt + deriving FromJSON via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoCreatedAt data KupoUtxo = KupoUtxo { transactionId :: !GYTxId @@ -234,7 +234,7 @@ data KupoUtxo = KupoUtxo , createdAt :: !KupoCreatedAt } deriving stock (Show, Eq, Ord, Generic) - deriving (FromJSON) via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoUtxo + deriving FromJSON via CustomJSON '[FieldLabelModifier '[CamelToSnake]] KupoUtxo findDatumByHash :: GYDatumHash -> ClientM KupoDatum findScriptByHash :: GYScriptHash -> ClientM KupoScript @@ -285,8 +285,8 @@ kupoUtxosAtAddress env addr mAssetClass = do Nothing -> commonRequestPart Nothing Nothing Just (mp, tn) -> commonRequestPart (Just mp) (Just tn) utxosFromList <$> traverse (transformUtxo env) (getResponse addrUtxos) - where - locationIdent = "AddressesUtxo" + where + locationIdent = "AddressesUtxo" kupoUtxoAtTxOutRef :: KupoApiEnv -> GYTxOutRef -> IO (Maybe GYUTxO) kupoUtxoAtTxOutRef env oref = do @@ -295,8 +295,8 @@ kupoUtxoAtTxOutRef env oref = do handleKupoError locationIdent <=< runKupoClient env $ fetchUtxosByPattern (Text.pack (show utxoIdx) <> "@" <> txId) True Nothing Nothing listToMaybe <$> traverse (transformUtxo env) (getResponse utxo) - where - locationIdent = "UtxoByRef" + where + locationIdent = "UtxoByRef" kupoUtxosAtPaymentCredential :: KupoApiEnv -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs kupoUtxosAtPaymentCredential env cred mAssetClass = do @@ -308,8 +308,8 @@ kupoUtxosAtPaymentCredential env cred mAssetClass = do Nothing -> commonRequestPart Nothing Nothing Just (mp, tn) -> commonRequestPart (Just mp) (Just tn) utxosFromList <$> traverse (transformUtxo env) (getResponse credUtxos) - where - locationIdent = "PaymentCredentialUtxos" + where + locationIdent = "PaymentCredentialUtxos" transformUtxo :: KupoApiEnv -> KupoUtxo -> IO GYUTxO transformUtxo env KupoUtxo {..} = do @@ -334,9 +334,9 @@ transformUtxo env KupoUtxo {..} = do , utxoOutDatum = dat , utxoRefScript = sc } - where - locationIdent = "transformUtxo" - commonDatumHashError = "No 'datum_hash' present in response whereas 'datum_type' mentions " + where + locationIdent = "transformUtxo" + commonDatumHashError = "No 'datum_hash' present in response whereas 'datum_type' mentions " -- | Definition of 'GYQueryUTxO' for the Kupo provider. kupoQueryUtxo :: KupoApiEnv -> GYQueryUTxO @@ -358,19 +358,19 @@ kupoQueryUtxo env = kupoAwaitTxConfirmed :: KupoApiEnv -> GYAwaitTx kupoAwaitTxConfirmed env p@GYAwaitTxParameters {..} txId = go 0 - where - go attempt - | attempt >= maxAttempts = throwIO $ GYAwaitTxException p - | otherwise = do - utxos <- - handleKupoError locationIdent <=< runKupoClient env $ - fetchUtxosByPattern (Text.pack $ "*@" <> show txId) False Nothing Nothing -- We don't require for only @unspent@. Kupo with @--prune-utxo@ option would still keep spent UTxOs until their spent record is truly immutable (see Kupo docs for more details). - case listToMaybe (getResponse utxos) of - Nothing -> threadDelay checkInterval >> go (attempt + 1) - Just u -> do - let slotsToWait = 3 * confirmations * 20 -- Ouroboros Praos guarantees that there are at least @k@ blocks in a window of @3k / f@ slots where @f@ is the active slot coefficient, which is @0.05@ for Mainnet, Preprod & Preview. - case (lookupResponseHeader utxos :: ResponseHeader "X-Most-Recent-Checkpoint" Word64) of - Header slotOfCurrentBlock -> unless (slotNo (createdAt u) + slotsToWait <= slotOfCurrentBlock) $ threadDelay checkInterval >> go (attempt + 1) - _ -> handleKupoAbsurdResponse locationIdent "Header 'X-Most-Recent-Checkpoint' isn't seen in response" - where - locationIdent = "AwaitTx" + where + go attempt + | attempt >= maxAttempts = throwIO $ GYAwaitTxException p + | otherwise = do + utxos <- + handleKupoError locationIdent <=< runKupoClient env $ + fetchUtxosByPattern (Text.pack $ "*@" <> show txId) False Nothing Nothing -- We don't require for only @unspent@. Kupo with @--prune-utxo@ option would still keep spent UTxOs until their spent record is truly immutable (see Kupo docs for more details). + case listToMaybe (getResponse utxos) of + Nothing -> threadDelay checkInterval >> go (attempt + 1) + Just u -> do + let slotsToWait = 3 * confirmations * 20 -- Ouroboros Praos guarantees that there are at least @k@ blocks in a window of @3k / f@ slots where @f@ is the active slot coefficient, which is @0.05@ for Mainnet, Preprod & Preview. + case (lookupResponseHeader utxos :: ResponseHeader "X-Most-Recent-Checkpoint" Word64) of + Header slotOfCurrentBlock -> unless (slotNo (createdAt u) + slotsToWait <= slotOfCurrentBlock) $ threadDelay checkInterval >> go (attempt + 1) + _ -> handleKupoAbsurdResponse locationIdent "Header 'X-Most-Recent-Checkpoint' isn't seen in response" + where + locationIdent = "AwaitTx" diff --git a/src/GeniusYield/Providers/LiteChainIndex.hs b/src/GeniusYield/Providers/LiteChainIndex.hs index 17ecf4cf..52e1d863 100644 --- a/src/GeniusYield/Providers/LiteChainIndex.hs +++ b/src/GeniusYield/Providers/LiteChainIndex.hs @@ -128,15 +128,15 @@ withChainSync :: (Async.Async () -> IO r) -> IO r withChainSync info resumePoints callback = Async.withAsync (Api.connectToLocalNode info localNodeClientProtocols) - where - localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode - localNodeClientProtocols = - Api.LocalNodeClientProtocols - { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback - , localTxSubmissionClient = Nothing - , localStateQueryClient = Nothing - , localTxMonitoringClient = Nothing - } + where + localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode + localNodeClientProtocols = + Api.LocalNodeClientProtocols + { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback + , localTxSubmissionClient = Nothing + , localStateQueryClient = Nothing + , localTxMonitoringClient = Nothing + } newChainSync :: Api.LocalNodeConnectInfo -> @@ -145,15 +145,15 @@ newChainSync :: IO (Async.Async ()) newChainSync info resumePoints callback = Async.async (Api.connectToLocalNode info localNodeClientProtocols) - where - localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode - localNodeClientProtocols = - Api.LocalNodeClientProtocols - { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback - , localTxSubmissionClient = Nothing - , localStateQueryClient = Nothing - , localTxMonitoringClient = Nothing - } + where + localNodeClientProtocols :: Api.LocalNodeClientProtocolsInMode + localNodeClientProtocols = + Api.LocalNodeClientProtocols + { localChainSyncClient = Api.LocalChainSyncClient $ chainSyncClient resumePoints callback + , localTxSubmissionClient = Nothing + , localStateQueryClient = Nothing + , localTxMonitoringClient = Nothing + } chainSyncClient :: [Api.ChainPoint] -> @@ -162,51 +162,51 @@ chainSyncClient :: chainSyncClient [] cb = chainSyncClient [Api.ChainPointAtGenesis] cb chainSyncClient resumePoints cb = Api.ChainSyncClient $ pure initialise - where - initialise = - Api.Sync.SendMsgFindIntersect resumePoints $ - Api.Sync.ClientStIntersect - { Api.Sync.recvMsgIntersectFound = \point _tip -> Api.ChainSyncClient $ do - cb (Resume point) - pure requestNext - , Api.Sync.recvMsgIntersectNotFound = \_tip -> - Api.ChainSyncClient $ pure requestNext - } - - requestNext :: Api.Sync.ClientStIdle Api.BlockInMode Api.ChainPoint Api.ChainTip IO () - requestNext = Api.Sync.SendMsgRequestNext (pure ()) handleNext - - handleNext = - Api.Sync.ClientStNext - { Api.Sync.recvMsgRollForward = \block tip -> Api.ChainSyncClient $ do - cb (RollForward block tip) - pure requestNext - , Api.Sync.recvMsgRollBackward = \point tip -> Api.ChainSyncClient $ do - cb (RollBackward point tip) + where + initialise = + Api.Sync.SendMsgFindIntersect resumePoints $ + Api.Sync.ClientStIntersect + { Api.Sync.recvMsgIntersectFound = \point _tip -> Api.ChainSyncClient $ do + cb (Resume point) pure requestNext + , Api.Sync.recvMsgIntersectNotFound = \_tip -> + Api.ChainSyncClient $ pure requestNext } + requestNext :: Api.Sync.ClientStIdle Api.BlockInMode Api.ChainPoint Api.ChainTip IO () + requestNext = Api.Sync.SendMsgRequestNext (pure ()) handleNext + + handleNext = + Api.Sync.ClientStNext + { Api.Sync.recvMsgRollForward = \block tip -> Api.ChainSyncClient $ do + cb (RollForward block tip) + pure requestNext + , Api.Sync.recvMsgRollBackward = \point tip -> Api.ChainSyncClient $ do + cb (RollBackward point tip) + pure requestNext + } + ------------------------------------------------------------------------------- -- Utilities ------------------------------------------------------------------------------- blockDatums :: Api.BlockInMode -> [Api.HashableScriptData] blockDatums (Api.BlockInMode _ block) = goBlock block - where - goBlock :: Api.Block era -> [Api.HashableScriptData] - goBlock (Api.Block _header txs) = concatMap goTx txs + where + goBlock :: Api.Block era -> [Api.HashableScriptData] + goBlock (Api.Block _header txs) = concatMap goTx txs - goTx :: Api.Tx era -> [Api.HashableScriptData] - goTx (Api.Tx (Api.TxBody body) _witnesses) = goTxBody body + goTx :: Api.Tx era -> [Api.HashableScriptData] + goTx (Api.Tx (Api.TxBody body) _witnesses) = goTxBody body - goTxBody :: Api.TxBodyContent Api.ViewTx era -> [Api.HashableScriptData] - goTxBody body = concatMap goTxOut (Api.txOuts body) + goTxBody :: Api.TxBodyContent Api.ViewTx era -> [Api.HashableScriptData] + goTxBody body = concatMap goTxOut (Api.txOuts body) - goTxOut :: Api.TxOut Api.CtxTx era -> [Api.HashableScriptData] - goTxOut (Api.TxOut _addr _value datum _) = goDatum datum + goTxOut :: Api.TxOut Api.CtxTx era -> [Api.HashableScriptData] + goTxOut (Api.TxOut _addr _value datum _) = goDatum datum - goDatum :: Api.TxOutDatum Api.CtxTx era -> [Api.HashableScriptData] - goDatum Api.TxOutDatumNone = [] - goDatum (Api.TxOutDatumInTx _ sd) = [sd] - goDatum (Api.TxOutDatumHash _ _h) = [] - goDatum (Api.TxOutDatumInline _ sd) = [sd] + goDatum :: Api.TxOutDatum Api.CtxTx era -> [Api.HashableScriptData] + goDatum Api.TxOutDatumNone = [] + goDatum (Api.TxOutDatumInTx _ sd) = [sd] + goDatum (Api.TxOutDatumHash _ _h) = [] + goDatum (Api.TxOutDatumInline _ sd) = [sd] diff --git a/src/GeniusYield/Providers/Maestro.hs b/src/GeniusYield/Providers/Maestro.hs index d67925a5..5b37aaf2 100644 --- a/src/GeniusYield/Providers/Maestro.hs +++ b/src/GeniusYield/Providers/Maestro.hs @@ -75,7 +75,7 @@ data MaestroProviderException | -- | The API returned an unexpected number of era summaries. MspvIncorrectEraHistoryLength ![Maestro.EraSummary] deriving stock (Eq, Show) - deriving anyclass (Exception) + deriving anyclass Exception throwMspvApiError :: Text -> Maestro.MaestroError -> IO a throwMspvApiError locationInfo = @@ -103,9 +103,9 @@ maestroSubmitTx useTurboSubmit env tx = do pure $ txIdFromHexE $ Text.unpack txId - where - handleMaestroSubmitError :: Either Maestro.MaestroError a -> IO a - handleMaestroSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersMaestroClientError) pure + where + handleMaestroSubmitError :: Either Maestro.MaestroError a -> IO a + handleMaestroSubmitError = either (throwIO . SubmitTxException . Text.pack . show . silenceHeadersMaestroClientError) pure ------------------------------------------------------------------------------- -- Await tx confirmation @@ -114,44 +114,44 @@ maestroSubmitTx useTurboSubmit env tx = do -- | Awaits for the confirmation of a given 'GYTxId' maestroAwaitTxConfirmed :: Maestro.MaestroEnv 'Maestro.V1 -> GYAwaitTx maestroAwaitTxConfirmed env p@GYAwaitTxParameters {..} txId = mspvAwaitTx 0 - where - mspvAwaitTx :: Int -> IO () - mspvAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p - mspvAwaitTx attempt = do - eTxInfo <- maestroQueryTx env txId - case eTxInfo of - Left Maestro.MaestroNotFound -> - threadDelay checkInterval - >> mspvAwaitTx (attempt + 1) - Left err -> throwMspvApiError "AwaitTx" err - Right txInfo -> - msvpAwaitBlock attempt $ - Maestro.txDetailsBlockHash $ - Maestro.getTimestampedData txInfo - - msvpAwaitBlock :: Int -> Maestro.BlockHash -> IO () - msvpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p - msvpAwaitBlock attempt blockHash = do - eBlockInfo <- maestroQueryBlock env blockHash - case eBlockInfo of - Left Maestro.MaestroNotFound -> - threadDelay checkInterval - >> msvpAwaitBlock (attempt + 1) blockHash - Left err -> throwMspvApiError "AwaitBlock" err - Right (Maestro.getTimestampedData -> blockInfo) - | attempt + 1 == maxAttempts -> - when - ( toInteger (Maestro.blockDetailsConfirmations blockInfo) - < toInteger confirmations - ) - $ throwIO - $ GYAwaitTxException p - Right (Maestro.getTimestampedData -> blockInfo) -> - when - ( toInteger (Maestro.blockDetailsConfirmations blockInfo) - < toInteger confirmations - ) - $ threadDelay checkInterval >> msvpAwaitBlock (attempt + 1) blockHash + where + mspvAwaitTx :: Int -> IO () + mspvAwaitTx attempt | maxAttempts <= attempt = throwIO $ GYAwaitTxException p + mspvAwaitTx attempt = do + eTxInfo <- maestroQueryTx env txId + case eTxInfo of + Left Maestro.MaestroNotFound -> + threadDelay checkInterval + >> mspvAwaitTx (attempt + 1) + Left err -> throwMspvApiError "AwaitTx" err + Right txInfo -> + msvpAwaitBlock attempt $ + Maestro.txDetailsBlockHash $ + Maestro.getTimestampedData txInfo + + msvpAwaitBlock :: Int -> Maestro.BlockHash -> IO () + msvpAwaitBlock attempt _ | maxAttempts <= attempt = throwIO $ GYAwaitTxException p + msvpAwaitBlock attempt blockHash = do + eBlockInfo <- maestroQueryBlock env blockHash + case eBlockInfo of + Left Maestro.MaestroNotFound -> + threadDelay checkInterval + >> msvpAwaitBlock (attempt + 1) blockHash + Left err -> throwMspvApiError "AwaitBlock" err + Right (Maestro.getTimestampedData -> blockInfo) + | attempt + 1 == maxAttempts -> + when + ( toInteger (Maestro.blockDetailsConfirmations blockInfo) + < toInteger confirmations + ) + $ throwIO + $ GYAwaitTxException p + Right (Maestro.getTimestampedData -> blockInfo) -> + when + ( toInteger (Maestro.blockDetailsConfirmations blockInfo) + < toInteger confirmations + ) + $ threadDelay checkInterval >> msvpAwaitBlock (attempt + 1) blockHash maestroQueryBlock :: Maestro.MaestroEnv 'Maestro.V1 -> @@ -229,7 +229,7 @@ scriptFromMaestro Maestro.Script {..} = case scriptType of Just sb -> pure $ GYPlutusScript <$> scriptFromCBOR @'PlutusV3 sb -- | Convert Maestro's UTxO to our GY type. -utxoFromMaestro :: (Maestro.IsUtxo a) => a -> Either SomeDeserializeError GYUTxO +utxoFromMaestro :: Maestro.IsUtxo a => a -> Either SomeDeserializeError GYUTxO utxoFromMaestro utxo = do ref <- first DeserializeErrorHex . Web.parseUrlPiece $ Web.toUrlPiece (Maestro.getTxHash utxo) <> "#" <> Web.toUrlPiece (Maestro.getIndex utxo) addr <- maybeToRight DeserializeErrorAddress $ addressFromTextMaybe $ coerce $ Maestro.getAddress utxo @@ -246,7 +246,7 @@ utxoFromMaestro utxo = do } -- | Convert Maestro's UTxO (with datum resolved) to our GY types. -utxoFromMaestroWithDatum :: (Maestro.IsUtxo a) => a -> Either SomeDeserializeError (GYUTxO, Maybe GYDatum) +utxoFromMaestroWithDatum :: Maestro.IsUtxo a => a -> Either SomeDeserializeError (GYUTxO, Maybe GYDatum) utxoFromMaestroWithDatum u = do gyUtxo <- utxoFromMaestro u case utxoOutDatum gyUtxo of @@ -270,8 +270,8 @@ maestroUtxosAtAddress env addr mAssetClass = do addrUtxos <- handleMaestroError locationIdent <=< try $ Maestro.allPages (Maestro.utxosAtAddress env (coerce addrAsText) (Just False) (Just False) (extractedAssetClassToMaestro extractedAssetClass)) either (throwIO . MspvDeserializeFailure locationIdent) (pure . utxosFromList) (traverse utxoFromMaestro addrUtxos) - where - locationIdent = "AddressUtxos" + where + locationIdent = "AddressUtxos" -- | Query UTxOs present at given address with datums. maestroUtxosAtAddressWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> GYAddress -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)] @@ -285,8 +285,8 @@ maestroUtxosAtAddressWithDatums env addr mAssetClass = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum addrUtxos - where - locationIdent = "AddressUtxosWithDatums" + where + locationIdent = "AddressUtxosWithDatums" -- | Query UTxOs present at multiple addresses. maestroUtxosAtAddresses :: Maestro.MaestroEnv 'Maestro.V1 -> [GYAddress] -> IO GYUTxOs @@ -296,8 +296,8 @@ maestroUtxosAtAddresses env addrs = do addrUtxos <- handleMaestroError locationIdent <=< try $ Maestro.allPages (flip (Maestro.utxosAtMultiAddresses env (Just False) (Just False)) $ coerce addrsInText) either (throwIO . MspvDeserializeFailure locationIdent) (pure . utxosFromList) (traverse utxoFromMaestro addrUtxos) - where - locationIdent = "AddressesUtxos" + where + locationIdent = "AddressesUtxos" -- | Query UTxOs present at multiple addresses with datums. maestroUtxosAtAddressesWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> [GYAddress] -> IO [(GYUTxO, Maybe GYDatum)] @@ -310,8 +310,8 @@ maestroUtxosAtAddressesWithDatums env addrs = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum addrUtxos - where - locationIdent = "AddressesUtxosWithDatums" + where + locationIdent = "AddressesUtxosWithDatums" -- | Query UTxOs present at payment credential. maestroUtxosAtPaymentCredential :: Maestro.MaestroEnv 'Maestro.V1 -> GYPaymentCredential -> Maybe GYAssetClass -> IO GYUTxOs @@ -322,8 +322,8 @@ maestroUtxosAtPaymentCredential env paymentCredential mAssetClass = do utxos <- handleMaestroError locationIdent <=< try $ Maestro.allPages $ Maestro.utxosByPaymentCredential env paymentCredentialBech32 (Just False) (Just False) (extractedAssetClassToMaestro extractedAssetClass) either (throwIO . MspvDeserializeFailure locationIdent) (pure . utxosFromList) (traverse utxoFromMaestro utxos) - where - locationIdent = "PaymentCredentialUtxos" + where + locationIdent = "PaymentCredentialUtxos" -- | Query UTxOs present at payment credential with their associated datum fetched (under best effort basis). maestroUtxosAtPaymentCredentialWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> GYPaymentCredential -> Maybe GYAssetClass -> IO [(GYUTxO, Maybe GYDatum)] @@ -337,8 +337,8 @@ maestroUtxosAtPaymentCredentialWithDatums env paymentCredential mAssetClass = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum utxos - where - locationIdent = "PaymentCredentialUtxosWithDatums" + where + locationIdent = "PaymentCredentialUtxosWithDatums" -- | Query UTxOs present at multiple payment credentials. maestroUtxosAtPaymentCredentials :: Maestro.MaestroEnv 'Maestro.V1 -> [GYPaymentCredential] -> IO GYUTxOs @@ -348,8 +348,8 @@ maestroUtxosAtPaymentCredentials env pcs = do utxos <- handleMaestroError locationIdent <=< try $ Maestro.allPages (flip (Maestro.utxosByMultiPaymentCredentials env (Just False) (Just False)) $ coerce paymentCredentialsBech32) either (throwIO . MspvDeserializeFailure locationIdent) (pure . utxosFromList) (traverse utxoFromMaestro utxos) - where - locationIdent = "PaymentCredentialsUtxos" + where + locationIdent = "PaymentCredentialsUtxos" -- | Query UTxOs present at multiple payment credentials with datums. maestroUtxosAtPaymentCredentialsWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> [GYPaymentCredential] -> IO [(GYUTxO, Maybe GYDatum)] @@ -362,8 +362,8 @@ maestroUtxosAtPaymentCredentialsWithDatums env pcs = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum utxos - where - locationIdent = "PaymentCredentialsUtxosWithDatums" + where + locationIdent = "PaymentCredentialsUtxosWithDatums" -- | Returns a list containing all 'GYTxOutRef' for a given 'GYAddress'. maestroRefsAtAddress :: Maestro.MaestroEnv 'Maestro.V1 -> GYAddress -> IO [GYTxOutRef] @@ -378,8 +378,8 @@ maestroRefsAtAddress env addr = do Web.parseUrlPiece $ Web.toUrlPiece outputReferenceObjectTxHash <> "#" <> Web.toUrlPiece outputReferenceObjectIndex ) mTxRefs - where - locationIdent = "RefsAtAddress" + where + locationIdent = "RefsAtAddress" -- | Query UTxO present at a output reference. maestroUtxoAtTxOutRef :: Maestro.MaestroEnv 'Maestro.V1 -> GYTxOutRef -> IO (Maybe GYUTxO) @@ -411,12 +411,12 @@ maestroUtxosAtTxOutRefs' env refs = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestro res - where - -- This particular error is fine in this case, we can just return @mempty@. - handler (Left Maestro.MaestroNotFound) = pure [] - handler other = handleMaestroError locationIdent other + where + -- This particular error is fine in this case, we can just return @mempty@. + handler (Left Maestro.MaestroNotFound) = pure [] + handler other = handleMaestroError locationIdent other - locationIdent = "UtxoByRefs" + locationIdent = "UtxoByRefs" -- | Query UTxOs present at multiple `GYTxOutRef` with datums. maestroUtxosAtTxOutRefsWithDatums :: Maestro.MaestroEnv 'Maestro.V1 -> [GYTxOutRef] -> IO [(GYUTxO, Maybe GYDatum)] @@ -429,12 +429,12 @@ maestroUtxosAtTxOutRefsWithDatums env refs = do (throwIO . MspvDeserializeFailure locationIdent) pure $ traverse utxoFromMaestroWithDatum res - where - -- This particular error is fine in this case, we can just return @mempty@. - handler (Left Maestro.MaestroNotFound) = pure [] - handler other = handleMaestroError locationIdent other + where + -- This particular error is fine in this case, we can just return @mempty@. + handler (Left Maestro.MaestroNotFound) = pure [] + handler other = handleMaestroError locationIdent other - locationIdent = "UtxoByRefsWithDatums" + locationIdent = "UtxoByRefsWithDatums" -- | Definition of 'GYQueryUTxO' for the Maestro provider. maestroQueryUtxo :: Maestro.MaestroEnv 'Maestro.V1 -> GYQueryUTxO @@ -535,8 +535,8 @@ maestroProtocolParams nid env = do , cppDRepActivity = THKD (Ledger.EpochInterval 0) , cppMinFeeRefScriptCostPerByte = THKD minBound } - where - errPath = "GeniusYield.Providers.Maestro.maestroProtocolParams: " + where + errPath = "GeniusYield.Providers.Maestro.maestroProtocolParams: " -- | Returns a set of all Stake Pool's 'Api.S.PoolId'. maestroStakePools :: Maestro.MaestroEnv 'Maestro.V1 -> IO (Set Api.S.PoolId) @@ -552,8 +552,8 @@ maestroStakePools env = do -- Deserialization failure shouldn't happen on Maestro returned pool id. Left err -> throwIO . MspvDeserializeFailure locationIdent $ DeserializeErrorBech32 err Right has -> pure $ Set.fromList has - where - locationIdent = "ListPools" + where + locationIdent = "ListPools" -- | Returns the 'CTime.SystemStart' queried from Maestro. maestroSystemStart :: Maestro.MaestroEnv 'Maestro.V1 -> IO CTime.SystemStart @@ -567,26 +567,26 @@ maestroEraHistory :: Maestro.MaestroEnv 'Maestro.V1 -> IO Api.EraHistory maestroEraHistory env = do eraSumms <- handleMaestroError "EraHistory" =<< try (Maestro.getTimestampedData <$> Maestro.getEraHistory env) maybe (throwIO $ MspvIncorrectEraHistoryLength 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 Maestro.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 Maestro.EraSummary {eraSummaryStart, eraSummaryEnd, eraSummaryParameters} = - Ouroboros.EraSummary - { eraStart = mkBound eraSummaryStart - , eraEnd = maybe Ouroboros.EraUnbounded (Ouroboros.EraEnd . mkBound) eraSummaryEnd - , eraParams = mkEraParams eraSummaryParameters - } + 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 Maestro.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 Maestro.EraSummary {eraSummaryStart, eraSummaryEnd, eraSummaryParameters} = + Ouroboros.EraSummary + { eraStart = mkBound eraSummaryStart + , eraEnd = maybe Ouroboros.EraUnbounded (Ouroboros.EraEnd . mkBound) eraSummaryEnd + , eraParams = mkEraParams eraSummaryParameters + } ------------------------------------------------------------------------------- -- Datum lookup @@ -602,11 +602,11 @@ maestroLookupDatum env dh = do Right bd -> pure bd ) datumMaybe - where - locationIdent = "LookupDatum" - -- This particular error is fine in this case, we can just return 'Nothing'. - handler (Left Maestro.MaestroNotFound) = pure Nothing - handler other = handleMaestroError locationIdent $ Just <$> other + where + locationIdent = "LookupDatum" + -- This particular error is fine in this case, we can just return 'Nothing'. + handler (Left Maestro.MaestroNotFound) = pure Nothing + handler other = handleMaestroError locationIdent $ Just <$> other ------------------------------------------------------------------------------- -- Account info @@ -616,17 +616,17 @@ maestroLookupDatum env dh = do maestroStakeAddressInfo :: Maestro.MaestroEnv 'Maestro.V1 -> GYStakeAddress -> IO (Maybe GYStakeAddressInfo) maestroStakeAddressInfo env saddr = do handler <=< try $ Maestro.getTimestampedData <$> Maestro.accountInfo env (coerce stakeAddressToText saddr) - where - -- This particular error is fine. - handler (Left Maestro.MaestroNotFound) = pure Nothing - handler other = - handleMaestroError "AccountInfo" $ - other <&> \accInfo -> - if Maestro.accountInfoRegistered accInfo - then - Just $ - GYStakeAddressInfo - { gyStakeAddressInfoDelegatedPool = Maestro.accountInfoDelegatedPool accInfo >>= stakePoolIdFromTextMaybe . coerce - , gyStakeAddressInfoAvailableRewards = fromIntegral $ Maestro.accountInfoRewardsAvailable accInfo - } - else Nothing + where + -- This particular error is fine. + handler (Left Maestro.MaestroNotFound) = pure Nothing + handler other = + handleMaestroError "AccountInfo" $ + other <&> \accInfo -> + if Maestro.accountInfoRegistered accInfo + then + Just $ + GYStakeAddressInfo + { gyStakeAddressInfoDelegatedPool = Maestro.accountInfoDelegatedPool accInfo >>= stakePoolIdFromTextMaybe . coerce + , gyStakeAddressInfoAvailableRewards = fromIntegral $ Maestro.accountInfoRewardsAvailable accInfo + } + else Nothing diff --git a/src/GeniusYield/Providers/Node.hs b/src/GeniusYield/Providers/Node.hs index 01e61bc0..9b4a840e 100644 --- a/src/GeniusYield/Providers/Node.hs +++ b/src/GeniusYield/Providers/Node.hs @@ -61,8 +61,8 @@ nodeSlotActions info = , gyWaitForNextBlock' = gyWaitForNextBlockDefault getSlotOfCurrentBlock , gyWaitUntilSlot' = gyWaitUntilSlotDefault getSlotOfCurrentBlock } - where - getSlotOfCurrentBlock = nodeGetSlotOfCurrentBlock info + where + getSlotOfCurrentBlock = nodeGetSlotOfCurrentBlock info ------------------------------------------------------------------------------- -- Parameters diff --git a/src/GeniusYield/Providers/Node/AwaitTx.hs b/src/GeniusYield/Providers/Node/AwaitTx.hs index 5862abac..6efb307f 100644 --- a/src/GeniusYield/Providers/Node/AwaitTx.hs +++ b/src/GeniusYield/Providers/Node/AwaitTx.hs @@ -38,21 +38,21 @@ See: https://docs.cardano.org/about-cardano/learn/chain-confirmation-versus-tran -} nodeAwaitTxConfirmed :: Api.LocalNodeConnectInfo -> GYAwaitTx nodeAwaitTxConfirmed info p@GYAwaitTxParameters {..} txId = go 0 - where - go attempt - | attempt >= maxAttempts = throwIO $ GYAwaitTxException p - | otherwise = do - {- NOTE: Checking for created utxos is not always correct. + where + go attempt + | attempt >= maxAttempts = throwIO $ GYAwaitTxException p + | otherwise = do + {- NOTE: Checking for created utxos is not always correct. - Transactions that create stake deposit with a user who's remaining - utxos are only enough to cover the transaction cost, create no outputs. - However, this is an extreme edge case that is unlikely to ever exist in - privnet tests (where this module is meant to be used, exclusively). - -} - utxos <- nodeUtxosFromTx info txId - -- FIXME: This doesn't actually wait for confirmations. - unless (utxosSize utxos /= 0) $ - threadDelay checkInterval >> go (attempt + 1) + Transactions that create stake deposit with a user who's remaining + utxos are only enough to cover the transaction cost, create no outputs. + However, this is an extreme edge case that is unlikely to ever exist in + privnet tests (where this module is meant to be used, exclusively). + -} + utxos <- nodeUtxosFromTx info txId + -- FIXME: This doesn't actually wait for confirmations. + unless (utxosSize utxos /= 0) $ + threadDelay checkInterval >> go (attempt + 1) -- | Obtain UTxOs created by a transaction. nodeUtxosFromTx :: Api.LocalNodeConnectInfo -> GYTxId -> IO GYUTxOs @@ -72,10 +72,10 @@ nodeUtxosFromTx info txId = do let startIx = 0 uptoIx = 10 go mempty startIx uptoIx - where - go acc startIx uptoIx = do - utxos <- nodeUtxosAtTxOutRefs info $ curry txOutRefFromTuple txId <$> [startIx .. uptoIx] - let acc' = acc <> utxos - if utxosSize utxos == 0 - then pure acc' - else go acc' (uptoIx + 1) (uptoIx * 2) + where + go acc startIx uptoIx = do + utxos <- nodeUtxosAtTxOutRefs info $ curry txOutRefFromTuple txId <$> [startIx .. uptoIx] + let acc' = acc <> utxos + if utxosSize utxos == 0 + then pure acc' + else go acc' (uptoIx + 1) (uptoIx * 2) diff --git a/src/GeniusYield/Providers/Node/Query.hs b/src/GeniusYield/Providers/Node/Query.hs index 309729b3..17cd16ef 100644 --- a/src/GeniusYield/Providers/Node/Query.hs +++ b/src/GeniusYield/Providers/Node/Query.hs @@ -64,10 +64,10 @@ nodeUtxosAtPaymentCredentials :: Api.LocalNodeConnectInfo -> [GYPaymentCredentia nodeUtxosAtPaymentCredentials info creds = do allUtxos <- queryUTxO info Api.QueryUTxOWhole pure $ filterUTxOs (\GYUTxO {utxoAddress} -> matchesCred $ addressToPaymentCredential utxoAddress) allUtxos - where - credSet = Set.fromList creds - matchesCred Nothing = False - matchesCred (Just cred) = cred `Set.member` credSet + where + credSet = Set.fromList creds + matchesCred Nothing = False + matchesCred (Just cred) = cred `Set.member` credSet nodeQueryUTxO :: Api.S.LocalNodeConnectInfo -> GYQueryUTxO nodeQueryUTxO info = diff --git a/src/GeniusYield/Providers/Sentry.hs b/src/GeniusYield/Providers/Sentry.hs index 155b97b7..f58d78dc 100644 --- a/src/GeniusYield/Providers/Sentry.hs +++ b/src/GeniusYield/Providers/Sentry.hs @@ -26,51 +26,51 @@ import System.Log.Raven.Types qualified as Raven mkSentryScribe :: Raven.SentryService -> Katip.PermitFunc -> Katip.Verbosity -> IO Katip.Scribe mkSentryScribe ss pf vb = return $ Katip.Scribe logger (return ()) pf - where - logger :: (Katip.LogItem a) => Katip.Item a -> IO () - logger item = do - let lvl = sentryLevel $ Katip._itemSeverity item - msg = TL.unpack $ Builder.toLazyText $ Katip.unLogStr $ Katip._itemMessage item - nmSpace = sentryNamespace $ Katip._itemNamespace item + where + logger :: Katip.LogItem a => Katip.Item a -> IO () + logger item = do + let lvl = sentryLevel $ Katip._itemSeverity item + msg = TL.unpack $ Builder.toLazyText $ Katip.unLogStr $ Katip._itemMessage item + nmSpace = sentryNamespace $ Katip._itemNamespace item - -- Register Sentry event - -- https://hackage.haskell.org/package/raven-haskell-0.1.4.1/docs/System-Log-Raven.html#v:register - Raven.register ss nmSpace lvl msg (`updateRecord` item) + -- Register Sentry event + -- https://hackage.haskell.org/package/raven-haskell-0.1.4.1/docs/System-Log-Raven.html#v:register + Raven.register ss nmSpace lvl msg (`updateRecord` item) - -- send Ktip.Loc data to sentry - locAttr :: (Katip.LogItem a) => Katip.Item a -> HashMap T.Text Aeson.Value - locAttr item = foldMap (HM.singleton "loc" . Aeson.toJSON . Katip.Core.LocJs) (Katip._itemLoc item) + -- send Ktip.Loc data to sentry + locAttr :: Katip.LogItem a => Katip.Item a -> HashMap T.Text Aeson.Value + locAttr item = foldMap (HM.singleton "loc" . Aeson.toJSON . Katip.Core.LocJs) (Katip._itemLoc item) - -- extra attributes we can send to sentry - srExtra :: (Katip.LogItem a) => Katip.Item a -> HashMap String Aeson.Value - srExtra item = toStringHashMap $ toHashMapText $ Katip.payloadObject vb (Katip._itemPayload item) <> fromHashMapText (locAttr item) - where - toStringHashMap :: HashMap T.Text Aeson.Value -> HashMap String Aeson.Value - toStringHashMap = HM.fromList . map (first T.unpack) . HM.toList + -- extra attributes we can send to sentry + srExtra :: Katip.LogItem a => Katip.Item a -> HashMap String Aeson.Value + srExtra item = toStringHashMap $ toHashMapText $ Katip.payloadObject vb (Katip._itemPayload item) <> fromHashMapText (locAttr item) + where + toStringHashMap :: HashMap T.Text Aeson.Value -> HashMap String Aeson.Value + toStringHashMap = HM.fromList . map (first T.unpack) . HM.toList - updateRecord :: (Katip.LogItem a) => Raven.SentryRecord -> Katip.Item a -> Raven.SentryRecord - updateRecord record item = - record - { Raven.srEnvironment = Just $ T.unpack $ Katip.getEnvironment $ Katip._itemEnv item - , Raven.srExtra = srExtra item - , Raven.srTimestamp = Katip._itemTime item - } + updateRecord :: Katip.LogItem a => Raven.SentryRecord -> Katip.Item a -> Raven.SentryRecord + updateRecord record item = + record + { Raven.srEnvironment = Just $ T.unpack $ Katip.getEnvironment $ Katip._itemEnv item + , Raven.srExtra = srExtra item + , Raven.srTimestamp = Katip._itemTime item + } - -- Sentry Level for Katip Log - sentryLevel :: Katip.Severity -> Raven.SentryLevel - sentryLevel Katip.DebugS = Raven.Debug - sentryLevel Katip.InfoS = Raven.Info - sentryLevel Katip.ErrorS = Raven.Error - sentryLevel Katip.WarningS = Raven.Warning - sentryLevel _ = Raven.Custom "Other" + -- Sentry Level for Katip Log + sentryLevel :: Katip.Severity -> Raven.SentryLevel + sentryLevel Katip.DebugS = Raven.Debug + sentryLevel Katip.InfoS = Raven.Info + sentryLevel Katip.ErrorS = Raven.Error + sentryLevel Katip.WarningS = Raven.Warning + sentryLevel _ = Raven.Custom "Other" - -- gives proper namespace for sentry - -- - -- >>> sentryNamespace $ Katip.Namespace ["GeniusYield", "Providers", "Logging"] - -- "GeniusYield.Providers.Logging" - -- - sentryNamespace :: Katip.Namespace -> String - sentryNamespace (Katip.Namespace ks) = T.unpack $ T.intercalate "." ks + -- gives proper namespace for sentry + -- + -- >>> sentryNamespace $ Katip.Namespace ["GeniusYield", "Providers", "Logging"] + -- "GeniusYield.Providers.Logging" + -- + sentryNamespace :: Katip.Namespace -> String + sentryNamespace (Katip.Namespace ks) = T.unpack $ T.intercalate "." ks -- minimum sentry service constructed from dsn sentryService :: String -> Raven.SentryService diff --git a/src/GeniusYield/ReadJSON.hs b/src/GeniusYield/ReadJSON.hs index 52642a45..7b649b97 100644 --- a/src/GeniusYield/ReadJSON.hs +++ b/src/GeniusYield/ReadJSON.hs @@ -13,7 +13,7 @@ import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS import GeniusYield.Imports -readJSON :: (FromJSON a) => FilePath -> IO a +readJSON :: FromJSON a => FilePath -> IO a readJSON fp = do bs <- LBS.readFile fp case Aeson.eitherDecode' bs of diff --git a/src/GeniusYield/Swagger/Utils.hs b/src/GeniusYield/Swagger/Utils.hs index de499228..2d4a269f 100644 --- a/src/GeniusYield/Swagger/Utils.hs +++ b/src/GeniusYield/Swagger/Utils.hs @@ -29,5 +29,5 @@ addSwaggerExample :: (Functor f1, Functor f2, Swagger.HasSchema b1 a, Swagger.Ha addSwaggerExample ex = mapped . mapped . Swagger.schema . Swagger.example ?~ ex -- | Drop the applied type symbol and convert camel case to snake case. -dropSymbolAndCamelToSnake :: forall a. (KnownSymbol a) => String -> String +dropSymbolAndCamelToSnake :: forall a. KnownSymbol a => String -> String dropSymbolAndCamelToSnake = camelTo2 '_' . drop (length $ symbolVal (Proxy @a)) diff --git a/src/GeniusYield/Test/Clb.hs b/src/GeniusYield/Test/Clb.hs index 42a6e798..9aad3cec 100644 --- a/src/GeniusYield/Test/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -126,7 +126,7 @@ newtype GYTxMonadClb a = GYTxMonadClb { unGYTxMonadClb :: ReaderT GYTxClbEnv (StateT GYTxClbState (ExceptT GYTxMonadException (RandT StdGen AtlasClb))) a } deriving newtype (Functor, Applicative, Monad, MonadReader GYTxClbEnv, MonadState GYTxClbState) - deriving anyclass (GYTxBuilderMonad) + deriving anyclass GYTxBuilderMonad instance MonadRandom GYTxMonadClb where getRandomR = GYTxMonadClb . getRandomR @@ -165,49 +165,49 @@ mkTestFor name action = testNoErrorsTraceClb v w Clb.defaultConway name $ do asClb pureGen (w1 testWallets) nextWalletInt $ action TestInfo {testGoldAsset = fakeCoin fakeGold, testIronAsset = fakeCoin fakeIron, testWallets} - where - -- TODO (simplify-genesis): Remove generation of non ada funds. - v = - valueFromLovelace 1_000_000_000_000_000 - <> fakeValue fakeGold 1_000_000_000 - <> fakeValue fakeIron 1_000_000_000 - - w = - valueFromLovelace 1_000_000_000_000 - <> fakeValue fakeGold 1_000_000 - <> fakeValue fakeIron 1_000_000 - - -- TODO (simplify-genesis):: Remove creation of wallets. Only create one (or more) genesis/funder wallet and pass it on. - testWallets :: Wallets - testWallets = - Wallets - (mkSimpleWallet (Clb.intToKeyPair 1)) - (mkSimpleWallet (Clb.intToKeyPair 2)) - (mkSimpleWallet (Clb.intToKeyPair 3)) - (mkSimpleWallet (Clb.intToKeyPair 4)) - (mkSimpleWallet (Clb.intToKeyPair 5)) - (mkSimpleWallet (Clb.intToKeyPair 6)) - (mkSimpleWallet (Clb.intToKeyPair 7)) - (mkSimpleWallet (Clb.intToKeyPair 8)) - (mkSimpleWallet (Clb.intToKeyPair 9)) - - -- This is the next consecutive number after the highest one used above for 'Clb.intToKeyPair' calls. - nextWalletInt :: Integer - nextWalletInt = 10 - - -- \| Helper for building tests - testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig ApiEra -> String -> AtlasClb a -> Tasty.TestTree - testNoErrorsTraceClb funds walletFunds cfg msg act = - testCaseInfo msg $ - maybe (pure mockLog) assertFailure $ - mbErrors >>= \errors -> pure (mockLog <> "\n\nError :\n-------\n" <> errors) - where - -- _errors since we decided to store errors in the log as well. - (mbErrors, mock) = Clb.runClb (act >> Clb.checkErrors) $ Clb.initClb cfg (valueToApi funds) (valueToApi walletFunds) - mockLog = "\nEmulator log :\n--------------\n" <> logString - options = defaultLayoutOptions {layoutPageWidth = AvailablePerLine 150 1.0} - logDoc = Clb.ppLog $ Clb.mockInfo mock - logString = renderString $ layoutPretty options logDoc + where + -- TODO (simplify-genesis): Remove generation of non ada funds. + v = + valueFromLovelace 1_000_000_000_000_000 + <> fakeValue fakeGold 1_000_000_000 + <> fakeValue fakeIron 1_000_000_000 + + w = + valueFromLovelace 1_000_000_000_000 + <> fakeValue fakeGold 1_000_000 + <> fakeValue fakeIron 1_000_000 + + -- TODO (simplify-genesis):: Remove creation of wallets. Only create one (or more) genesis/funder wallet and pass it on. + testWallets :: Wallets + testWallets = + Wallets + (mkSimpleWallet (Clb.intToKeyPair 1)) + (mkSimpleWallet (Clb.intToKeyPair 2)) + (mkSimpleWallet (Clb.intToKeyPair 3)) + (mkSimpleWallet (Clb.intToKeyPair 4)) + (mkSimpleWallet (Clb.intToKeyPair 5)) + (mkSimpleWallet (Clb.intToKeyPair 6)) + (mkSimpleWallet (Clb.intToKeyPair 7)) + (mkSimpleWallet (Clb.intToKeyPair 8)) + (mkSimpleWallet (Clb.intToKeyPair 9)) + + -- This is the next consecutive number after the highest one used above for 'Clb.intToKeyPair' calls. + nextWalletInt :: Integer + nextWalletInt = 10 + + -- \| Helper for building tests + testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig ApiEra -> String -> AtlasClb a -> Tasty.TestTree + testNoErrorsTraceClb funds walletFunds cfg msg act = + testCaseInfo msg $ + maybe (pure mockLog) assertFailure $ + mbErrors >>= \errors -> pure (mockLog <> "\n\nError :\n-------\n" <> errors) + where + -- _errors since we decided to store errors in the log as well. + (mbErrors, mock) = Clb.runClb (act >> Clb.checkErrors) $ Clb.initClb cfg (valueToApi funds) (valueToApi walletFunds) + mockLog = "\nEmulator log :\n--------------\n" <> logString + options = defaultLayoutOptions {layoutPageWidth = AvailablePerLine 150 1.0} + logDoc = Clb.ppLog $ Clb.mockInfo mock + logString = renderString $ layoutPretty options logDoc mkSimpleWallet :: TL.KeyPair r L.StandardCrypto -> User mkSimpleWallet kp = @@ -248,10 +248,10 @@ mustFailWith isExpectedError act = do } Left err -> liftClb $ logError $ "Action failed with unexpected exception: " ++ show err Right _ -> liftClb $ logError "Expected action to fail but it succeeds" - where - mkMustFailLog (unLog -> pre) (unLog -> post) = - Log $ second (LogEntry Error . ((msg <> ":") <>) . show) <$> Seq.drop (Seq.length pre) post - msg = "Unnamed failure action" + where + mkMustFailLog (unLog -> pre) (unLog -> post) = + Log $ second (LogEntry Error . ((msg <> ":") <>) . show) <$> Seq.drop (Seq.length pre) post + msg = "Unnamed failure action" instance MonadError GYTxMonadException GYTxMonadClb where throwError = GYTxMonadClb . throwError @@ -285,12 +285,12 @@ instance GYTxQueryMonad GYTxMonadClb where Nothing -> utxos Just ac -> filter (\GYUTxO {..} -> valueAssetClass utxoValue ac > 0) utxos return $ utxosFromList utxos' - where - f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) - f ref = do - case txOutRefFromPlutus ref of - Left _ -> return Nothing -- TODO: should it error? - Right ref' -> utxoAtTxOutRef ref' + where + f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) + f ref = do + case txOutRefFromPlutus ref of + Left _ -> return Nothing -- TODO: should it error? + Right ref' -> utxoAtTxOutRef ref' utxosAtPaymentCredential :: GYPaymentCredential -> Maybe GYAssetClass -> GYTxMonadClb GYUTxOs utxosAtPaymentCredential cred mAssetClass = do @@ -301,11 +301,11 @@ instance GYTxQueryMonad GYTxMonadClb where $ filter (\GYUTxO {utxoValue} -> maybe True ((> 0) . valueAssetClass utxoValue) mAssetClass) utxos - where - f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) - f ref = case txOutRefFromPlutus ref of - Left _ -> return Nothing - Right ref' -> utxoAtTxOutRef ref' + where + f :: Plutus.TxOutRef -> GYTxMonadClb (Maybe GYUTxO) + f ref = case txOutRefFromPlutus ref of + Left _ -> return Nothing + Right ref' -> utxoAtTxOutRef ref' utxoAtTxOutRef ref = do -- All UTxOs map @@ -399,11 +399,11 @@ instance GYTxUserQueryMonad GYTxMonadClb where case find utxoTranslatableToV1 $ utxosToList utxos of Just u -> return $ utxoRef u Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Better error message here? - where - ifNotV1 utxos addrs = - case someTxOutRef utxos of - Nothing -> throwError $ GYQueryUTxOException $ GYNoUtxosAtAddress addrs - Just (ref, _) -> return ref + where + ifNotV1 utxos addrs = + case someTxOutRef utxos of + Nothing -> throwError $ GYQueryUTxOException $ GYNoUtxosAtAddress addrs + Just (ref, _) -> return ref instance GYTxMonad GYTxMonadClb where signTxBody = signTxBodyImpl . asks $ userPaymentSKey . clbEnvWallet @@ -416,38 +416,38 @@ instance GYTxMonad GYTxMonadClb where case vRes of Success _state _onChainTx -> pure $ txBodyTxId txBody Fail _ err -> throwAppError . someBackendError . T.pack $ show err - where - -- TODO: use Prettyprinter - dumpBody :: GYTxBody -> GYTxMonadClb () - dumpBody body = do - ins <- mapM utxoAtTxOutRef' $ txBodyTxIns body - refIns <- mapM utxoAtTxOutRef' $ txBodyTxInsReference body - gyLogDebug' "" $ - printf - "fee: %d lovelace\nmint value: %s\nvalidity range: %s\ncollateral: %s\ntotal collateral: %d\ninputs:\n\n%sreference inputs:\n\n%soutputs:\n\n%s" - (txBodyFee body) - (txBodyMintValue body) - (show $ txBodyValidityRange body) - (show $ txBodyCollateral body) - (txBodyTotalCollateralLovelace body) - (concatMap dumpInUTxO ins) - (concatMap dumpInUTxO refIns) - (concatMap dumpOutUTxO $ utxosToList $ txBodyUTxOs body) - - dumpInUTxO :: GYUTxO -> String - dumpInUTxO GYUTxO {..} = - printf " - ref: %s\n" utxoRef - <> printf " addr: %s\n" utxoAddress - <> printf " value: %s\n" utxoValue - <> printf " datum: %s\n" (show utxoOutDatum) - <> printf " ref script: %s\n\n" (show utxoRefScript) - - dumpOutUTxO :: GYUTxO -> String - dumpOutUTxO GYUTxO {..} = - printf " - addr: %s\n" utxoAddress - <> printf " value: %s\n" utxoValue - <> printf " datum: %s\n" (show utxoOutDatum) - <> printf " ref script: %s\n\n" (show utxoRefScript) + where + -- TODO: use Prettyprinter + dumpBody :: GYTxBody -> GYTxMonadClb () + dumpBody body = do + ins <- mapM utxoAtTxOutRef' $ txBodyTxIns body + refIns <- mapM utxoAtTxOutRef' $ txBodyTxInsReference body + gyLogDebug' "" $ + printf + "fee: %d lovelace\nmint value: %s\nvalidity range: %s\ncollateral: %s\ntotal collateral: %d\ninputs:\n\n%sreference inputs:\n\n%soutputs:\n\n%s" + (txBodyFee body) + (txBodyMintValue body) + (show $ txBodyValidityRange body) + (show $ txBodyCollateral body) + (txBodyTotalCollateralLovelace body) + (concatMap dumpInUTxO ins) + (concatMap dumpInUTxO refIns) + (concatMap dumpOutUTxO $ utxosToList $ txBodyUTxOs body) + + dumpInUTxO :: GYUTxO -> String + dumpInUTxO GYUTxO {..} = + printf " - ref: %s\n" utxoRef + <> printf " addr: %s\n" utxoAddress + <> printf " value: %s\n" utxoValue + <> printf " datum: %s\n" (show utxoOutDatum) + <> printf " ref script: %s\n\n" (show utxoRefScript) + + dumpOutUTxO :: GYUTxO -> String + dumpOutUTxO GYUTxO {..} = + printf " - addr: %s\n" utxoAddress + <> printf " value: %s\n" utxoValue + <> printf " datum: %s\n" (show utxoOutDatum) + <> printf " ref script: %s\n\n" (show utxoRefScript) -- Transaction submission and confirmation is immediate in CLB. awaitTxConfirmed' _ _ = pure () @@ -501,62 +501,62 @@ instance GYTxSpecialQueryMonad GYTxMonadClb where eraHistory = do (_, len) <- slotConfig' return $ Api.EraHistory $ eh len - where - eh :: NominalDiffTime -> Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) - eh = - Ouroboros.mkInterpreter - . Ouroboros.Summary - . NonEmptyCons byronEra - . NonEmptyCons shelleyEra - . NonEmptyCons allegraEra - . NonEmptyCons maryEra - . NonEmptyCons alonzoEra - . NonEmptyCons babbageEra - . NonEmptyOne - . conwayEra - - byronEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} - } - shelleyEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - allegraEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - maryEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - alonzoEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - babbageEra = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } - conwayEra len = - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} - , eraEnd = Ouroboros.EraUnbounded - , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength len, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} - } + where + eh :: NominalDiffTime -> Ouroboros.Interpreter (Ouroboros.CardanoEras Ouroboros.StandardCrypto) + eh = + Ouroboros.mkInterpreter + . Ouroboros.Summary + . NonEmptyCons byronEra + . NonEmptyCons shelleyEra + . NonEmptyCons allegraEra + . NonEmptyCons maryEra + . NonEmptyCons alonzoEra + . NonEmptyCons babbageEra + . NonEmptyOne + . conwayEra + + byronEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 4320, eraSlotLength = mkSlotLength 20, eraSafeZone = Ouroboros.StandardSafeZone 864, eraGenesisWin = 0} + } + shelleyEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + allegraEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + maryEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + alonzoEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + babbageEra = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraEnd (Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0}) + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength 1, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } + conwayEra len = + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime = RelativeTime 0, boundSlot = 0, boundEpoch = 0} + , eraEnd = Ouroboros.EraUnbounded + , eraParams = Ouroboros.EraParams {eraEpochSize = 86400, eraSlotLength = mkSlotLength len, eraSafeZone = Ouroboros.StandardSafeZone 25920, eraGenesisWin = 0} + } dumpUtxoState :: GYTxMonadClb () dumpUtxoState = liftClb Clb.dumpUtxoState @@ -569,12 +569,12 @@ pureGen :: StdGen pureGen = mkStdGen 42 -- | This is simply defined as @buildTxBody skeleton >>= signAndSubmitConfirmed@. -sendSkeleton :: (GYTxMonad m) => GYTxSkeleton v -> m GYTxId +sendSkeleton :: GYTxMonad m => GYTxSkeleton v -> m GYTxId sendSkeleton skeleton = snd <$> sendSkeleton' skeleton -sendSkeleton' :: (GYTxMonad m) => GYTxSkeleton v -> m (GYTxBody, GYTxId) +sendSkeleton' :: GYTxMonad m => GYTxSkeleton v -> m (GYTxBody, GYTxId) sendSkeleton' skeleton = buildTxBody skeleton >>= \tx -> signAndSubmitConfirmed tx >>= \txId -> pure (tx, txId) -- | Variant of `logInfo` from @Clb@ that logs a string with @Info@ severity. -logInfoS :: (Monad m) => String -> ClbT ApiEra m () +logInfoS :: Monad m => String -> ClbT ApiEra m () logInfoS s = Clb.logInfo $ Clb.LogEntry Clb.Info s diff --git a/src/GeniusYield/Test/FeeTracker.hs b/src/GeniusYield/Test/FeeTracker.hs index c5a76de5..931cda49 100644 --- a/src/GeniusYield/Test/FeeTracker.hs +++ b/src/GeniusYield/Test/FeeTracker.hs @@ -90,14 +90,14 @@ newtype FeeTracker m a = FeeTracker (FeeTrackerState -> m (a, FeeTrackerState)) deriving via StateT FeeTrackerState m instance - (MonadError GYTxMonadException m) => MonadError GYTxMonadException (FeeTracker m) + MonadError GYTxMonadException m => MonadError GYTxMonadException (FeeTracker m) -- | Perform a special action supported by the specific wrapped monad instance by lifting it to 'FeeTracker'. -ftLift :: (Functor m) => m a -> FeeTracker m a +ftLift :: Functor m => m a -> FeeTracker m a ftLift act = FeeTracker $ \s -> (,s) <$> act -- | Override given transaction building function to track extra lovelace per transaction. -wrapBodyBuilder :: (GYTxUserQueryMonad m) => ([GYTxSkeleton v] -> m GYTxBuildResult) -> [GYTxSkeleton v] -> FeeTracker m GYTxBuildResult +wrapBodyBuilder :: GYTxUserQueryMonad m => ([GYTxSkeleton v] -> m GYTxBuildResult) -> [GYTxSkeleton v] -> FeeTracker m GYTxBuildResult wrapBodyBuilder f skeletons = do ownPkh <- ownChangeAddress >>= addressToPubKeyHash' res <- ftLift $ f skeletons @@ -107,29 +107,29 @@ wrapBodyBuilder f skeletons = do GYTxBuildPartialSuccess _ txBodies -> helpers txBodies _ -> pure () pure res - where - helper ownPkh (skeleton, txBody) = do - -- Actual outputs with their blueprints (counterpart from skeleton) - -- NOTE: This relies on proper ordering. 'txBodyUTxOs txBody' is expected to have the same order - -- as the outputs in the skeleton. The extra balancing outputs at the end of the list of 'txBodyUTxOs txBody' - -- should be truncated by 'zip'. - let outsWithBlueprint = zip (gytxOuts skeleton) . utxosToList $ txBodyUTxOs txBody - feeExtraLovelace = stSingleton ownPkh mempty {uelFees = Sum $ txBodyFee txBody} - depositsExtraLovelace = - foldMap' - ( \(blueprint, actual) -> - let targetAddr = gyTxOutAddress blueprint - deposit = Sum . flip valueAssetClass GYLovelace $ utxoValue actual `valueMinus` gyTxOutValue blueprint - -- These two will cancel out if the ada is going to own address. - ownLostDeposit = stSingleton ownPkh mempty {uelMinAda = deposit} - otherGainedDeposit = maybe mempty (`stSingleton` mempty {uelMinAda = negate deposit}) $ addressToPubKeyHash targetAddr - in ownLostDeposit <> otherGainedDeposit - ) - outsWithBlueprint - modify' (\prev -> prev <> feeExtraLovelace <> depositsExtraLovelace) + where + helper ownPkh (skeleton, txBody) = do + -- Actual outputs with their blueprints (counterpart from skeleton) + -- NOTE: This relies on proper ordering. 'txBodyUTxOs txBody' is expected to have the same order + -- as the outputs in the skeleton. The extra balancing outputs at the end of the list of 'txBodyUTxOs txBody' + -- should be truncated by 'zip'. + let outsWithBlueprint = zip (gytxOuts skeleton) . utxosToList $ txBodyUTxOs txBody + feeExtraLovelace = stSingleton ownPkh mempty {uelFees = Sum $ txBodyFee txBody} + depositsExtraLovelace = + foldMap' + ( \(blueprint, actual) -> + let targetAddr = gyTxOutAddress blueprint + deposit = Sum . flip valueAssetClass GYLovelace $ utxoValue actual `valueMinus` gyTxOutValue blueprint + -- These two will cancel out if the ada is going to own address. + ownLostDeposit = stSingleton ownPkh mempty {uelMinAda = deposit} + otherGainedDeposit = maybe mempty (`stSingleton` mempty {uelMinAda = negate deposit}) $ addressToPubKeyHash targetAddr + in ownLostDeposit <> otherGainedDeposit + ) + outsWithBlueprint + modify' (\prev -> prev <> feeExtraLovelace <> depositsExtraLovelace) -- | Override transaction building code of the inner monad to track extra lovelace per transaction. -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (FeeTracker m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (FeeTracker m) where type TxBuilderStrategy (FeeTracker m) = TxBuilderStrategy m buildTxBodyWithStrategy strat skeleton = do res <- wrapBodyBuilder (\x -> GYTxBuildSuccess . NE.singleton <$> buildTxBodyWithStrategy @m strat (head x)) [skeleton] @@ -143,7 +143,7 @@ instance (GYTxBuilderMonad m) => GYTxBuilderMonad (FeeTracker m) where Useful for building a tx body without the intent to submit it later. Thereby ignoring all the tracked fees from that txbody that won't actually take effect in the wallet (since it won't be submitted). -} -withoutFeeTracking :: (Monad m) => FeeTracker m a -> FeeTracker m a +withoutFeeTracking :: Monad m => FeeTracker m a -> FeeTracker m a withoutFeeTracking act = do s <- get a <- act @@ -168,16 +168,16 @@ newtype FeeTrackerGame m a = FeeTrackerGame (FeeTrackerState -> m (a, FeeTracker deriving via StateT FeeTrackerState m instance - (MonadError GYTxMonadException m) => MonadError GYTxMonadException (FeeTrackerGame m) + MonadError GYTxMonadException m => MonadError GYTxMonadException (FeeTrackerGame m) -evalFtg :: (Functor f) => FeeTrackerGame f b -> f b +evalFtg :: Functor f => FeeTrackerGame f b -> f b evalFtg (FeeTrackerGame act) = fst <$> act mempty -- | Perform a special action supported by the specific wrapped monad instance by lifting it to 'FeeTrackerGame'. -ftgLift :: (Functor m) => m a -> FeeTrackerGame m a +ftgLift :: Functor m => m a -> FeeTrackerGame m a ftgLift act = FeeTrackerGame $ \s -> (,s) <$> act -instance (GYTxGameMonad m) => GYTxGameMonad (FeeTrackerGame m) where +instance GYTxGameMonad m => GYTxGameMonad (FeeTrackerGame m) where type TxMonadOf (FeeTrackerGame m) = FeeTracker (TxMonadOf m) createUser = ftgLift createUser asUser u (FeeTracker act) = FeeTrackerGame $ asUser u . act @@ -212,11 +212,11 @@ Notes: * An empty list means no checks are performed. * The 'GYValue' should be negative to check if the Wallet lost those funds. -} -withWalletBalancesCheckSimple :: (GYTxGameMonad m) => [(User, GYValue)] -> FeeTrackerGame m a -> m a +withWalletBalancesCheckSimple :: GYTxGameMonad m => [(User, GYValue)] -> FeeTrackerGame m a -> m a withWalletBalancesCheckSimple wallValueDiffs = withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs mempty -- | Variant of `withWalletBalancesCheckSimple` that only accounts for transaction fees and not minimum ada deposits. -withWalletBalancesCheckSimpleIgnoreMinDepFor :: (GYTxGameMonad m) => [(User, GYValue)] -> Set User -> FeeTrackerGame m a -> m a +withWalletBalancesCheckSimpleIgnoreMinDepFor :: GYTxGameMonad m => [(User, GYValue)] -> Set User -> FeeTrackerGame m a -> m a withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs ignoreMinDepFor m = evalFtg $ do bs <- mapM (queryBalances . userAddresses' . fst) wallValueDiffs a <- m @@ -246,6 +246,6 @@ withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs ignoreMinDepFor m = (encodeJsonText v) (encodeJsonText diff) pure a - where - encodeJsonText :: (ToJSON a) => a -> Text - encodeJsonText = LT.toStrict . LTE.decodeUtf8 . Aeson.encode + where + encodeJsonText :: ToJSON a => a -> Text + encodeJsonText = LT.toStrict . LTE.decodeUtf8 . Aeson.encode diff --git a/src/GeniusYield/Test/Privnet/Asserts.hs b/src/GeniusYield/Test/Privnet/Asserts.hs index 83bb99a6..c7304e83 100644 --- a/src/GeniusYield/Test/Privnet/Asserts.hs +++ b/src/GeniusYield/Test/Privnet/Asserts.hs @@ -26,13 +26,13 @@ import GeniusYield.Types import GeniusYield.Test.Privnet.Ctx -assertFee :: (HasCallStack) => GYTxBody -> Integer -> Integer -> IO () +assertFee :: HasCallStack => GYTxBody -> Integer -> Integer -> IO () assertFee (txBodyFee -> fee) lb ub | fee < lb = assertFailure $ printf "Fee: %d less than %d" fee lb | fee > ub = assertFailure $ printf "Fee: %d greater than %d" fee ub | otherwise = return () -assertThrown :: forall e a. (Exception e) => (e -> Bool) -> IO a -> IO () +assertThrown :: forall e a. Exception e => (e -> Bool) -> IO a -> IO () assertThrown p action = do thrownRef <- newIORef False void action `catch` \e -> @@ -42,8 +42,8 @@ assertThrown p action = do thrown <- readIORef thrownRef unless thrown $ assertFailure $ "Expecting an exception: " ++ name - where - name = show (typeRep (Proxy @e)) + where + name = show (typeRep (Proxy @e)) -- | Asserts if the user funds change as expected. This function subtracts fees from the given expected value. assertUserFunds :: Integer -> Ctx -> User -> GYValue -> IO () diff --git a/src/GeniusYield/Test/Privnet/Examples/Gift.hs b/src/GeniusYield/Test/Privnet/Examples/Gift.hs index 731a589b..369169c0 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Gift.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Gift.hs @@ -496,7 +496,7 @@ tests setup = -- TODO: NonOutputSupplimentaryDatums is thrown by other tests when this test is run. -- They fail to consume utxos with (inline) datums. -- We need to fix utxosDatums to also return whether the datum was inline. - let addNewGiftV2 :: (GYTxUserQueryMonad m) => GYTxSkeleton 'PlutusV2 -> m (GYTxSkeleton 'PlutusV2) + let addNewGiftV2 :: GYTxUserQueryMonad m => GYTxSkeleton 'PlutusV2 -> m (GYTxSkeleton 'PlutusV2) addNewGiftV2 skeleton = do addr <- scriptAddress giftValidatorV2 return $ @@ -620,7 +620,7 @@ grabGifts validator = do -- | Grab gifts using a referenced validator. grabGiftsRef :: - (GYTxQueryMonad m) => + GYTxQueryMonad m => GYTxOutRef -> GYValidator 'PlutusV2 -> m (Maybe (GYTxSkeleton 'PlutusV2)) @@ -649,7 +649,7 @@ grabGiftsRef ref validator = do -- | Function to check for consistency of collaterals with respect to ledger laws. checkCollateral :: - (Integral a) => + Integral a => -- | Sum of values present in collateral inputs. GYValue -> -- | Value present in return collateral output. @@ -667,5 +667,5 @@ checkCollateral inputValue returnValue totalCollateralLovelace txFee collPer = && totalCollateralLovelace == balanceLovelace && balanceLovelace >= ceiling (txFee * collPer % 100) -- Api checks via `balanceLovelace * 100 >= txFee * collPer` which IMO works as `balanceLovelace` is an integer & 100 but in general `c >= ceil (a / b)` is not equivalent to `c * b >= a`. && inputValue == returnValue <> valueFromLovelace totalCollateralLovelace - where - (balanceLovelace, balanceOther) = valueSplitAda $ inputValue `valueMinus` returnValue + where + (balanceLovelace, balanceOther) = valueSplitAda $ inputValue `valueMinus` returnValue diff --git a/src/GeniusYield/Test/Privnet/Setup.hs b/src/GeniusYield/Test/Privnet/Setup.hs index ac5cc8e9..2b564e7e 100644 --- a/src/GeniusYield/Test/Privnet/Setup.hs +++ b/src/GeniusYield/Test/Privnet/Setup.hs @@ -353,13 +353,13 @@ withPrivnet testnetOpts setupUser = do let setup = Setup $ \targetSev putLog kont -> kont $ ctx {ctxLog = simpleLogging targetSev (putLog . Txt.unpack)} setupUser setup - where - -- \| This is defined same as `cardanoTestnetDefault` except we use our own conway genesis parameters. - cardanoTestnet' opts conf = do - Api.AnyCardanoEra cEra <- pure $ cardanoNodeEra cardanoDefaultTestnetOptions - alonzoGenesis <- getDefaultAlonzoGenesis cEra - (startTime, shelleyGenesis') <- getDefaultShelleyGenesis opts - cardanoTestnet opts conf startTime shelleyGenesis' alonzoGenesis conwayGenesis + where + -- \| This is defined same as `cardanoTestnetDefault` except we use our own conway genesis parameters. + cardanoTestnet' opts conf = do + Api.AnyCardanoEra cEra <- pure $ cardanoNodeEra cardanoDefaultTestnetOptions + alonzoGenesis <- getDefaultAlonzoGenesis cEra + (startTime, shelleyGenesis') <- getDefaultShelleyGenesis opts + cardanoTestnet opts conf startTime shelleyGenesis' alonzoGenesis conwayGenesis ------------------------------------------------------------------------------- -- Generating users @@ -387,8 +387,8 @@ generateUser network = do ) pure User' {userPaymentSKey' = paymentSigningKeyFromApi skey, userAddr = addr, userStakeSKey' = Nothing} - where - stake = Api.NoStakeAddress + where + stake = Api.NoStakeAddress ------------------------------------------------------------------------------- -- Balance @@ -425,6 +425,6 @@ mintTestTokens ctx tn' = do (ac, txBody) <- GY.TestTokens.mintTestTokens tn 1_000_000_000 >>= traverse buildTxBody signAndSubmitConfirmed_ txBody pure ac - where - tn :: GYTokenName - tn = fromString tn' + where + tn :: GYTokenName + tn = fromString tn' diff --git a/src/GeniusYield/Test/Privnet/Utils.hs b/src/GeniusYield/Test/Privnet/Utils.hs index 8baeadf0..ccc59ef2 100644 --- a/src/GeniusYield/Test/Privnet/Utils.hs +++ b/src/GeniusYield/Test/Privnet/Utils.hs @@ -38,5 +38,5 @@ urlPieceFromText t = case Web.parseUrlPiece t of printf "Failed to parse %s from %s: %s\n" (show (typeRep @a)) t msg exitFailure -urlPieceToFile :: forall a. (Web.ToHttpApiData a) => FilePath -> a -> IO () +urlPieceToFile :: forall a. Web.ToHttpApiData a => FilePath -> a -> IO () urlPieceToFile p x = T.IO.writeFile p (Web.toUrlPiece x) diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 1ad18f42..afb81f2c 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -58,15 +58,15 @@ import GeniusYield.Test.FeeTracker as X -- | Runs the second 'Tasty.TestTree' after all tests in the first 'Tasty.TestTree' succeed afterAllSucceed :: Tasty.TestTree -> Tasty.TestTree -> Tasty.TestTree afterAllSucceed = Tasty.after Tasty.AllSucceed . pat - where - pat :: Tasty.TestTree -> String - pat dep = case dep of - Tasty.SingleTest tn _ -> tn - Tasty.TestGroup tn _ -> tn - Tasty.After _ _ dep' -> pat dep' - Tasty.PlusTestOptions _ dep' -> pat dep' - Tasty.WithResource _ f -> pat (f (fail "Not running IO")) - Tasty.AskOptions f -> pat (f mempty) + where + pat :: Tasty.TestTree -> String + pat dep = case dep of + Tasty.SingleTest tn _ -> tn + Tasty.TestGroup tn _ -> tn + Tasty.After _ _ dep' -> pat dep' + Tasty.PlusTestOptions _ dep' -> pat dep' + Tasty.WithResource _ f -> pat (f (fail "Not running IO")) + Tasty.AskOptions f -> pat (f mempty) ------------------------------------------------------------------------------- -- QC @@ -75,9 +75,9 @@ afterAllSucceed = Tasty.after Tasty.AllSucceed . pat -- | Adjust the number of QuickCheck cases to generate. withMaxQCTests :: Int -> Tasty.TestTree -> Tasty.TestTree withMaxQCTests n = Tasty.adjustOption f - where - f :: Tasty.QuickCheckTests -> Tasty.QuickCheckTests - f (Tasty.QuickCheckTests m) = Tasty.QuickCheckTests (min m n) + where + f :: Tasty.QuickCheckTests -> Tasty.QuickCheckTests + f (Tasty.QuickCheckTests m) = Tasty.QuickCheckTests (min m n) ------------------------------------------------------------------------------- -- test assets @@ -132,7 +132,7 @@ data Wallets = Wallets deriving (Show, Eq, Ord) -- | Create an user and fund them with the given amount of lovelace provided by the given funder user. -createUserWithLovelace :: (GYTxGameMonad m) => User -> Natural -> m User +createUserWithLovelace :: GYTxGameMonad m => User -> Natural -> m User createUserWithLovelace funder lovelace = do u <- createUser asUser funder $ do @@ -166,14 +166,14 @@ createUserWithLovelace funder lovelace = do Note: This will obviously require the user to have enough lovelace to cover the fees and min ada deposits for the mints. -} -createUserWithAssets :: (GYTxGameMonad m) => User -> Natural -> [(FakeCoin, Natural)] -> m User +createUserWithAssets :: GYTxGameMonad m => User -> Natural -> [(FakeCoin, Natural)] -> m User createUserWithAssets funder lovelace tokens = do user <- createUserWithLovelace funder lovelace asUser user $ mintTestAssets tokens pure user -- | Create a collateral utxo out of the existing ada within a user wallet. Returns the collateral reference. -generateCollateral :: (GYTxMonad m) => m GYTxOutRef +generateCollateral :: GYTxMonad m => m GYTxOutRef generateCollateral = do addr <- ownChangeAddress gyLogDebug' "mintTestAssets" . T.unpack $ @@ -190,14 +190,14 @@ generateCollateral = do It creates a user with ada, non-ada assets, and a collateral. Thereby making a user ready to participate in smart contracts. -} -createUserFull :: (GYTxGameMonad m) => User -> Natural -> [(FakeCoin, Natural)] -> m User +createUserFull :: GYTxGameMonad m => User -> Natural -> [(FakeCoin, Natural)] -> m User createUserFull funder lovelace tokens = do user <- createUserWithAssets funder lovelace tokens userCollateralRef <- asUser user generateCollateral pure user {userCollateral = Just UserCollateral {userCollateralRef, userCollateralCheck = True}} -- | Mint given amount of test tokens. -mintTestAssets :: (GYTxMonad m) => [(FakeCoin, Natural)] -> m () +mintTestAssets :: GYTxMonad m => [(FakeCoin, Natural)] -> m () mintTestAssets tokens = do addr <- ownChangeAddress let readableTkNames = @@ -218,13 +218,13 @@ mintTestAssets tokens = do ) tokens signAndSubmitConfirmed_ txBody - where - readableTk tk = mintingPolicyIdToText (mintingPolicyId $ fakePolicy tk) <> "." <> T.pack (show $ fakeCoinName tk) + where + readableTk tk = mintingPolicyIdToText (mintingPolicyId $ fakePolicy tk) <> "." <> T.pack (show $ fakeCoinName tk) {- | Computes a `GYTx*Monad` action and returns the result and how this action changed the balance of some "Address". -} -withBalance :: (GYTxQueryMonad m) => String -> User -> m b -> m (b, GYValue) +withBalance :: GYTxQueryMonad m => String -> User -> m b -> m (b, GYValue) withBalance n a m = do old <- queryBalance $ userAddr a b <- m @@ -239,7 +239,7 @@ Notes: * An empty list means no checks are performed. * The 'GYValue' should be negative to check if the Wallet lost those funds. -} -withWalletBalancesCheck :: (GYTxQueryMonad m) => [(User, GYValue)] -> m a -> m a +withWalletBalancesCheck :: GYTxQueryMonad m => [(User, GYValue)] -> m a -> m a withWalletBalancesCheck [] m = m withWalletBalancesCheck ((w, v) : xs) m = do (b, diff) <- withBalance (show $ userAddr w) w $ withWalletBalancesCheck xs m @@ -251,7 +251,7 @@ withWalletBalancesCheck ((w, v) : xs) m = do Returns Nothing if it fails to decode an address contained in the transaction outputs. -} -findLockedUtxosInBody :: (Num a) => GYAddress -> GYTx -> Maybe [a] +findLockedUtxosInBody :: Num a => GYAddress -> GYTx -> Maybe [a] findLockedUtxosInBody addr tx = let os = utxosToList . txBodyUTxOs $ getTxBody tx @@ -264,7 +264,7 @@ findLockedUtxosInBody addr tx = findAllMatches (0, os, []) -- | Find reference scripts at given address. -getRefInfos :: (GYTxQueryMonad m) => GYAddress -> m (Map GYAnyScript GYTxOutRef) +getRefInfos :: GYTxQueryMonad m => GYAddress -> m (Map GYAnyScript GYTxOutRef) getRefInfos addr = do utxo <- utxosAtAddress addr Nothing return $ utxoToRefMap utxo @@ -285,7 +285,7 @@ findRefScriptsInBody body = do {- | Adds the given script to the given address and returns the reference for it. Note: The new utxo is given an inline unit datum. -} -addRefScript :: forall m. (GYTxMonad m) => GYAddress -> GYScript 'PlutusV2 -> m GYTxOutRef +addRefScript :: forall m. GYTxMonad m => GYAddress -> GYScript 'PlutusV2 -> m GYTxOutRef addRefScript addr sc = throwAppError absurdError `runEagerT` do existingUtxos <- lift $ utxosAtAddress addr Nothing @@ -303,12 +303,12 @@ addRefScript addr sc = } lift $ signAndSubmitConfirmed_ txBody maybeToEager . Map.lookup (GYPlutusScript sc) $ findRefScriptsInBody txBody - where - absurdError = someBackendError "Shouldn't happen: no ref in body" + where + absurdError = someBackendError "Shouldn't happen: no ref in body" -- | Adds an input (whose datum we'll refer later) and returns the reference to it. addRefInput :: - (GYTxMonad m) => + GYTxMonad m => -- | Whether to inline this datum? Bool -> -- | Where to place this output? @@ -328,19 +328,19 @@ addRefInput toInline addr dat = lift $ signAndSubmitConfirmed_ txBody maybeToEager . findRefWithDatum $ txBodyUTxOs txBody - where - findRefWithDatum :: GYUTxOs -> Maybe GYTxOutRef - findRefWithDatum utxos = - fmap utxoRef - . find - ( \GYUTxO {utxoOutDatum} -> - case utxoOutDatum of - GYOutDatumHash dh -> hashDatum dat == dh - GYOutDatumInline dat' -> dat == dat' - _ -> False - ) - $ utxosToList utxos - absurdError = someBackendError "Shouldn't happen: no output with expected datum in body" + where + findRefWithDatum :: GYUTxOs -> Maybe GYTxOutRef + findRefWithDatum utxos = + fmap utxoRef + . find + ( \GYUTxO {utxoOutDatum} -> + case utxoOutDatum of + GYOutDatumHash dh -> hashDatum dat == dh + GYOutDatumInline dat' -> dat == dat' + _ -> False + ) + $ utxosToList utxos + absurdError = someBackendError "Shouldn't happen: no output with expected datum in body" {- | Abstraction for explicitly building a Value representing the fees of a transaction. @@ -368,11 +368,11 @@ type EagerT m a = ExceptT a m () {- | If we have a 'Just' value, we can exit with it immediately. So it gets converted to 'Left'. -} -maybeToEager :: (Monad m) => Maybe a -> EagerT m a +maybeToEager :: Monad m => Maybe a -> EagerT m a maybeToEager (Just a) = throwError a maybeToEager Nothing = pure () -- If all goes well, we should finish with a 'Left'. if not, we perform the -- given action to signal error. -runEagerT :: (Monad m) => m a -> ExceptT a m () -> m a +runEagerT :: Monad m => m a -> ExceptT a m () -> m a runEagerT whenError = runExceptT >=> either pure (const whenError) diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index 889ac01e..943af365 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -161,76 +161,76 @@ buildUnsignedTxBody :: Maybe GYTxMetadata -> m (Either GYBuildTxError GYTxBody) buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata = buildTxLoop cstrat extraLovelaceStart - where - certsFinalised = finaliseTxCert (gyBTxEnvProtocolParams env) <$> certs - - step :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError ([GYTxInDetailed v], GYUTxOs, [GYTxOut v])) - step stepStrat = fmap (first GYBuildTxBalancingError) . balanceTxStep env mmint wdrls certsFinalised insOld outsOld stepStrat - - buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) - buildTxLoop stepStrat n - -- Stop trying with RandomImprove if extra lovelace has hit the pre-determined ceiling. - | stepStrat /= GYLargestFirstMultiAsset && n >= randImproveExtraLovelaceCeil = buildTxLoop GYLargestFirstMultiAsset n - | otherwise = do - res <- f stepStrat n - case res of - {- These errors generally indicate the input selection process selected less ada - than necessary. Try again with double the extra lovelace amount -} - Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceNegative {}) -> buildTxLoop stepStrat (n * 2) - Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceTooSmall {}) -> buildTxLoop stepStrat (n * 2) - -- @RandomImprove@ may result into many change outputs, where their minimum ada requirements might be unsatisfiable with available ada. - Left (GYBuildTxBalancingError err@(GYBalancingErrorChangeShortFall _)) -> - retryIfRandomImprove - stepStrat - n - (GYBuildTxBalancingError err) - {- RandomImprove may end up selecting too many inputs to fit in the transaction. - In this case, try with LargestFirst and dial back the extraLovelace param. - -} - Left (GYBuildTxExUnitsTooBig maxUnits currentUnits) -> - retryIfRandomImprove - stepStrat - n - (GYBuildTxExUnitsTooBig maxUnits currentUnits) - Left (GYBuildTxSizeTooBig maxPossibleSize currentSize) -> - retryIfRandomImprove - stepStrat - n - (GYBuildTxSizeTooBig maxPossibleSize currentSize) - Right x -> pure $ Right x - {- The most common error here would be: - - InsufficientFunds - - Script validation failure - - Tx not within validity range specified timeframe - - No need to try again for these. - -} - other -> pure other - - f :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) - f stepStrat pessimisticFee = do - stepRes <- step stepStrat pessimisticFee - pure $ - stepRes >>= \(ins, collaterals, outs) -> - finalizeGYBalancedTx - env - GYBalancedTx - { gybtxIns = ins - , gybtxCollaterals = collaterals - , gybtxOuts = outs - , gybtxMint = mmint - , gybtxWdrls = wdrls - , gybtxCerts = certsFinalised - , gybtxInvalidBefore = lb - , gybtxInvalidAfter = ub - , gybtxSigners = signers - , gybtxRefIns = refIns - , gybtxMetadata = mbTxMetadata - } - (length outsOld) - - retryIfRandomImprove GYRandomImproveMultiAsset n _ = buildTxLoop GYLargestFirstMultiAsset (if n == extraLovelaceStart then extraLovelaceStart else n `div` 2) - retryIfRandomImprove _ _ err = pure $ Left err + where + certsFinalised = finaliseTxCert (gyBTxEnvProtocolParams env) <$> certs + + step :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError ([GYTxInDetailed v], GYUTxOs, [GYTxOut v])) + step stepStrat = fmap (first GYBuildTxBalancingError) . balanceTxStep env mmint wdrls certsFinalised insOld outsOld stepStrat + + buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) + buildTxLoop stepStrat n + -- Stop trying with RandomImprove if extra lovelace has hit the pre-determined ceiling. + | stepStrat /= GYLargestFirstMultiAsset && n >= randImproveExtraLovelaceCeil = buildTxLoop GYLargestFirstMultiAsset n + | otherwise = do + res <- f stepStrat n + case res of + {- These errors generally indicate the input selection process selected less ada + than necessary. Try again with double the extra lovelace amount -} + Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceNegative {}) -> buildTxLoop stepStrat (n * 2) + Left (GYBuildTxBodyErrorAutoBalance Api.TxBodyErrorAdaBalanceTooSmall {}) -> buildTxLoop stepStrat (n * 2) + -- @RandomImprove@ may result into many change outputs, where their minimum ada requirements might be unsatisfiable with available ada. + Left (GYBuildTxBalancingError err@(GYBalancingErrorChangeShortFall _)) -> + retryIfRandomImprove + stepStrat + n + (GYBuildTxBalancingError err) + {- RandomImprove may end up selecting too many inputs to fit in the transaction. + In this case, try with LargestFirst and dial back the extraLovelace param. + -} + Left (GYBuildTxExUnitsTooBig maxUnits currentUnits) -> + retryIfRandomImprove + stepStrat + n + (GYBuildTxExUnitsTooBig maxUnits currentUnits) + Left (GYBuildTxSizeTooBig maxPossibleSize currentSize) -> + retryIfRandomImprove + stepStrat + n + (GYBuildTxSizeTooBig maxPossibleSize currentSize) + Right x -> pure $ Right x + {- The most common error here would be: + - InsufficientFunds + - Script validation failure + - Tx not within validity range specified timeframe + + No need to try again for these. + -} + other -> pure other + + f :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) + f stepStrat pessimisticFee = do + stepRes <- step stepStrat pessimisticFee + pure $ + stepRes >>= \(ins, collaterals, outs) -> + finalizeGYBalancedTx + env + GYBalancedTx + { gybtxIns = ins + , gybtxCollaterals = collaterals + , gybtxOuts = outs + , gybtxMint = mmint + , gybtxWdrls = wdrls + , gybtxCerts = certsFinalised + , gybtxInvalidBefore = lb + , gybtxInvalidAfter = ub + , gybtxSigners = signers + , gybtxRefIns = refIns + , gybtxMetadata = mbTxMetadata + } + (length outsOld) + + retryIfRandomImprove GYRandomImproveMultiAsset n _ = buildTxLoop GYLargestFirstMultiAsset (if n == extraLovelaceStart then extraLovelaceStart else n `div` 2) + retryIfRandomImprove _ _ err = pure $ Left err ------------------------------------------------------------------------------- -- Primary balancing logic @@ -321,14 +321,14 @@ balanceTxStep } cstrat pure (ins ++ addIns, collaterals, adjustedOuts ++ changeOuts) - where - isScriptWitness GYTxInWitnessKey = False - isScriptWitness GYTxInWitnessScript {} = True - isScriptWitness GYTxInWitnessSimpleScript {} = False -- Simple (native) scripts don't require collateral. - isCertScriptWitness (Just GYTxCertWitnessScript {}) = True - isCertScriptWitness _ = False - isWdrlScriptWitness GYTxWdrlWitnessScript {} = True - isWdrlScriptWitness _ = False + where + isScriptWitness GYTxInWitnessKey = False + isScriptWitness GYTxInWitnessScript {} = True + isScriptWitness GYTxInWitnessSimpleScript {} = False -- Simple (native) scripts don't require collateral. + isCertScriptWitness (Just GYTxCertWitnessScript {}) = True + isCertScriptWitness _ = False + isWdrlScriptWitness GYTxWdrlWitnessScript {} = True + isWdrlScriptWitness _ = False retColSup :: Api.BabbageEraOnwards ApiEra retColSup = Api.BabbageEraOnwardsConway @@ -366,173 +366,173 @@ finalizeGYBalancedTx changeAddr unregisteredStakeCredsMap estimateKeyWitnesses - where - -- Over-estimate the number of key witnesses required for the transaction. - -- We do not provide support for byron key witnesses in our estimate as @Api.makeTransactionBodyAutoBalance@ does not consider them, i.e., count of key witnesses returned here are considered as shelley key witnesses by cardano api. - estimateKeyWitnesses :: Word = - fromIntegral $ - countUnique $ - mapMaybe (extractPaymentPkhFromAddress . utxoAddress) (utxosToList collaterals) - <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferSCByKey sc]] - <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferSCByKey sc]] - <> estimateKeyWitnessesFromInputs ins - <> Set.toList signers - where - extractPaymentPkhFromAddress gyaddr = - addressToPaymentCredential gyaddr >>= \case - GYPaymentCredentialByKey pkh -> Just $ toPubKeyHash pkh - GYPaymentCredentialByScript _ -> Nothing - - preferSCByKey (GYStakeCredentialByKey pkh) = Just $ toPubKeyHash pkh - preferSCByKey _otherwise = Nothing - - countUnique :: (Ord a) => [a] -> Int - countUnique = Set.size . Set.fromList - - estimateKeyWitnessesFromInputs txInDets = - -- Count key witnesses. - [apkh | txInDet@GYTxInDetailed {gyTxInDet = GYTxIn {gyTxInWitness = GYTxInWitnessKey}} <- txInDets, let gyaddr = gyTxInDetAddress txInDet, Just apkh <- [extractPaymentPkhFromAddress gyaddr]] - ++ - -- Estimate key witnesses required by native scripts. - map toPubKeyHash (Set.toList $ foldl' estimateKeyWitnessesFromNativeScripts mempty txInDets) - where - estimateKeyWitnessesFromNativeScripts acc (gyTxInWitness . gyTxInDet -> GYTxInWitnessSimpleScript gyInSS) = - case gyInSS of - GYInSimpleScript s -> getTotalKeysInSimpleScript s <> acc - GYInReferenceSimpleScript _ s -> getTotalKeysInSimpleScript s <> acc - estimateKeyWitnessesFromNativeScripts acc _ = acc - - inRefs :: Api.TxInsReference Api.BuildTx ApiEra - inRefs = case inRefs' of - [] -> Api.TxInsReferenceNone - _ -> Api.TxInsReference Api.BabbageEraOnwardsConway inRefs' - - inRefs' :: [Api.TxIn] - inRefs' = [txOutRefToApi r | r <- utxosRefs utxosRefInputs] - - -- utxos for inputs - utxosIn :: GYUTxOs - utxosIn = utxosFromList $ utxoFromTxInDetailed <$> ins - - -- Map to lookup information for various utxos. - utxos :: GYUTxOs - utxos = utxosIn <> utxosRefInputs <> collaterals - - outs' :: [Api.S.TxOut Api.S.CtxTx ApiEra] - outs' = txOutToApi <$> outs - - ins' :: [(Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra))] - ins' = [txInToApi (isInlineDatum $ gyTxInDetDatum i) (gyTxInDet i) | i <- ins] - - collaterals' :: Api.TxInsCollateral ApiEra - collaterals' = case utxosRefs collaterals of - [] -> Api.TxInsCollateralNone - orefs -> Api.TxInsCollateral Api.AlonzoEraOnwardsConway $ txOutRefToApi <$> orefs - - -- will be filled by makeTransactionBodyAutoBalance - fee :: Api.TxFee ApiEra - fee = Api.TxFeeExplicit Api.ShelleyBasedEraConway $ Ledger.Coin 0 - - lb' :: Api.TxValidityLowerBound ApiEra - lb' = - maybe - Api.TxValidityNoLowerBound - (Api.TxValidityLowerBound Api.AllegraEraOnwardsConway . slotToApi) - lb - - ub' :: Api.TxValidityUpperBound ApiEra - ub' = Api.TxValidityUpperBound Api.ShelleyBasedEraConway $ slotToApi <$> ub - - extra :: Api.TxExtraKeyWitnesses ApiEra - extra = case toList signers of - [] -> Api.TxExtraKeyWitnessesNone - pkhs -> Api.TxExtraKeyWitnesses Api.AlonzoEraOnwardsConway $ pubKeyHashToApi <$> pkhs - - mint :: Api.TxMintValue Api.BuildTx ApiEra - mint = case mmint of - Nothing -> Api.TxMintNone - Just (v, xs) -> - Api.TxMintValue Api.MaryEraOnwardsConway (valueToApi v) $ - Api.BuildTxWith $ - Map.fromList - [ ( mintingPolicyApiIdFromWitness p - , gyMintingScriptWitnessToApiPlutusSW - p - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + where + -- Over-estimate the number of key witnesses required for the transaction. + -- We do not provide support for byron key witnesses in our estimate as @Api.makeTransactionBodyAutoBalance@ does not consider them, i.e., count of key witnesses returned here are considered as shelley key witnesses by cardano api. + estimateKeyWitnesses :: Word = + fromIntegral $ + countUnique $ + mapMaybe (extractPaymentPkhFromAddress . utxoAddress) (utxosToList collaterals) + <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferSCByKey sc]] + <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferSCByKey sc]] + <> estimateKeyWitnessesFromInputs ins + <> Set.toList signers + where + extractPaymentPkhFromAddress gyaddr = + addressToPaymentCredential gyaddr >>= \case + GYPaymentCredentialByKey pkh -> Just $ toPubKeyHash pkh + GYPaymentCredentialByScript _ -> Nothing + + preferSCByKey (GYStakeCredentialByKey pkh) = Just $ toPubKeyHash pkh + preferSCByKey _otherwise = Nothing + + countUnique :: Ord a => [a] -> Int + countUnique = Set.size . Set.fromList + + estimateKeyWitnessesFromInputs txInDets = + -- Count key witnesses. + [apkh | txInDet@GYTxInDetailed {gyTxInDet = GYTxIn {gyTxInWitness = GYTxInWitnessKey}} <- txInDets, let gyaddr = gyTxInDetAddress txInDet, Just apkh <- [extractPaymentPkhFromAddress gyaddr]] + ++ + -- Estimate key witnesses required by native scripts. + map toPubKeyHash (Set.toList $ foldl' estimateKeyWitnessesFromNativeScripts mempty txInDets) + where + estimateKeyWitnessesFromNativeScripts acc (gyTxInWitness . gyTxInDet -> GYTxInWitnessSimpleScript gyInSS) = + case gyInSS of + GYInSimpleScript s -> getTotalKeysInSimpleScript s <> acc + GYInReferenceSimpleScript _ s -> getTotalKeysInSimpleScript s <> acc + estimateKeyWitnessesFromNativeScripts acc _ = acc + + inRefs :: Api.TxInsReference Api.BuildTx ApiEra + inRefs = case inRefs' of + [] -> Api.TxInsReferenceNone + _ -> Api.TxInsReference Api.BabbageEraOnwardsConway inRefs' + + inRefs' :: [Api.TxIn] + inRefs' = [txOutRefToApi r | r <- utxosRefs utxosRefInputs] + + -- utxos for inputs + utxosIn :: GYUTxOs + utxosIn = utxosFromList $ utxoFromTxInDetailed <$> ins + + -- Map to lookup information for various utxos. + utxos :: GYUTxOs + utxos = utxosIn <> utxosRefInputs <> collaterals + + outs' :: [Api.S.TxOut Api.S.CtxTx ApiEra] + outs' = txOutToApi <$> outs + + ins' :: [(Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra))] + ins' = [txInToApi (isInlineDatum $ gyTxInDetDatum i) (gyTxInDet i) | i <- ins] + + collaterals' :: Api.TxInsCollateral ApiEra + collaterals' = case utxosRefs collaterals of + [] -> Api.TxInsCollateralNone + orefs -> Api.TxInsCollateral Api.AlonzoEraOnwardsConway $ txOutRefToApi <$> orefs + + -- will be filled by makeTransactionBodyAutoBalance + fee :: Api.TxFee ApiEra + fee = Api.TxFeeExplicit Api.ShelleyBasedEraConway $ Ledger.Coin 0 + + lb' :: Api.TxValidityLowerBound ApiEra + lb' = + maybe + Api.TxValidityNoLowerBound + (Api.TxValidityLowerBound Api.AllegraEraOnwardsConway . slotToApi) + lb + + ub' :: Api.TxValidityUpperBound ApiEra + ub' = Api.TxValidityUpperBound Api.ShelleyBasedEraConway $ slotToApi <$> ub + + extra :: Api.TxExtraKeyWitnesses ApiEra + extra = case toList signers of + [] -> Api.TxExtraKeyWitnessesNone + pkhs -> Api.TxExtraKeyWitnesses Api.AlonzoEraOnwardsConway $ pubKeyHashToApi <$> pkhs + + mint :: Api.TxMintValue Api.BuildTx ApiEra + mint = case mmint of + Nothing -> Api.TxMintNone + Just (v, xs) -> + Api.TxMintValue Api.MaryEraOnwardsConway (valueToApi v) $ + Api.BuildTxWith $ + Map.fromList + [ ( mintingPolicyApiIdFromWitness p + , gyMintingScriptWitnessToApiPlutusSW + p + (redeemerToApi r) + (Api.ExecutionUnits 0 0) + ) + | (p, r) <- xs + ] + + -- Putting `TxTotalCollateralNone` & `TxReturnCollateralNone` would have them appropriately calculated by `makeTransactionBodyAutoBalance` but then return collateral it generates is only for ada. To support multi-asset collateral input we therefore calculate correct values ourselves and put appropriate entries here to have `makeTransactionBodyAutoBalance` calculate appropriate overestimated fees. + (dummyTotCol :: Api.TxTotalCollateral ApiEra, dummyRetCol :: Api.TxReturnCollateral Api.CtxTx ApiEra) = + if mempty == collaterals + then + (Api.TxTotalCollateralNone, Api.TxReturnCollateralNone) + else + ( -- Total collateral must be <= lovelaces available in collateral inputs. + Api.TxTotalCollateral retColSup (Ledger.Coin $ fst $ valueSplitAda collateralTotalValue) + , -- Return collateral must be <= what is in collateral inputs. + Api.TxReturnCollateral retColSup $ txOutToApi $ GYTxOut changeAddr collateralTotalValue Nothing Nothing + ) + where + collateralTotalValue :: GYValue + collateralTotalValue = foldMapUTxOs utxoValue collaterals + + txMetadata :: Api.TxMetadataInEra ApiEra + txMetadata = maybe Api.TxMetadataNone toMetaInEra mbTxMetadata + where + toMetaInEra :: GYTxMetadata -> Api.TxMetadataInEra ApiEra + toMetaInEra gymd = + let md = txMetadataToApi gymd + in if md == mempty then Api.TxMetadataNone else Api.TxMetadataInEra Api.ShelleyBasedEraConway md + + wdrls' :: Api.TxWithdrawals Api.BuildTx ApiEra + wdrls' = if wdrls == mempty then Api.TxWithdrawalsNone else Api.TxWithdrawals Api.ShelleyBasedEraConway $ map txWdrlToApi wdrls + + certs' = + if certs == mempty + then Api.TxCertificatesNone + else + let apiCertsFromGY = + foldl' + ( \(accCerts, accWits) cert -> + let (apiCert, mapiWit) = txCertToApi cert + apiWit = maybe Map.empty (uncurry Map.singleton) mapiWit + in (apiCert : accCerts, accWits <> apiWit) ) - | (p, r) <- xs - ] - - -- Putting `TxTotalCollateralNone` & `TxReturnCollateralNone` would have them appropriately calculated by `makeTransactionBodyAutoBalance` but then return collateral it generates is only for ada. To support multi-asset collateral input we therefore calculate correct values ourselves and put appropriate entries here to have `makeTransactionBodyAutoBalance` calculate appropriate overestimated fees. - (dummyTotCol :: Api.TxTotalCollateral ApiEra, dummyRetCol :: Api.TxReturnCollateral Api.CtxTx ApiEra) = - if mempty == collaterals - then - (Api.TxTotalCollateralNone, Api.TxReturnCollateralNone) - else - ( -- Total collateral must be <= lovelaces available in collateral inputs. - Api.TxTotalCollateral retColSup (Ledger.Coin $ fst $ valueSplitAda collateralTotalValue) - , -- Return collateral must be <= what is in collateral inputs. - Api.TxReturnCollateral retColSup $ txOutToApi $ GYTxOut changeAddr collateralTotalValue Nothing Nothing - ) - where - collateralTotalValue :: GYValue - collateralTotalValue = foldMapUTxOs utxoValue collaterals - - txMetadata :: Api.TxMetadataInEra ApiEra - txMetadata = maybe Api.TxMetadataNone toMetaInEra mbTxMetadata - where - toMetaInEra :: GYTxMetadata -> Api.TxMetadataInEra ApiEra - toMetaInEra gymd = - let md = txMetadataToApi gymd - in if md == mempty then Api.TxMetadataNone else Api.TxMetadataInEra Api.ShelleyBasedEraConway md - - wdrls' :: Api.TxWithdrawals Api.BuildTx ApiEra - wdrls' = if wdrls == mempty then Api.TxWithdrawalsNone else Api.TxWithdrawals Api.ShelleyBasedEraConway $ map txWdrlToApi wdrls - - certs' = - if certs == mempty - then Api.TxCertificatesNone - else - let apiCertsFromGY = - foldl' - ( \(accCerts, accWits) cert -> - let (apiCert, mapiWit) = txCertToApi cert - apiWit = maybe Map.empty (uncurry Map.singleton) mapiWit - in (apiCert : accCerts, accWits <> apiWit) - ) - (mempty, mempty) - certs - in Api.TxCertificates Api.ShelleyBasedEraConway (reverse $ fst apiCertsFromGY) $ Api.BuildTxWith (snd apiCertsFromGY) - - unregisteredStakeCredsMap = Map.fromList [(stakeCredentialToApi sc, fromIntegral amt) | GYStakeAddressDeregistrationCertificate amt sc <- map gyTxCertCertificate' certs] - - body :: Api.TxBodyContent Api.BuildTx ApiEra - body = - Api.TxBodyContent - { Api.txIns = ins' - , Api.txInsCollateral = collaterals' - , Api.txInsReference = inRefs - , Api.txOuts = outs' - , Api.txTotalCollateral = dummyTotCol - , Api.txReturnCollateral = dummyRetCol - , Api.txFee = fee - , Api.txValidityLowerBound = lb' - , Api.txValidityUpperBound = ub' - , Api.txMetadata = txMetadata - , Api.txAuxScripts = Api.TxAuxScriptsNone - , Api.txExtraKeyWits = extra - , Api.txProtocolParams = Api.BuildTxWith $ Just $ Api.S.LedgerProtocolParameters pp - , Api.txWithdrawals = wdrls' - , Api.txCertificates = certs' - , Api.txUpdateProposal = Api.TxUpdateProposalNone - , Api.txMintValue = mint - , Api.txScriptValidity = Api.TxScriptValidityNone - , Api.txProposalProcedures = Nothing - , Api.txVotingProcedures = Nothing - , Api.txCurrentTreasuryValue = Nothing -- FIXME:? - , Api.txTreasuryDonation = Nothing - } + (mempty, mempty) + certs + in Api.TxCertificates Api.ShelleyBasedEraConway (reverse $ fst apiCertsFromGY) $ Api.BuildTxWith (snd apiCertsFromGY) + + unregisteredStakeCredsMap = Map.fromList [(stakeCredentialToApi sc, fromIntegral amt) | GYStakeAddressDeregistrationCertificate amt sc <- map gyTxCertCertificate' certs] + + body :: Api.TxBodyContent Api.BuildTx ApiEra + body = + Api.TxBodyContent + { Api.txIns = ins' + , Api.txInsCollateral = collaterals' + , Api.txInsReference = inRefs + , Api.txOuts = outs' + , Api.txTotalCollateral = dummyTotCol + , Api.txReturnCollateral = dummyRetCol + , Api.txFee = fee + , Api.txValidityLowerBound = lb' + , Api.txValidityUpperBound = ub' + , Api.txMetadata = txMetadata + , Api.txAuxScripts = Api.TxAuxScriptsNone + , Api.txExtraKeyWits = extra + , Api.txProtocolParams = Api.BuildTxWith $ Just $ Api.S.LedgerProtocolParameters pp + , Api.txWithdrawals = wdrls' + , Api.txCertificates = certs' + , Api.txUpdateProposal = Api.TxUpdateProposalNone + , Api.txMintValue = mint + , Api.txScriptValidity = Api.TxScriptValidityNone + , Api.txProposalProcedures = Nothing + , Api.txVotingProcedures = Nothing + , Api.txCurrentTreasuryValue = Nothing -- FIXME:? + , Api.txTreasuryDonation = Nothing + } {- | Wraps around 'Api.makeTransactionBodyAutoBalance' just to verify the final ex units and tx size are within limits. @@ -693,7 +693,7 @@ collapseExtraOut apiOut@(Api.TxOut _ outVal _ _) bodyContent@Api.TxBodyContent { in Api.S.createAndValidateTransactionBody Api.ShelleyBasedEraConway $ bodyContent {Api.txOuts = nOuts} - where - (skeletonOuts, changeOuts) = splitAt numSkeletonOuts txOuts + where + (skeletonOuts, changeOuts) = splitAt numSkeletonOuts txOuts type ShelleyBasedConwayEra = Api.S.ShelleyLedgerEra ApiEra diff --git a/src/GeniusYield/Transaction/CBOR.hs b/src/GeniusYield/Transaction/CBOR.hs index 39b705ae..81db323c 100644 --- a/src/GeniusYield/Transaction/CBOR.hs +++ b/src/GeniusYield/Transaction/CBOR.hs @@ -75,11 +75,11 @@ recursiveTermModification f term = TMapI termPairList -> recursiveTermModificationHandler $ TMapI $ bimap (recursiveTermModification f) (recursiveTermModification f) <$> termPairList TTagged word otherTerm -> recursiveTermModificationHandler $ TTagged word $ recursiveTermModification f otherTerm _otherwise -> recursiveTermModificationHandler term - where - recursiveTermModificationHandler nothingHandler = - case f term of - Nothing -> nothingHandler - Just termMod -> if term == termMod then nothingHandler else recursiveTermModification f termMod + where + recursiveTermModificationHandler nothingHandler = + case f term of + Nothing -> nothingHandler + Just termMod -> if term == termMod then nothingHandler else recursiveTermModification f termMod -- | See `simplifyTxCbor`. simplifyTxBodyCbor :: Term -> Term @@ -89,34 +89,34 @@ simplifyTxBodyCbor txBody = -- Second, we'll sort keys in any map. txBodySortedKeys = recursiveTermModification sortMapKeys txBodyDefinite in txBodySortedKeys - where - sortMapKeys :: Term -> Maybe Term - sortMapKeys (TMap keyValsToSort) = - if allSameType - then - Just $ TMap $ sortBy sortingFunction keyValsToSort - else Nothing - where - sortingFunction :: forall b1 b2. (Term, b1) -> (Term, b2) -> Ordering - sortingFunction (TInt a, _) (TInt b, _) = compare a b - sortingFunction (TInteger a, _) (TInteger b, _) = compare a b - sortingFunction (TBytes a, _) (TBytes b, _) = compare (B.length a) (B.length b) <> compare a b - sortingFunction (TString a, _) (TString b, _) = compare (T.length a) (T.length b) <> compare a b - sortingFunction _ _ = error "absurd - sortingFunction" -- We verify that all keys are of the same appropriate type before calling this function. - allSameType = any ($ keyValsToSort) [isTInt, isTInteger, isTBytes, isTString] - where - isTInt = all (\(k, _) -> case k of TInt _ -> True; _ow -> False) - isTInteger = all (\(k, _) -> case k of TInteger _ -> True; _ow -> False) - isTBytes = all (\(k, _) -> case k of TBytes _ -> True; _ow -> False) - isTString = all (\(k, _) -> case k of TString _ -> True; _ow -> False) - sortMapKeys _otherwise = Nothing + where + sortMapKeys :: Term -> Maybe Term + sortMapKeys (TMap keyValsToSort) = + if allSameType + then + Just $ TMap $ sortBy sortingFunction keyValsToSort + else Nothing + where + sortingFunction :: forall b1 b2. (Term, b1) -> (Term, b2) -> Ordering + sortingFunction (TInt a, _) (TInt b, _) = compare a b + sortingFunction (TInteger a, _) (TInteger b, _) = compare a b + sortingFunction (TBytes a, _) (TBytes b, _) = compare (B.length a) (B.length b) <> compare a b + sortingFunction (TString a, _) (TString b, _) = compare (T.length a) (T.length b) <> compare a b + sortingFunction _ _ = error "absurd - sortingFunction" -- We verify that all keys are of the same appropriate type before calling this function. + allSameType = any ($ keyValsToSort) [isTInt, isTInteger, isTBytes, isTString] + where + isTInt = all (\(k, _) -> case k of TInt _ -> True; _ow -> False) + isTInteger = all (\(k, _) -> case k of TInteger _ -> True; _ow -> False) + isTBytes = all (\(k, _) -> case k of TBytes _ -> True; _ow -> False) + isTString = all (\(k, _) -> case k of TString _ -> True; _ow -> False) + sortMapKeys _otherwise = Nothing - makeTermsDefinite :: Term -> Maybe Term - makeTermsDefinite (TBytesI b) = Just $ TBytes $ LBS.toStrict b - makeTermsDefinite (TStringI s) = Just $ TString $ LT.toStrict s - makeTermsDefinite (TListI l) = Just $ TList l - makeTermsDefinite (TMapI keyVals) = Just $ TMap keyVals - makeTermsDefinite _otherwise = Nothing + makeTermsDefinite :: Term -> Maybe Term + makeTermsDefinite (TBytesI b) = Just $ TBytes $ LBS.toStrict b + makeTermsDefinite (TStringI s) = Just $ TString $ LT.toStrict s + makeTermsDefinite (TListI l) = Just $ TList l + makeTermsDefinite (TMapI keyVals) = Just $ TMap keyVals + makeTermsDefinite _otherwise = Nothing -- | This `GYTxBody` doesn't represent @transaction_body@ as mentioned in [CDDL](https://github.com/input-output-hk/cardano-ledger/blob/master/eras/babbage/test-suite/cddl-files/babbage.cddl) specification, it's API's internal type to represent transaction without signing key witnesses. However `GYTx` does represent `transaction` as defined in specification. We therefore obtain `GYTx` and work with it. Here we need an invariant, which is if we receive our simplified `GYTx` transaction, then obtaining `GYTxBody` via `getTxBody` and obtaining `GYTx` back via `unsignedTx` should have the same serialisation for the modifications to CBOR encoding we do here. simplifyGYTxBodyCbor :: GYTxBody -> Either CborSimplificationError GYTxBody diff --git a/src/GeniusYield/Transaction/CoinSelection.hs b/src/GeniusYield/Transaction/CoinSelection.hs index f22b19aa..42980bf0 100644 --- a/src/GeniusYield/Transaction/CoinSelection.hs +++ b/src/GeniusYield/Transaction/CoinSelection.hs @@ -120,7 +120,7 @@ a positive amount of ada. -} selectInputs :: forall m v. - (MonadRandom m) => + MonadRandom m => GYCoinSelectionEnv v -> GYCoinSelectionStrategy -> ExceptT GYBalancingError m ([GYTxInDetailed v], [GYTxOut v]) @@ -167,17 +167,17 @@ selectInputs | not $ isEmptyValue tokenChange ] pure (additionalInputForReplayProtectionAsList <> addIns, changeOuts) - where - missing :: GYValue -> Map GYAssetClass Natural - missing v = foldl' f Map.empty $ valueToList v - where - f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural - f m (ac, n) - | n <= 0 = m - | otherwise = Map.insert ac (fromIntegral n) m - - removeAda :: GYValue -> GYValue - removeAda = snd . valueSplitAda + where + missing :: GYValue -> Map GYAssetClass Natural + missing v = foldl' f Map.empty $ valueToList v + where + f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural + f m (ac, n) + | n <= 0 = m + | otherwise = Map.insert ac (fromIntegral n) m + + removeAda :: GYValue -> GYValue + removeAda = snd . valueSplitAda selectInputs GYCoinSelectionEnv { existingInputs @@ -217,48 +217,48 @@ selectInputs -- Set of additional inputs chosen by the balancer that should be added to the transaction. addIns = foldl' foldHelper [] inputsSelected pure (addIns, changeOuts) - where - selectionConstraints = - CBalance.SelectionConstraints - { tokenBundleSizeAssessor = - tokenBundleSizeAssessor $ - CWallet.TxSize maxValueSize - , computeMinimumAdaQuantity = \addr tkMap -> do - -- This function is ran for generated change outputs which do not have datum & reference script. - -- This first parameter can actually be ignored as it will always be @toCWalletAddress changeAddr@. - CWallet.Coin $ - minimumUTxOF - GYTxOut - { gyTxOutAddress = fromCWalletAddress addr - , gyTxOutValue = fromTokenMap tkMap - , gyTxOutDatum = Nothing - , gyTxOutRefS = Nothing - } - , {- This field essentially takes care of tx fees. - - For simplicity, we simply use the extraLovelace parameter. - -} - computeMinimumCost = const $ CWallet.Coin extraLovelace - , maximumOutputAdaQuantity = CWallet.txOutMaxCoin - , maximumOutputTokenQuantity = CWallet.txOutMaxTokenQuantity - , maximumLengthChangeAddress = toCWalletAddress changeAddr -- Since our change address is fixed. - , nullAddress = CWallet.Address "" - } - selectionParams = - CBalance.SelectionParams - { assetsToMint = toTokenMap mintedVal - , assetsToBurn = toTokenMap burnedVal - , extraCoinSource = CWallet.Coin adaSource - , extraCoinSink = CWallet.Coin adaSink - , outputsToCover = map (bimap toCWalletAddress toTokenBundle) requiredOutputs - , utxoAvailable = CWallet.fromIndexPair (ownUtxosIndex, existingInpsIndex) -- `fromIndexPair` would actually make first element to be @ownUtxosIndex `UTxOIndex.difference` existingInpsIndex@. - , selectionStrategy = case cstrat of - GYRandomImproveMultiAsset -> CBalance.SelectionStrategyOptimal - _ -> CBalance.SelectionStrategyMinimal - } - (mintedVal, burnedVal) = valueSplitSign mintValue - ownUtxosIndex = utxosToUtxoIndex ownUtxos - existingInpsIndex = txInDetailedToUtxoIndex existingInputs + where + selectionConstraints = + CBalance.SelectionConstraints + { tokenBundleSizeAssessor = + tokenBundleSizeAssessor $ + CWallet.TxSize maxValueSize + , computeMinimumAdaQuantity = \addr tkMap -> do + -- This function is ran for generated change outputs which do not have datum & reference script. + -- This first parameter can actually be ignored as it will always be @toCWalletAddress changeAddr@. + CWallet.Coin $ + minimumUTxOF + GYTxOut + { gyTxOutAddress = fromCWalletAddress addr + , gyTxOutValue = fromTokenMap tkMap + , gyTxOutDatum = Nothing + , gyTxOutRefS = Nothing + } + , {- This field essentially takes care of tx fees. + + For simplicity, we simply use the extraLovelace parameter. + -} + computeMinimumCost = const $ CWallet.Coin extraLovelace + , maximumOutputAdaQuantity = CWallet.txOutMaxCoin + , maximumOutputTokenQuantity = CWallet.txOutMaxTokenQuantity + , maximumLengthChangeAddress = toCWalletAddress changeAddr -- Since our change address is fixed. + , nullAddress = CWallet.Address "" + } + selectionParams = + CBalance.SelectionParams + { assetsToMint = toTokenMap mintedVal + , assetsToBurn = toTokenMap burnedVal + , extraCoinSource = CWallet.Coin adaSource + , extraCoinSink = CWallet.Coin adaSink + , outputsToCover = map (bimap toCWalletAddress toTokenBundle) requiredOutputs + , utxoAvailable = CWallet.fromIndexPair (ownUtxosIndex, existingInpsIndex) -- `fromIndexPair` would actually make first element to be @ownUtxosIndex `UTxOIndex.difference` existingInpsIndex@. + , selectionStrategy = case cstrat of + GYRandomImproveMultiAsset -> CBalance.SelectionStrategyOptimal + _ -> CBalance.SelectionStrategyMinimal + } + (mintedVal, burnedVal) = valueSplitSign mintValue + ownUtxosIndex = utxosToUtxoIndex ownUtxos + existingInpsIndex = txInDetailedToUtxoIndex existingInputs computeTokenBundleSerializedLengthBytes :: CTokenBundle.TokenBundle -> CWallet.TxSize computeTokenBundleSerializedLengthBytes = @@ -268,9 +268,9 @@ computeTokenBundleSerializedLengthBytes = . CBOR.serialize' (eraProtVerHigh @Conway) . Api.S.toMaryValue . toCardanoValue - where - safeCast :: Int -> Natural - safeCast = fromIntegral + where + safeCast :: Int -> Natural + safeCast = fromIntegral selectInputsLegacy :: -- | Set of own utxos to select additional inputs from. @@ -281,39 +281,39 @@ selectInputsLegacy :: [GYTxInDetailed v] -> Either GYBalancingError ([GYTxInDetailed v], GYValue) selectInputsLegacy ownUtxos targetOut existingIns = go targetOut [] mempty $ utxosToList ownUtxos - where - inRefs = map (gyTxInTxOutRef . gyTxInDet) existingIns - ownValueMap :: Map GYTxOutRef GYValue - ownValueMap = mapUTxOs utxoValue ownUtxos - - go :: Map GYAssetClass Natural -> [GYTxInDetailed v] -> GYValue -> [GYUTxO] -> Either GYBalancingError ([GYTxInDetailed v], GYValue) - go m addIns addVal _ - | Map.null m = Right (addIns, addVal) - go m _ _ [] = Left $ GYBalancingErrorInsufficientFunds $ valueFromList [(ac, toInteger n) | (ac, n) <- Map.toList m] - go m addIns addVal (utxo : ys) - | utxoRef utxo `elem` inRefs = go m addIns addVal ys - | otherwise = - let v = ownValueMap Map.! utxoRef utxo - m' = foldl' f m $ valueToList v - where - f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural - f m'' (ac, n) = - let - o = fromIntegral n - in - case Map.lookup ac m'' of - Nothing -> m'' - Just n' - | n' <= o -> Map.delete ac m'' - | otherwise -> Map.insert ac (n' - o) m'' - in if m' == m - then go m addIns addVal ys - else - go - m' - (utxoAsPubKeyInp utxo : addIns) - (addVal <> v) - ys + where + inRefs = map (gyTxInTxOutRef . gyTxInDet) existingIns + ownValueMap :: Map GYTxOutRef GYValue + ownValueMap = mapUTxOs utxoValue ownUtxos + + go :: Map GYAssetClass Natural -> [GYTxInDetailed v] -> GYValue -> [GYUTxO] -> Either GYBalancingError ([GYTxInDetailed v], GYValue) + go m addIns addVal _ + | Map.null m = Right (addIns, addVal) + go m _ _ [] = Left $ GYBalancingErrorInsufficientFunds $ valueFromList [(ac, toInteger n) | (ac, n) <- Map.toList m] + go m addIns addVal (utxo : ys) + | utxoRef utxo `elem` inRefs = go m addIns addVal ys + | otherwise = + let v = ownValueMap Map.! utxoRef utxo + m' = foldl' f m $ valueToList v + where + f :: Map GYAssetClass Natural -> (GYAssetClass, Integer) -> Map GYAssetClass Natural + f m'' (ac, n) = + let + o = fromIntegral n + in + case Map.lookup ac m'' of + Nothing -> m'' + Just n' + | n' <= o -> Map.delete ac m'' + | otherwise -> Map.insert ac (n' - o) m'' + in if m' == m + then go m addIns addVal ys + else + go + m' + (utxoAsPubKeyInp utxo : addIns) + (addVal <> v) + ys ------------------------------------------------------------------------------- -- Utilities @@ -332,33 +332,33 @@ utxoAsPubKeyInp GYUTxO {utxoRef, utxoAddress, utxoValue, utxoOutDatum, utxoRefSc tokenBundleSizeAssessor :: CWallet.TxSize -> CWallet.TokenBundleSizeAssessor tokenBundleSizeAssessor maxSize = CWallet.TokenBundleSizeAssessor {..} - where - assessTokenBundleSize tb - | serializedLengthBytes <= maxSize = - CWallet.TokenBundleSizeWithinLimit - | otherwise = - CWallet.TokenBundleSizeExceedsLimit - where - serializedLengthBytes :: CWallet.TxSize - serializedLengthBytes = computeTokenBundleSerializedLengthBytes tb + where + assessTokenBundleSize tb + | serializedLengthBytes <= maxSize = + CWallet.TokenBundleSizeWithinLimit + | otherwise = + CWallet.TokenBundleSizeExceedsLimit + where + serializedLengthBytes :: CWallet.TxSize + serializedLengthBytes = computeTokenBundleSerializedLengthBytes tb toCardanoValue :: CTokenBundle.TokenBundle -> Api.S.Value toCardanoValue tb = Api.S.valueFromList $ (Api.S.AdaAssetId, coinToQuantity coin) : map (bimap toCardanoAssetId toQuantity) bundle - where - (coin, bundle) = CTokenBundle.toFlatList tb - toCardanoAssetId (CTokenBundle.AssetId pid name) = - Api.S.AssetId (toCardanoPolicyId pid) (toCardanoAssetName name) + where + (coin, bundle) = CTokenBundle.toFlatList tb + toCardanoAssetId (CTokenBundle.AssetId pid name) = + Api.S.AssetId (toCardanoPolicyId pid) (toCardanoAssetName name) - toCardanoAssetName :: CWallet.AssetName -> Api.S.AssetName - toCardanoAssetName (CWallet.UnsafeAssetName tn) = - either (\e -> error $ "toCardanoValue: unable to deserialise, error: " <> show e) id $ - Api.S.deserialiseFromRawBytes Api.S.AsAssetName tn + toCardanoAssetName :: CWallet.AssetName -> Api.S.AssetName + toCardanoAssetName (CWallet.UnsafeAssetName tn) = + either (\e -> error $ "toCardanoValue: unable to deserialise, error: " <> show e) id $ + Api.S.deserialiseFromRawBytes Api.S.AsAssetName tn - coinToQuantity = fromIntegral . CWallet.unCoin - toQuantity = fromIntegral . CWallet.unTokenQuantity + coinToQuantity = fromIntegral . CWallet.unCoin + toQuantity = fromIntegral . CWallet.unTokenQuantity toCardanoPolicyId :: CWallet.TokenPolicyId -> Api.S.PolicyId toCardanoPolicyId (CWallet.UnsafeTokenPolicyId (CWallet.Hash pid)) = @@ -381,24 +381,24 @@ fromTokenMap = toWalletAssetId :: GYAssetClass -> CTokenBundle.AssetId toWalletAssetId GYLovelace = error "toWalletAssetId: unable to deserialize" toWalletAssetId tkn@(GYToken policyId (GYTokenName tokenName)) = CTokenBundle.AssetId tokenPolicy nTokenName - where - tokenPolicy = either (customError tkn) id $ fromText $ mintingPolicyIdToText policyId - nTokenName = either (customError tkn) id $ CWallet.fromByteString tokenName - customError t = error $ printf "toWalletAssetId: unable to deserialize \n %s" t + where + tokenPolicy = either (customError tkn) id $ fromText $ mintingPolicyIdToText policyId + nTokenName = either (customError tkn) id $ CWallet.fromByteString tokenName + customError t = error $ printf "toWalletAssetId: unable to deserialize \n %s" t fromWalletAssetId :: CTokenBundle.AssetId -> GYAssetClass fromWalletAssetId (CTokenBundle.AssetId tokenPolicy nTokenName) = GYToken policyId tkName - where - policyId = fromRight customError $ mintingPolicyIdFromText $ toText tokenPolicy - tkName = fromMaybe customError $ tokenNameFromBS $ CWallet.unAssetName nTokenName - customError = error "fromWalletAssetId: unable to deserialize" + where + policyId = fromRight customError $ mintingPolicyIdFromText $ toText tokenPolicy + tkName = fromMaybe customError $ tokenNameFromBS $ CWallet.unAssetName nTokenName + customError = error "fromWalletAssetId: unable to deserialize" toTokenBundle :: GYValue -> CTokenBundle.TokenBundle toTokenBundle v = CTokenBundle.fromCoin coins `CTokenBundle.add` CTokenBundle.fromTokenMap (toTokenMap tokens) - where - coins = fromMaybe customError $ CWallet.fromIntegralMaybe lov - (lov, tokens) = valueSplitAda v - customError = error "toTokenBundle: unable to deserialize" + where + coins = fromMaybe customError $ CWallet.fromIntegralMaybe lov + (lov, tokens) = valueSplitAda v + customError = error "toTokenBundle: unable to deserialize" fromTokenBundle :: CTokenBundle.TokenBundle -> GYValue fromTokenBundle (CTokenBundle.TokenBundle (CWallet.Coin n) tkMap) = valueFromLovelace (toInteger n) <> fromTokenMap tkMap @@ -413,13 +413,13 @@ utxoToTuple , utxoAddress , utxoValue } = (wUtxo, bundle) - where - wUtxo = - CBalanceInternal.WalletUTxO - { txIn = toCWalletTxIn utxoRef - , address = toCWalletAddress utxoAddress - } - bundle = toTokenBundle utxoValue + where + wUtxo = + CBalanceInternal.WalletUTxO + { txIn = toCWalletTxIn utxoRef + , address = toCWalletAddress utxoAddress + } + bundle = toTokenBundle utxoValue txInDetailedToUtxoIndex :: [GYTxInDetailed v] -> CWallet.UTxOIndex CBalanceInternal.WalletUTxO txInDetailedToUtxoIndex = CWallet.fromSequence . map txInDetailedToTuple @@ -431,21 +431,21 @@ txInDetailedToTuple , gyTxInDetAddress , gyTxInDetValue } = (wUtxo, bundle) - where - wUtxo = - CBalanceInternal.WalletUTxO - { txIn = toCWalletTxIn $ gyTxInTxOutRef gyTxInDet - , address = toCWalletAddress gyTxInDetAddress - } - bundle = toTokenBundle gyTxInDetValue + where + wUtxo = + CBalanceInternal.WalletUTxO + { txIn = toCWalletTxIn $ gyTxInTxOutRef gyTxInDet + , address = toCWalletAddress gyTxInDetAddress + } + bundle = toTokenBundle gyTxInDetValue toCWalletAddress :: GYAddress -> CWallet.Address toCWalletAddress = CWallet.Address . Api.serialiseToRawBytes . addressToApi fromCWalletAddress :: CWallet.Address -> GYAddress fromCWalletAddress (CWallet.Address bs) = either customError addressFromApi $ Api.deserialiseFromRawBytes Api.AsAddressAny bs - where - customError e = error $ "fromCWalletAddress: unable to deserialize, error: " <> show e + where + customError e = error $ "fromCWalletAddress: unable to deserialize, error: " <> show e toCWalletTxIn :: GYTxOutRef -> CWallet.TxIn toCWalletTxIn ref = @@ -453,16 +453,16 @@ toCWalletTxIn ref = { inputId = nTxId , inputIx = fromIntegral txIx } - where - (txId, txIx) = txOutRefToTuple ref - nTxId = either customError id $ fromText $ Text.pack $ show txId - customError = error "toCWalletTxIn: unable to deserialise" + where + (txId, txIx) = txOutRefToTuple ref + nTxId = either customError id $ fromText $ Text.pack $ show txId + customError = error "toCWalletTxIn: unable to deserialise" fromCWalletTxIn :: CWallet.TxIn -> GYTxOutRef fromCWalletTxIn CWallet.TxIn {inputId, inputIx} = txOutRefFromTuple (txId, fromIntegral inputIx) - where - txId = fromMaybe customError . txIdFromHex . Text.unpack $ toText inputId - customError = error "fromCWalletTxIn: unable to deserialise txId" + where + txId = fromMaybe customError . txIdFromHex . Text.unpack $ toText inputId + customError = error "fromCWalletTxIn: unable to deserialise txId" fromCWalletBalancingError :: CBalanceInternal.SelectionBalanceError ctx -> GYBalancingError fromCWalletBalancingError (CBalance.BalanceInsufficient (CBalance.BalanceInsufficientError _ _ delta)) = diff --git a/src/GeniusYield/Transaction/Common.hs b/src/GeniusYield/Transaction/Common.hs index d1b9c084..d4d16cca 100644 --- a/src/GeniusYield/Transaction/Common.hs +++ b/src/GeniusYield/Transaction/Common.hs @@ -120,7 +120,7 @@ data GYBuildTxError GYBuildTxNoSuitableCollateral | GYBuildTxCborSimplificationError !CborSimplificationError | GYBuildTxCollapseExtraOutError !Api.TxBodyError - deriving stock (Show) + deriving stock Show ------------------------------------------------------------------------------- -- Transaction Utilities @@ -134,17 +134,17 @@ minimumUTxO pp txOut = adjustTxOut :: (GYTxOut v -> Natural) -> GYTxOut v -> GYTxOut v adjustTxOut minimumUTxOF = helper - where - helper txOut = - let v = gyTxOutValue txOut - needed = minimumUTxOF txOut - contained = extractLovelace $ valueToApi v - in if needed <= contained - then txOut - else - let v' = valueFromLovelace (fromIntegral $ needed - contained) <> v - txOut' = txOut {gyTxOutValue = v'} - in helper txOut' + where + helper txOut = + let v = gyTxOutValue txOut + needed = minimumUTxOF txOut + contained = extractLovelace $ valueToApi v + in if needed <= contained + then txOut + else + let v' = valueFromLovelace (fromIntegral $ needed - contained) <> v + txOut' = txOut {gyTxOutValue = v'} + in helper txOut' extractLovelace :: Api.Value -> Natural extractLovelace v = case Api.selectLovelace v of Ledger.Coin n -> fromIntegral $ max 0 n diff --git a/src/GeniusYield/TxBuilder.hs b/src/GeniusYield/TxBuilder.hs index 129f70f2..3ec1f2d7 100644 --- a/src/GeniusYield/TxBuilder.hs +++ b/src/GeniusYield/TxBuilder.hs @@ -29,23 +29,23 @@ import GeniusYield.Imports import GeniusYield.Types -- | Query the balance at given address. -queryBalance :: (GYTxQueryMonad m) => GYAddress -> m GYValue +queryBalance :: GYTxQueryMonad m => GYAddress -> m GYValue queryBalance addr = foldMapUTxOs utxoValue <$> utxosAtAddress addr Nothing -- | Query the balances at given addresses. -queryBalances :: (GYTxQueryMonad m) => [GYAddress] -> m GYValue +queryBalances :: GYTxQueryMonad m => [GYAddress] -> m GYValue queryBalances addrs = foldMapUTxOs utxoValue <$> utxosAtAddresses addrs {- | Query the txoutrefs at given address with ADA-only values. Useful for finding a txoutref to be used as collateral. -} -getAdaOnlyUTxO :: (GYTxQueryMonad m) => GYAddress -> m [(GYTxOutRef, Natural)] +getAdaOnlyUTxO :: GYTxQueryMonad m => GYAddress -> m [(GYTxOutRef, Natural)] getAdaOnlyUTxO addr = adaOnlyUTxOPure <$> utxosAtAddress addr Nothing -- | Get a UTxO suitable for use as collateral. getCollateral' :: - (GYTxQueryMonad m) => + GYTxQueryMonad m => -- | The address where to look. GYAddress -> -- | The minimal amount of lovelace required as collateral. @@ -60,7 +60,7 @@ getCollateral' addr minCollateral = do -- | Get an UTxO suitable for use as collateral. getCollateral :: - (GYTxQueryMonad m) => + GYTxQueryMonad m => -- | The address where to look. GYAddress -> -- | The minimal amount of lovelace required as collateral. @@ -75,16 +75,16 @@ getCollateral addr minCollateral = do adaOnlyUTxOPure :: GYUTxOs -> [(GYTxOutRef, Natural)] adaOnlyUTxOPure = Map.toList . mapMaybeUTxOs (valueIsPositiveAda . utxoValue) - where - valueIsPositiveAda :: GYValue -> Maybe Natural - valueIsPositiveAda v = case valueSplitAda v of - (n, v') | n > 0, isEmptyValue v' -> Just (fromInteger n) - _ -> Nothing + where + valueIsPositiveAda :: GYValue -> Maybe Natural + valueIsPositiveAda v = case valueSplitAda v of + (n, v') | n > 0, isEmptyValue v' -> Just (fromInteger n) + _ -> Nothing {- | Calculate how much balance is the given transaction is moving to given pubkeyhash address(es). -} -getTxBalance :: (GYTxQueryMonad m) => GYPubKeyHash -> GYTx -> m GYValue +getTxBalance :: GYTxQueryMonad m => GYPubKeyHash -> GYTx -> m GYValue getTxBalance pkh tx = do let Api.TxBody content = Api.getTxBody $ txToApi tx ins = txOutRefFromApi . fst <$> Api.txIns content @@ -97,11 +97,11 @@ getTxBalance pkh tx = do utxos <- utxosAtTxOutRefs ins let inValue = foldMapUTxOs f utxos return $ outValue `valueMinus` inValue - where - isRelevantAddress :: GYAddress -> Bool - isRelevantAddress addr = Just pkh == addressToPubKeyHash addr + where + isRelevantAddress :: GYAddress -> Bool + isRelevantAddress addr = Just pkh == addressToPubKeyHash addr - f :: GYUTxO -> GYValue - f utxo - | isRelevantAddress $ utxoAddress utxo = utxoValue utxo - | otherwise = mempty + f :: GYUTxO -> GYValue + f utxo + | isRelevantAddress $ utxoAddress utxo = utxoValue utxo + | otherwise = mempty diff --git a/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index 9a53572b..ea7d3629 100644 --- a/src/GeniusYield/TxBuilder/Class.hs +++ b/src/GeniusYield/TxBuilder/Class.hs @@ -197,19 +197,19 @@ class (Default (TxBuilderStrategy m), GYTxSpecialQueryMonad m, GYTxUserQueryMona buildTxBodyChainingWithStrategy = buildTxBodyChainingWithStrategy' -- | 'buildTxBodyWithStrategy' with the default coin selection strategy. -buildTxBody :: forall v m. (GYTxBuilderMonad m) => GYTxSkeleton v -> m GYTxBody +buildTxBody :: forall v m. GYTxBuilderMonad m => GYTxSkeleton v -> m GYTxBody buildTxBody = buildTxBodyWithStrategy def -- | 'buildTxBodyParallelWithStrategy' with the default coin selection strategy. -buildTxBodyParallel :: forall v m. (GYTxBuilderMonad m) => [GYTxSkeleton v] -> m GYTxBuildResult +buildTxBodyParallel :: forall v m. GYTxBuilderMonad m => [GYTxSkeleton v] -> m GYTxBuildResult buildTxBodyParallel = buildTxBodyParallelWithStrategy def -- | 'buildTxBodyChainingWithStrategy' with the default coin selection strategy. -buildTxBodyChaining :: forall v m. (GYTxBuilderMonad m) => [GYTxSkeleton v] -> m GYTxBuildResult +buildTxBodyChaining :: forall v m. GYTxBuilderMonad m => [GYTxSkeleton v] -> m GYTxBuildResult buildTxBodyChaining = buildTxBodyChainingWithStrategy def -- | Class of monads for interacting with the blockchain using transactions. -class (GYTxBuilderMonad m) => GYTxMonad m where +class GYTxBuilderMonad m => GYTxMonad m where -- | Sign a transaction body with the user payment key to produce a transaction with witnesses. -- -- /Note:/ The key is not meant to be exposed to the monad, so it is only held @@ -244,10 +244,10 @@ class (GYTxBuilderMonad m) => GYTxMonad m where -- by the identified transaction. awaitTxConfirmed' :: GYAwaitTxParameters -> GYTxId -> m () -signTxBodyImpl :: (GYTxMonad m) => m GYPaymentSigningKey -> GYTxBody -> m GYTx +signTxBodyImpl :: GYTxMonad m => m GYPaymentSigningKey -> GYTxBody -> m GYTx signTxBodyImpl kM txBody = signGYTxBody txBody . (: []) <$> kM -signTxBodyWithStakeImpl :: (GYTxMonad m) => m (GYPaymentSigningKey, Maybe GYStakeSigningKey) -> GYTxBody -> m GYTx +signTxBodyWithStakeImpl :: GYTxMonad m => m (GYPaymentSigningKey, Maybe GYStakeSigningKey) -> GYTxBody -> m GYTx signTxBodyWithStakeImpl kM txBody = (\(pKey, sKey) -> signGYTxBody txBody $ GYSomeSigningKey pKey : maybeToList (GYSomeSigningKey <$> sKey)) <$> kM -- | Class of monads that can simulate a "game" between different users interacting with transactions. @@ -288,47 +288,47 @@ will be automatically inferred. -} -- | > waitUntilSlot_ = void . waitUntilSlot -waitUntilSlot_ :: (GYTxQueryMonad m) => GYSlot -> m () +waitUntilSlot_ :: GYTxQueryMonad m => GYSlot -> m () waitUntilSlot_ = void . waitUntilSlot -- | Wait until the chain tip has progressed by N slots. -waitNSlots :: (GYTxQueryMonad m) => Word64 -> m GYSlot +waitNSlots :: GYTxQueryMonad m => Word64 -> m GYSlot waitNSlots (slotFromWord64 -> n) = do -- FIXME: Does this need to be an absolute slot getter instead? currentSlot <- slotOfCurrentBlock waitUntilSlot . slotFromApi $ currentSlot `addSlots` n - where - addSlots = (+) `on` slotToApi + where + addSlots = (+) `on` slotToApi -- | > waitNSlots_ = void . waitNSlots -waitNSlots_ :: (GYTxQueryMonad m) => Word64 -> m () +waitNSlots_ :: GYTxQueryMonad m => Word64 -> m () waitNSlots_ = void . waitNSlots -- | > submitTx_ = void . submitTx -submitTx_ :: (GYTxMonad m) => GYTx -> m () +submitTx_ :: GYTxMonad m => GYTx -> m () submitTx_ = void . submitTx -- | > submitTxConfirmed_ = void . submitTxConfirmed -submitTxConfirmed_ :: (GYTxMonad m) => GYTx -> m () +submitTxConfirmed_ :: GYTxMonad m => GYTx -> m () submitTxConfirmed_ = void . submitTxConfirmed -- | 'submitTxConfirmed'' with default tx waiting parameters. -submitTxConfirmed :: (GYTxMonad m) => GYTx -> m GYTxId +submitTxConfirmed :: GYTxMonad m => GYTx -> m GYTxId submitTxConfirmed = submitTxConfirmed' def -- | > submitTxConfirmed'_ p = void . submitTxConfirmed' p -submitTxConfirmed'_ :: (GYTxMonad m) => GYAwaitTxParameters -> GYTx -> m () +submitTxConfirmed'_ :: GYTxMonad m => GYAwaitTxParameters -> GYTx -> m () submitTxConfirmed'_ awaitParams = void . submitTxConfirmed' awaitParams -- | Equivalent to a call to 'submitTx' and then a call to 'awaitTxConfirmed'' with submitted tx id. -submitTxConfirmed' :: (GYTxMonad m) => GYAwaitTxParameters -> GYTx -> m GYTxId +submitTxConfirmed' :: GYTxMonad m => GYAwaitTxParameters -> GYTx -> m GYTxId submitTxConfirmed' awaitParams tx = do txId <- submitTx tx awaitTxConfirmed' awaitParams txId pure txId -- | Wait for a _recently_ submitted transaction to be confirmed, with default waiting parameters. -awaitTxConfirmed :: (GYTxMonad m) => GYTxId -> m () +awaitTxConfirmed :: GYTxMonad m => GYTxId -> m () awaitTxConfirmed = awaitTxConfirmed' def -- | > submitTxBody_ t = void . submitTxBody t @@ -351,10 +351,10 @@ Equivalent to a call to 'signGYTxBody', followed by a call to 'submitTxConfirmed submitTxBodyConfirmed :: forall a m. (GYTxMonad m, ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> m GYTxId submitTxBodyConfirmed txBody = submitTxConfirmed . signGYTxBody txBody -signAndSubmitConfirmed_ :: (GYTxMonad m) => GYTxBody -> m () +signAndSubmitConfirmed_ :: GYTxMonad m => GYTxBody -> m () signAndSubmitConfirmed_ = void . signAndSubmitConfirmed -signAndSubmitConfirmed :: (GYTxMonad m) => GYTxBody -> m GYTxId +signAndSubmitConfirmed :: GYTxMonad m => GYTxBody -> m GYTxId signAndSubmitConfirmed txBody = signTxBody txBody >>= submitTxConfirmed ------------------------------------------------------------------------------- @@ -381,25 +381,25 @@ Since these wrapper data types are usage specific, and 'GYTxGameMonad' instances "overarching base" type, we do not provide these instances and users may define them if necessary. -} -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (RandT g m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (RandT g m) where type TxBuilderStrategy (RandT g m) = TxBuilderStrategy m buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x -instance (GYTxMonad m) => GYTxMonad (RandT g m) where +instance GYTxMonad m => GYTxMonad (RandT g m) where signTxBody = lift . signTxBody signTxBodyWithStake = lift . signTxBodyWithStake submitTx = lift . submitTx awaitTxConfirmed' p = lift . awaitTxConfirmed' p -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (ReaderT env m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (ReaderT env m) where type TxBuilderStrategy (ReaderT env m) = TxBuilderStrategy m buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x -instance (GYTxMonad m) => GYTxMonad (ReaderT env m) where +instance GYTxMonad m => GYTxMonad (ReaderT env m) where signTxBody = lift . signTxBody signTxBodyWithStake = lift . signTxBodyWithStake submitTx = lift . submitTx @@ -411,25 +411,25 @@ instance (GYTxMonad m) => GYTxMonad (ReaderT env m) where -- See: https://github.com/haskell-effectful/effectful/blob/master/transformers.md ------------------------------------------------------------------------------- -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (Strict.StateT s m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (Strict.StateT s m) where type TxBuilderStrategy (Strict.StateT s m) = TxBuilderStrategy m buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x -instance (GYTxMonad m) => GYTxMonad (Strict.StateT s m) where +instance GYTxMonad m => GYTxMonad (Strict.StateT s m) where signTxBody = lift . signTxBody signTxBodyWithStake = lift . signTxBodyWithStake submitTx = lift . submitTx awaitTxConfirmed' p = lift . awaitTxConfirmed' p -instance (GYTxBuilderMonad m) => GYTxBuilderMonad (Lazy.StateT s m) where +instance GYTxBuilderMonad m => GYTxBuilderMonad (Lazy.StateT s m) where type TxBuilderStrategy (Lazy.StateT s m) = TxBuilderStrategy m buildTxBodyWithStrategy x = lift . buildTxBodyWithStrategy x buildTxBodyParallelWithStrategy x = lift . buildTxBodyParallelWithStrategy x buildTxBodyChainingWithStrategy x = lift . buildTxBodyChainingWithStrategy x -instance (GYTxMonad m) => GYTxMonad (Lazy.StateT s m) where +instance GYTxMonad m => GYTxMonad (Lazy.StateT s m) where signTxBody = lift . signTxBody signTxBodyWithStake = lift . signTxBodyWithStake submitTx = lift . submitTx @@ -472,11 +472,11 @@ instance (GYTxMonad m, Monoid w) => GYTxMonad (Lazy.WriterT w m) where awaitTxConfirmed' p = lift . awaitTxConfirmed' p -- | A version of 'lookupDatum' that raises 'GYNoDatumForHash' if the datum is not found. -lookupDatum' :: (GYTxQueryMonad m) => GYDatumHash -> m GYDatum +lookupDatum' :: GYTxQueryMonad m => GYDatumHash -> m GYDatum lookupDatum' h = lookupDatum h >>= maybe (throwError . GYQueryDatumException $ GYNoDatumForHash h) pure -- | A version of 'utxoAtTxOutRef' that raises 'GYNoUtxoAtRef' if the utxo is not found. -utxoAtTxOutRef' :: (GYTxQueryMonad m) => GYTxOutRef -> m GYUTxO +utxoAtTxOutRef' :: GYTxQueryMonad m => GYTxOutRef -> m GYUTxO utxoAtTxOutRef' ref = utxoAtTxOutRef ref >>= maybe @@ -484,7 +484,7 @@ utxoAtTxOutRef' ref = pure -- | A version of 'utxoAtTxOutRefWithDatum' that raises 'GYNoUtxoAtRef' if the utxo is not found. -utxoAtTxOutRefWithDatum' :: (GYTxQueryMonad m) => GYTxOutRef -> m (GYUTxO, Maybe GYDatum) +utxoAtTxOutRefWithDatum' :: GYTxQueryMonad m => GYTxOutRef -> m (GYUTxO, Maybe GYDatum) utxoAtTxOutRefWithDatum' ref = utxoAtTxOutRefWithDatum ref >>= maybe @@ -492,7 +492,7 @@ utxoAtTxOutRefWithDatum' ref = pure -- | Returns some UTxO present in wallet which doesn't have reference script. -someUTxOWithoutRefScript :: (GYTxUserQueryMonad m) => m GYTxOutRef +someUTxOWithoutRefScript :: GYTxUserQueryMonad m => m GYTxOutRef someUTxOWithoutRefScript = do utxosToConsider <- utxosRemoveRefScripts <$> availableUTxOs addrs <- ownAddresses @@ -505,25 +505,25 @@ someUTxOWithoutRefScript = do ------------------------------------------------------------------------------- -- | Get the starting 'GYTime' of a 'GYSlot' in 'GYTxMonad'. -slotToBeginTime :: (GYTxQueryMonad f) => GYSlot -> f GYTime +slotToBeginTime :: GYTxQueryMonad f => GYSlot -> f GYTime slotToBeginTime x = flip slotToBeginTimePure x <$> slotConfig -- | Get the ending 'GYTime' of a 'GYSlot' (inclusive) in 'GYTxMonad'. -slotToEndTime :: (GYTxQueryMonad f) => GYSlot -> f GYTime +slotToEndTime :: GYTxQueryMonad f => GYSlot -> f GYTime slotToEndTime x = flip slotToEndTimePure x <$> slotConfig {- | Get the 'GYSlot' of a 'GYTime' in 'GYTxMonad'. Returns 'Nothing' if given time is before known system start. -} -enclosingSlotFromTime :: (GYTxQueryMonad f) => GYTime -> f (Maybe GYSlot) +enclosingSlotFromTime :: GYTxQueryMonad f => GYTime -> f (Maybe GYSlot) enclosingSlotFromTime x = flip enclosingSlotFromTimePure x <$> slotConfig {- | Partial version of 'enclosingSlotFromTime'. Raises 'GYTimeUnderflowException' if given time is before known system start. -} -enclosingSlotFromTime' :: (GYTxQueryMonad m) => GYTime -> m GYSlot +enclosingSlotFromTime' :: GYTxQueryMonad m => GYTime -> m GYSlot enclosingSlotFromTime' x = do sysStart <- gyscSystemStart <$> slotConfig enclosingSlotFromTime x >>= maybe (throwError $ GYTimeUnderflowException sysStart x) pure @@ -533,13 +533,13 @@ enclosingSlotFromTime' x = do ------------------------------------------------------------------------------- -- | Calculate script's address. -scriptAddress :: (GYTxQueryMonad m) => GYValidator v -> m GYAddress +scriptAddress :: GYTxQueryMonad m => GYValidator v -> m GYAddress scriptAddress v = do nid <- networkId return $ addressFromValidator nid v -- | Calculate script's address. -scriptAddress' :: (GYTxQueryMonad m) => GYValidatorHash -> m GYAddress +scriptAddress' :: GYTxQueryMonad m => GYValidatorHash -> m GYAddress scriptAddress' h = do nid <- networkId return $ addressFromValidatorHash nid h @@ -548,18 +548,18 @@ scriptAddress' h = do Explicitly returns an error rather than throwing it. -} -addressFromPlutusM :: (GYTxQueryMonad m) => Plutus.Address -> m (Either PlutusToCardanoError GYAddress) +addressFromPlutusM :: GYTxQueryMonad m => Plutus.Address -> m (Either PlutusToCardanoError GYAddress) addressFromPlutusM addr = flip addressFromPlutus addr <$> networkId -- | 'hush'ed version of 'addressFromPlutusM'. -addressFromPlutusHushedM :: (GYTxQueryMonad m) => Plutus.Address -> m (Maybe GYAddress) +addressFromPlutusHushedM :: GYTxQueryMonad m => Plutus.Address -> m (Maybe GYAddress) addressFromPlutusHushedM addr = fmap hush $ flip addressFromPlutus addr <$> networkId {- | Convert a 'Plutus.Address' to 'GYAddress' in 'GYTxMonad'. Throw 'GYConversionException' if conversion fails. -} -addressFromPlutus' :: (GYTxQueryMonad m) => Plutus.Address -> m GYAddress +addressFromPlutus' :: GYTxQueryMonad m => Plutus.Address -> m GYAddress addressFromPlutus' addr = do x <- addressFromPlutusM addr liftEither $ first (GYConversionException . GYLedgerToCardanoError) x @@ -568,7 +568,7 @@ addressFromPlutus' addr = do Throw 'GYConversionException' if address is not key-hash one. -} -addressToPubKeyHash' :: (MonadError GYTxMonadException m) => GYAddress -> m GYPubKeyHash +addressToPubKeyHash' :: MonadError GYTxMonadException m => GYAddress -> m GYPubKeyHash addressToPubKeyHash' addr = maybe (throwError . GYConversionException $ GYNotPubKeyAddress addr) @@ -586,7 +586,7 @@ addressToPubKeyHashIO addr = Throw 'GYConversionException' if address is not script-hash one. -} -addressToValidatorHash' :: (MonadError GYTxMonadException m) => GYAddress -> m GYValidatorHash +addressToValidatorHash' :: MonadError GYTxMonadException m => GYAddress -> m GYValidatorHash addressToValidatorHash' addr = maybe (throwError . GYConversionException $ GYNotPubKeyAddress addr) @@ -604,7 +604,7 @@ addressToValidatorHashIO addr = Throw 'GYConversionException' if conversion fails. -} -valueFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.Value -> m GYValue +valueFromPlutus' :: MonadError GYTxMonadException m => Plutus.Value -> m GYValue valueFromPlutus' val = either (throwError . GYConversionException . flip GYInvalidPlutusValue val) @@ -626,7 +626,7 @@ valueFromPlutusIO val = Throw 'GYConversionException' if conversion fails. -} -makeAssetClass' :: (MonadError GYTxMonadException m) => Text -> Text -> m GYAssetClass +makeAssetClass' :: MonadError GYTxMonadException m => Text -> Text -> m GYAssetClass makeAssetClass' a b = either (throwError . GYConversionException . GYInvalidAssetClass . Txt.pack) @@ -648,7 +648,7 @@ makeAssetClassIO a b = Throw 'GYConversionException' if conversion fails. -} -assetClassFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.AssetClass -> m GYAssetClass +assetClassFromPlutus' :: MonadError GYTxMonadException m => Plutus.AssetClass -> m GYAssetClass assetClassFromPlutus' x = either (throwError . GYConversionException . GYInvalidPlutusAsset) @@ -659,7 +659,7 @@ assetClassFromPlutus' x = Throw 'GYConversionException' if conversion fails. -} -tokenNameFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.TokenName -> m GYTokenName +tokenNameFromPlutus' :: MonadError GYTxMonadException m => Plutus.TokenName -> m GYTokenName tokenNameFromPlutus' x = maybe (throwError . GYConversionException . GYInvalidPlutusAsset $ GYTokenNameTooBig x) @@ -670,7 +670,7 @@ tokenNameFromPlutus' x = Throw 'GYConversionException' if conversion fails. -} -txOutRefFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.TxOutRef -> m GYTxOutRef +txOutRefFromPlutus' :: MonadError GYTxMonadException m => Plutus.TxOutRef -> m GYTxOutRef txOutRefFromPlutus' ref = either (throwError . GYConversionException . GYLedgerToCardanoError) @@ -681,7 +681,7 @@ txOutRefFromPlutus' ref = Throw 'GYConversionException' if conversion fails. -} -datumHashFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.DatumHash -> m GYDatumHash +datumHashFromPlutus' :: MonadError GYTxMonadException m => Plutus.DatumHash -> m GYDatumHash datumHashFromPlutus' dh = either (throwError . GYConversionException . GYLedgerToCardanoError) @@ -692,7 +692,7 @@ datumHashFromPlutus' dh = Throw 'GYConversionException' if conversion fails. -} -pubKeyHashFromPlutus' :: (MonadError GYTxMonadException m) => Plutus.PubKeyHash -> m GYPubKeyHash +pubKeyHashFromPlutus' :: MonadError GYTxMonadException m => Plutus.PubKeyHash -> m GYPubKeyHash pubKeyHashFromPlutus' pkh = either (throwError . GYConversionException . GYLedgerToCardanoError) @@ -703,7 +703,7 @@ pubKeyHashFromPlutus' pkh = Throw 'GYConversionException' if parsing fails. -} -addressFromText' :: (MonadError GYTxMonadException m) => Text -> m GYAddress +addressFromText' :: MonadError GYTxMonadException m => Text -> m GYAddress addressFromText' addr = maybe (throwError . GYConversionException $ GYInvalidAddressText addr) @@ -711,7 +711,7 @@ addressFromText' addr = (addressFromTextMaybe addr) -- | Advance 'GYSlot' forward in 'GYTxMonad'. If slot value overflows, throw 'GYSlotOverflowException'. -advanceSlot' :: (MonadError GYTxMonadException m) => GYSlot -> Natural -> m GYSlot +advanceSlot' :: MonadError GYTxMonadException m => GYSlot -> Natural -> m GYSlot advanceSlot' s t = maybe (throwError $ GYSlotOverflowException s t) @@ -722,11 +722,11 @@ utxosDatums :: forall m a. (GYTxQueryMonad m, Plutus.FromData a) => GYUTxOs -> m utxosDatums = witherUTxOs utxoDatumHushed -- | Pure variant of `utxosDatums`. -utxosDatumsPure :: (Plutus.FromData a) => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a) +utxosDatumsPure :: Plutus.FromData a => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a) utxosDatumsPure = Map.fromList . mapMaybe utxoDatumPureHushed -- | Like `utxosDatumsPure` but also returns original raw `GYDatum`. -utxosDatumsPureWithOriginalDatum :: (Plutus.FromData a) => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a, GYDatum) +utxosDatumsPureWithOriginalDatum :: Plutus.FromData a => [(GYUTxO, Maybe GYDatum)] -> Map GYTxOutRef (GYAddress, GYValue, a, GYDatum) utxosDatumsPureWithOriginalDatum = Map.fromList . mapMaybe utxoDatumPureHushedWithOriginalDatum utxoDatum :: (GYTxQueryMonad m, Plutus.FromData a) => GYUTxO -> m (Either GYQueryDatumError (GYAddress, GYValue, a)) @@ -738,25 +738,25 @@ utxoDatum utxo = case utxoOutDatum utxo of Nothing -> pure . Left $ GYNoDatumForHash h Just d -> datumToRes d GYOutDatumInline d -> datumToRes d - where - datumToRes x = case Plutus.fromBuiltinData $ datumToPlutus' x of - Nothing -> pure . Left $ GYInvalidDatum x - Just a -> pure $ Right (utxoAddress utxo, utxoValue utxo, a) + where + datumToRes x = case Plutus.fromBuiltinData $ datumToPlutus' x of + Nothing -> pure . Left $ GYInvalidDatum x + Just a -> pure $ Right (utxoAddress utxo, utxoValue utxo, a) -- | Obtain original datum representation of an UTxO. -utxoDatumPureHushed :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a)) +utxoDatumPureHushed :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a)) utxoDatumPureHushed (_utxo, Nothing) = Nothing utxoDatumPureHushed (GYUTxO {..}, Just d) = datumToPlutus' d & Plutus.fromBuiltinData <&> \d' -> (utxoRef, (utxoAddress, utxoValue, d')) -- | Like `utxoDatumPureHushed` but also returns original raw `GYDatum`. -utxoDatumPureHushedWithOriginalDatum :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a, GYDatum)) +utxoDatumPureHushedWithOriginalDatum :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Maybe (GYTxOutRef, (GYAddress, GYValue, a, GYDatum)) utxoDatumPureHushedWithOriginalDatum (_utxo, Nothing) = Nothing utxoDatumPureHushedWithOriginalDatum (GYUTxO {..}, Just d) = datumToPlutus' d & Plutus.fromBuiltinData <&> \d' -> (utxoRef, (utxoAddress, utxoValue, d', d)) -- | Pure variant of `utxoDatum`. -utxoDatumPure :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a) +utxoDatumPure :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a) utxoDatumPure (utxo, Nothing) = Left $ GYNoDatumHash utxo utxoDatumPure (GYUTxO {..}, Just d) = case Plutus.fromBuiltinData $ datumToPlutus' d of @@ -764,7 +764,7 @@ utxoDatumPure (GYUTxO {..}, Just d) = Just a -> Right (utxoAddress, utxoValue, a) -- | Like `utxoDatumPure` but also returns original raw datum. -utxoDatumPureWithOriginalDatum :: (Plutus.FromData a) => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a, GYDatum) +utxoDatumPureWithOriginalDatum :: Plutus.FromData a => (GYUTxO, Maybe GYDatum) -> Either GYQueryDatumError (GYAddress, GYValue, a, GYDatum) utxoDatumPureWithOriginalDatum (utxo, Nothing) = Left $ GYNoDatumHash utxo utxoDatumPureWithOriginalDatum (GYUTxO {..}, Just d) = case Plutus.fromBuiltinData $ datumToPlutus' d of @@ -795,7 +795,7 @@ utxoDatumHushed = fmap hush . utxoDatum mustHaveInput :: GYTxIn v -> GYTxSkeleton v mustHaveInput i = emptyGYTxSkeleton {gytxIns = [i]} -mustHaveRefInput :: (VersionIsGreaterOrEqual v 'PlutusV2) => GYTxOutRef -> GYTxSkeleton v +mustHaveRefInput :: VersionIsGreaterOrEqual v 'PlutusV2 => GYTxOutRef -> GYTxSkeleton v mustHaveRefInput i = emptyGYTxSkeleton {gytxRefIns = GYTxSkeletonRefIns (Set.singleton i)} mustHaveOutput :: GYTxOut v -> GYTxSkeleton v @@ -817,7 +817,7 @@ mustHaveWithdrawal w = mempty {gytxWdrls = [w]} mustHaveCertificate :: GYTxCert v -> GYTxSkeleton v mustHaveCertificate c = mempty {gytxCerts = [c]} -mustBeSignedBy :: (CanSignTx a) => a -> GYTxSkeleton v +mustBeSignedBy :: CanSignTx a => a -> GYTxSkeleton v mustBeSignedBy pkh = emptyGYTxSkeleton {gytxSigs = Set.singleton $ toPubKeyHash pkh} isInvalidBefore :: GYSlot -> GYTxSkeleton v @@ -835,14 +835,14 @@ gyLogError' ns = withFrozenCallStack $ logMsg ns GYError -- | Given a skeleton, returns a list of reference to reference script UTxOs which are present as witness. skeletonToRefScriptsORefs :: GYTxSkeleton v -> [GYTxOutRef] skeletonToRefScriptsORefs GYTxSkeleton {gytxIns} = go gytxIns [] - where - go :: [GYTxIn v] -> [GYTxOutRef] -> [GYTxOutRef] - go [] acc = acc - go (gytxIn : rest) acc = case gyTxInWitness gytxIn of - GYTxInWitnessScript gyInScript _ _ -> case gyInScript of - GYInReference oRef _ -> go rest (oRef : acc) - _anyOtherMatch -> go rest acc + where + go :: [GYTxIn v] -> [GYTxOutRef] -> [GYTxOutRef] + go [] acc = acc + go (gytxIn : rest) acc = case gyTxInWitness gytxIn of + GYTxInWitnessScript gyInScript _ _ -> case gyInScript of + GYInReference oRef _ -> go rest (oRef : acc) _anyOtherMatch -> go rest acc + _anyOtherMatch -> go rest acc -- | Log the time a particular monad action took. wrapReqWithTimeLog :: (GYTxQueryMonad m, MonadIO m) => String -> m a -> m a @@ -960,22 +960,22 @@ buildTxBodyCore ownUtxoUpdateF cstrat skeletons = do case e of Left err -> throwError $ GYBuildTxException err Right res -> pure res - where - logSkeletons :: [GYTxSkeleton v] -> m () - logSkeletons = mapM_ (logMsg "buildTxBody" GYDebug . show) + where + logSkeletons :: [GYTxSkeleton v] -> m () + logSkeletons = mapM_ (logMsg "buildTxBody" GYDebug . show) -- | Update own utxo set by removing any utxos used up in the given tx. updateOwnUtxosParallel :: GYTxBody -> GYUTxOs -> GYUTxOs updateOwnUtxosParallel txBody = utxosRemoveTxOutRefs (Set.fromList txIns) - where - txIns = txBodyTxIns txBody + where + txIns = txBodyTxIns txBody {- | Update own utxo set by removing any utxos used up in the given tx, **and** adding newly created utxos addressed to own wallet. -} updateOwnUtxosChaining :: Set GYAddress -> GYTxBody -> GYUTxOs -> GYUTxOs updateOwnUtxosChaining ownAddrs txBody utxos = utxosRemoveTxOutRefs (Set.fromList txIns) utxos <> txOutsOwn - where - txIns = txBodyTxIns txBody - txOuts = txBodyUTxOs txBody - txOutsOwn = filterUTxOs (\GYUTxO {utxoAddress} -> utxoAddress `Set.member` ownAddrs) txOuts + where + txIns = txBodyTxIns txBody + txOuts = txBodyUTxOs txBody + txOutsOwn = filterUTxOs (\GYUTxO {utxoAddress} -> utxoAddress `Set.member` ownAddrs) txOuts diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index 22d19a7e..b997c7c7 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -71,10 +71,10 @@ data GYTxSkeleton (v :: PlutusVersion) = GYTxSkeleton , gytxInvalidAfter :: !(Maybe GYSlot) , gytxMetadata :: !(Maybe GYTxMetadata) } - deriving (Show) + deriving Show data GYTxSkeletonRefIns :: PlutusVersion -> Type where - GYTxSkeletonRefIns :: (VersionIsGreaterOrEqual v 'PlutusV2) => !(Set GYTxOutRef) -> GYTxSkeletonRefIns v + GYTxSkeletonRefIns :: VersionIsGreaterOrEqual v 'PlutusV2 => !(Set GYTxOutRef) -> GYTxSkeletonRefIns v GYTxSkeletonNoRefIns :: GYTxSkeletonRefIns v deriving instance Show (GYTxSkeletonRefIns v) @@ -122,23 +122,23 @@ instance Semigroup (GYTxSkeleton v) where , gytxInvalidAfter = combineInvalidAfter (gytxInvalidAfter x) (gytxInvalidAfter y) , gytxMetadata = gytxMetadata x <> gytxMetadata y } - where - -- we keep only one input per utxo to spend - combineIns u v = nubBy ((==) `on` gyTxInTxOutRef) (u ++ v) - -- we cannot combine redeemers, so we just pick first. - combineMint = Map.unionWith (\(amt, r) (amt', _r) -> (Map.unionWith (+) amt amt', r)) - -- we keep only one withdrawal per stake address - combineWdrls u v = nubBy ((==) `on` gyTxWdrlStakeAddress) (u ++ v) - - combineInvalidBefore :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot - combineInvalidBefore m Nothing = m - combineInvalidBefore Nothing n = n - combineInvalidBefore (Just s) (Just t) = Just (max s t) - - combineInvalidAfter :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot - combineInvalidAfter m Nothing = m - combineInvalidAfter Nothing n = n - combineInvalidAfter (Just s) (Just t) = Just (min s t) + where + -- we keep only one input per utxo to spend + combineIns u v = nubBy ((==) `on` gyTxInTxOutRef) (u ++ v) + -- we cannot combine redeemers, so we just pick first. + combineMint = Map.unionWith (\(amt, r) (amt', _r) -> (Map.unionWith (+) amt amt', r)) + -- we keep only one withdrawal per stake address + combineWdrls u v = nubBy ((==) `on` gyTxWdrlStakeAddress) (u ++ v) + + combineInvalidBefore :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot + combineInvalidBefore m Nothing = m + combineInvalidBefore Nothing n = n + combineInvalidBefore (Just s) (Just t) = Just (max s t) + + combineInvalidAfter :: Maybe GYSlot -> Maybe GYSlot -> Maybe GYSlot + combineInvalidAfter m Nothing = m + combineInvalidAfter Nothing n = n + combineInvalidAfter (Just s) (Just t) = Just (min s t) instance Monoid (GYTxSkeleton v) where mempty = emptyGYTxSkeleton @@ -238,13 +238,13 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk pure $ GYTxInDetailed gyTxIn utxoAddress utxoValue utxoOutDatum utxoRefScript else throwError $ GYDatumMismatch utxoOutDatum gyTxIn - where - checkDatumMatch _ GYTxInWitnessKey = True - checkDatumMatch _ GYTxInWitnessSimpleScript {} = True - checkDatumMatch ud (GYTxInWitnessScript _ wd _) = case ud of - GYOutDatumNone -> False - GYOutDatumHash h -> h == hashDatum wd - GYOutDatumInline uid -> uid == wd + where + checkDatumMatch _ GYTxInWitnessKey = True + checkDatumMatch _ GYTxInWitnessSimpleScript {} = True + checkDatumMatch ud (GYTxInWitnessScript _ wd _) = case ud of + GYOutDatumNone -> False + GYOutDatumHash h -> h == hashDatum wd + GYOutDatumInline uid -> uid == wd -- This operation is `O(n)` where `n` denotes the number of UTxOs in `ownUtxos'`. let totalRefScriptSize = foldl' (\acc GYUTxO {..} -> acc + maybe 0 scriptSize utxoRefScript) 0 $ refInsUtxos <> map utxoFromTxInDetailed gyTxInsDetailed @@ -298,31 +298,31 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk -- Continue with an updated accumulator (set of built results). go ownUTxos'' (updateBuildRes (Right body) acc) rest go ownUtxos GYTxBuildNoInputs skeletons - where - {- This function updates 'GYTxBuildResult' based on a build outcome - - In case of insufficient funds failure ('Left' argument): - We return either 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess' - Depending on whether or not any previous transactions were built succesfully. - - In case of successful build: - We save the newly built tx body into the existing ones (if any) - - It's impossible for the second argument to ever be 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess', as - the outer function 'go' (see above) always exits as soon as the accumulator updates to one of these. - -} - updateBuildRes (Left v) GYTxBuildNoInputs = GYTxBuildFailure v - updateBuildRes (Left v) (GYTxBuildSuccess ne) = GYTxBuildPartialSuccess v ne - updateBuildRes (Right x) GYTxBuildNoInputs = GYTxBuildSuccess (x :| []) - updateBuildRes (Right x) (GYTxBuildSuccess ne) = GYTxBuildSuccess (NE.cons x ne) - updateBuildRes _ _ = error "buildTxCore.flippedFoldM.updateBuildRes: absurd" - - -- TODO: Move to @Data.Sequence.NonEmpty@? - -- \| To reverse the final non-empty list built. - reverseResult :: GYTxBuildResult -> GYTxBuildResult - reverseResult (GYTxBuildSuccess ne) = GYTxBuildSuccess $ NE.reverse ne - reverseResult (GYTxBuildPartialSuccess v ne) = GYTxBuildPartialSuccess v $ NE.reverse ne - reverseResult anyOther = anyOther + where + {- This function updates 'GYTxBuildResult' based on a build outcome + + In case of insufficient funds failure ('Left' argument): + We return either 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess' + Depending on whether or not any previous transactions were built succesfully. + + In case of successful build: + We save the newly built tx body into the existing ones (if any) + + It's impossible for the second argument to ever be 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess', as + the outer function 'go' (see above) always exits as soon as the accumulator updates to one of these. + -} + updateBuildRes (Left v) GYTxBuildNoInputs = GYTxBuildFailure v + updateBuildRes (Left v) (GYTxBuildSuccess ne) = GYTxBuildPartialSuccess v ne + updateBuildRes (Right x) GYTxBuildNoInputs = GYTxBuildSuccess (x :| []) + updateBuildRes (Right x) (GYTxBuildSuccess ne) = GYTxBuildSuccess (NE.cons x ne) + updateBuildRes _ _ = error "buildTxCore.flippedFoldM.updateBuildRes: absurd" + + -- TODO: Move to @Data.Sequence.NonEmpty@? + -- \| To reverse the final non-empty list built. + reverseResult :: GYTxBuildResult -> GYTxBuildResult + reverseResult (GYTxBuildSuccess ne) = GYTxBuildSuccess $ NE.reverse ne + reverseResult (GYTxBuildPartialSuccess v ne) = GYTxBuildPartialSuccess v $ NE.reverse ne + reverseResult anyOther = anyOther collateralLovelace :: Integer collateralLovelace = 5_000_000 diff --git a/src/GeniusYield/TxBuilder/Errors.hs b/src/GeniusYield/TxBuilder/Errors.hs index 2055774c..4a085d48 100644 --- a/src/GeniusYield/TxBuilder/Errors.hs +++ b/src/GeniusYield/TxBuilder/Errors.hs @@ -58,7 +58,7 @@ data GYConversionError GYInvalidAssetClass !Text | -- | Errors caused by "GeniusYield.Types.Slot.slotFromInteger" resulting in 'Nothing'. GYInvalidSlot !Integer - deriving stock (Show) + deriving stock Show -- | 'GYQueryUTxOError's may be raised during utxo related queries. data GYQueryUTxOError @@ -66,7 +66,7 @@ data GYQueryUTxOError GYNoUtxosAtAddress ![GYAddress] | -- | No UTxO exists at given ref. GYNoUtxoAtRef !GYTxOutRef - deriving stock (Show) + deriving stock Show -- | 'GYQueryDatumError' may be raised during fetching and parsing datums. data GYQueryDatumError @@ -76,7 +76,7 @@ data GYQueryDatumError GYInvalidDatum !GYDatum | -- | No datum hash at utxo. GYNoDatumHash !GYUTxO - deriving stock (Show) + deriving stock Show {- | Exceptions raised within the 'GeniusYield.TxBuilder.Class.GYTxMonad' computation. diff --git a/src/GeniusYield/TxBuilder/IO/Builder.hs b/src/GeniusYield/TxBuilder/IO/Builder.hs index cfa76671..f6044a0e 100644 --- a/src/GeniusYield/TxBuilder/IO/Builder.hs +++ b/src/GeniusYield/TxBuilder/IO/Builder.hs @@ -49,7 +49,7 @@ newtype GYTxBuilderMonadIO a = GYTxBuilderMonadIO (GYTxBuilderIOEnv -> GYTxQuery , GYTxSpecialQueryMonad ) via ReaderT GYTxBuilderIOEnv GYTxQueryMonadIO - deriving anyclass (GYTxBuilderMonad) + deriving anyclass GYTxBuilderMonad data GYTxBuilderIOEnv = GYTxBuilderIOEnv { envAddrs :: ![GYAddress] @@ -82,9 +82,9 @@ instance GYTxUserQueryMonad GYTxBuilderMonadIO where usedSomeUTxOs <- getUsedSomeUTxOs utxos <- utxosAtAddresses addrs return $ utxosRemoveTxOutRefs (maybe usedSomeUTxOs ((`Set.insert` usedSomeUTxOs) . utxoRef) mCollateral) utxos - where - getCollateral = asks envCollateral - getUsedSomeUTxOs = asks envUsedSomeUTxOs + where + getCollateral = asks envCollateral + getUsedSomeUTxOs = asks envUsedSomeUTxOs someUTxO lang = do addrs <- ownAddresses @@ -96,11 +96,11 @@ instance GYTxUserQueryMonad GYTxBuilderMonadIO where case find utxoTranslatableToV1 $ utxosToList utxosToConsider of Just u -> return $ utxoRef u Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Better error message here? - where - ifNotV1 utxosToConsider addrs = - case someTxOutRef utxosToConsider of - Just (oref, _) -> return oref - Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs + where + ifNotV1 utxosToConsider addrs = + case someTxOutRef utxosToConsider of + Just (oref, _) -> return oref + Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs runGYTxBuilderMonadIO :: -- | Network ID. @@ -126,14 +126,14 @@ runGYTxBuilderMonadIO envNid envProviders envAddrs envChangeAddr collateral (GYT , envCollateral = collateral' , envUsedSomeUTxOs = mempty } - where - obtainCollateral :: IO (Maybe GYUTxO) - obtainCollateral = runMaybeT $ do - (collateralRef, toCheck) <- hoistMaybe collateral - collateralUtxo <- - liftIO $ - gyQueryUtxoAtTxOutRef envProviders collateralRef - >>= maybe (throwIO . GYQueryUTxOException $ GYNoUtxoAtRef collateralRef) pure - if not toCheck || (utxoValue collateralUtxo == collateralValue) - then return collateralUtxo - else hoistMaybe Nothing + where + obtainCollateral :: IO (Maybe GYUTxO) + obtainCollateral = runMaybeT $ do + (collateralRef, toCheck) <- hoistMaybe collateral + collateralUtxo <- + liftIO $ + gyQueryUtxoAtTxOutRef envProviders collateralRef + >>= maybe (throwIO . GYQueryUTxOException $ GYNoUtxoAtRef collateralRef) pure + if not toCheck || (utxoValue collateralUtxo == collateralValue) + then return collateralUtxo + else hoistMaybe Nothing diff --git a/src/GeniusYield/TxBuilder/Query/Class.hs b/src/GeniusYield/TxBuilder/Query/Class.hs index 589bfe2c..086b7235 100644 --- a/src/GeniusYield/TxBuilder/Query/Class.hs +++ b/src/GeniusYield/TxBuilder/Query/Class.hs @@ -31,7 +31,7 @@ import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) ------------------------------------------------------------------------------- -- | Class of monads for querying chain data. -class (MonadError GYTxMonadException m) => GYTxQueryMonad m where +class MonadError GYTxMonadException m => GYTxQueryMonad m where {-# MINIMAL networkId, lookupDatum, (utxoAtTxOutRef | utxosAtTxOutRefs), utxosAtAddress, utxosAtPaymentCredential, stakeAddressInfo, slotConfig, slotOfCurrentBlock, logMsg, waitUntilSlot, waitForNextBlock #-} -- | Get the network id @@ -70,9 +70,9 @@ class (MonadError GYTxMonadException m) => GYTxQueryMonad m where -- | Lookup 'GYUTxOs' at zero or more 'GYAddress'. utxosAtAddresses :: [GYAddress] -> m GYUTxOs utxosAtAddresses = foldM f mempty - where - f :: GYUTxOs -> GYAddress -> m GYUTxOs - f utxos addr = (<> utxos) <$> utxosAtAddress addr Nothing + where + f :: GYUTxOs -> GYAddress -> m GYUTxOs + f utxos addr = (<> utxos) <$> utxosAtAddress addr Nothing -- | Lookup UTxOs at zero or more 'GYAddress' with their datums. This has a default implementation using `utxosAtAddresses` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. utxosAtAddressesWithDatums :: [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] @@ -92,9 +92,9 @@ class (MonadError GYTxMonadException m) => GYTxQueryMonad m where -- | Lookup 'GYUTxOs' at zero or more 'GYPaymentCredential'. utxosAtPaymentCredentials :: [GYPaymentCredential] -> m GYUTxOs utxosAtPaymentCredentials = foldM f mempty - where - f :: GYUTxOs -> GYPaymentCredential -> m GYUTxOs - f utxos paymentCred = (<> utxos) <$> utxosAtPaymentCredential paymentCred Nothing + where + f :: GYUTxOs -> GYPaymentCredential -> m GYUTxOs + f utxos paymentCred = (<> utxos) <$> utxosAtPaymentCredential paymentCred Nothing -- | Lookup UTxOs at zero or more 'GYPaymentCredential' with their datums. This has a default implementation using `utxosAtPaymentCredentials` and `lookupDatum` but should be overridden for efficiency if provider provides suitable option. utxosAtPaymentCredentialsWithDatums :: [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] @@ -114,7 +114,7 @@ class (MonadError GYTxMonadException m) => GYTxQueryMonad m where slotOfCurrentBlock :: m GYSlot -- | Log a message with specified namespace and severity. - logMsg :: (HasCallStack) => GYLogNamespace -> GYLogSeverity -> String -> m () + logMsg :: HasCallStack => GYLogNamespace -> GYLogSeverity -> String -> m () -- | Wait until the chain tip is at least the given slot number, returning it's slot. waitUntilSlot :: GYSlot -> m GYSlot @@ -136,14 +136,14 @@ to decide where to draw the line regarding the interface. Our transaction buildi coin selection strategy, parallel transactions, chaining transactions etc. Should all this really be included under the class method in question? -} -class (GYTxQueryMonad m) => GYTxSpecialQueryMonad m where +class GYTxQueryMonad m => GYTxSpecialQueryMonad m where systemStart :: m Api.SystemStart eraHistory :: m Api.EraHistory protocolParams :: m ApiProtocolParameters stakePools :: m (Set Api.S.PoolId) -- | Class of monads for querying as a user. -class (GYTxQueryMonad m) => GYTxUserQueryMonad m where +class GYTxQueryMonad m => GYTxUserQueryMonad m where -- | Get your own address(es). ownAddresses :: m [GYAddress] @@ -165,7 +165,7 @@ class (GYTxQueryMonad m) => GYTxUserQueryMonad m where -- Instances for useful transformers. ------------------------------------------------------------------------------- -instance (GYTxQueryMonad m) => GYTxQueryMonad (RandT g m) where +instance GYTxQueryMonad m => GYTxQueryMonad (RandT g m) where networkId = lift networkId lookupDatum = lift . lookupDatum utxoAtTxOutRef = lift . utxoAtTxOutRef @@ -187,20 +187,20 @@ instance (GYTxQueryMonad m) => GYTxQueryMonad (RandT g m) where waitUntilSlot = lift . waitUntilSlot waitForNextBlock = lift waitForNextBlock -instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (RandT g m) where +instance GYTxUserQueryMonad m => GYTxUserQueryMonad (RandT g m) where ownAddresses = lift ownAddresses ownChangeAddress = lift ownChangeAddress ownCollateral = lift ownCollateral availableUTxOs = lift availableUTxOs someUTxO = lift . someUTxO -instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (RandT g m) where +instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (RandT g m) where systemStart = lift systemStart eraHistory = lift eraHistory protocolParams = lift protocolParams stakePools = lift stakePools -instance (GYTxQueryMonad m) => GYTxQueryMonad (ReaderT env m) where +instance GYTxQueryMonad m => GYTxQueryMonad (ReaderT env m) where networkId = lift networkId lookupDatum = lift . lookupDatum utxoAtTxOutRef = lift . utxoAtTxOutRef @@ -222,14 +222,14 @@ instance (GYTxQueryMonad m) => GYTxQueryMonad (ReaderT env m) where waitUntilSlot = lift . waitUntilSlot waitForNextBlock = lift waitForNextBlock -instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (ReaderT env m) where +instance GYTxUserQueryMonad m => GYTxUserQueryMonad (ReaderT env m) where ownAddresses = lift ownAddresses ownChangeAddress = lift ownChangeAddress ownCollateral = lift ownCollateral availableUTxOs = lift availableUTxOs someUTxO = lift . someUTxO -instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (ReaderT env m) where +instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (ReaderT env m) where systemStart = lift systemStart eraHistory = lift eraHistory protocolParams = lift protocolParams @@ -261,7 +261,7 @@ system will suffice (do NOT use free(er) monad like ones). This will trivialize entire problem. -} -instance (GYTxQueryMonad m) => GYTxQueryMonad (Strict.StateT s m) where +instance GYTxQueryMonad m => GYTxQueryMonad (Strict.StateT s m) where networkId = lift networkId lookupDatum = lift . lookupDatum utxoAtTxOutRef = lift . utxoAtTxOutRef @@ -283,20 +283,20 @@ instance (GYTxQueryMonad m) => GYTxQueryMonad (Strict.StateT s m) where waitUntilSlot = lift . waitUntilSlot waitForNextBlock = lift waitForNextBlock -instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (Strict.StateT s m) where +instance GYTxUserQueryMonad m => GYTxUserQueryMonad (Strict.StateT s m) where ownAddresses = lift ownAddresses ownChangeAddress = lift ownChangeAddress ownCollateral = lift ownCollateral availableUTxOs = lift availableUTxOs someUTxO = lift . someUTxO -instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (Strict.StateT s m) where +instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (Strict.StateT s m) where systemStart = lift systemStart eraHistory = lift eraHistory protocolParams = lift protocolParams stakePools = lift stakePools -instance (GYTxQueryMonad m) => GYTxQueryMonad (Lazy.StateT s m) where +instance GYTxQueryMonad m => GYTxQueryMonad (Lazy.StateT s m) where networkId = lift networkId lookupDatum = lift . lookupDatum utxoAtTxOutRef = lift . utxoAtTxOutRef @@ -318,14 +318,14 @@ instance (GYTxQueryMonad m) => GYTxQueryMonad (Lazy.StateT s m) where waitUntilSlot = lift . waitUntilSlot waitForNextBlock = lift waitForNextBlock -instance (GYTxUserQueryMonad m) => GYTxUserQueryMonad (Lazy.StateT s m) where +instance GYTxUserQueryMonad m => GYTxUserQueryMonad (Lazy.StateT s m) where ownAddresses = lift ownAddresses ownChangeAddress = lift ownChangeAddress ownCollateral = lift ownCollateral availableUTxOs = lift availableUTxOs someUTxO = lift . someUTxO -instance (GYTxSpecialQueryMonad m) => GYTxSpecialQueryMonad (Lazy.StateT s m) where +instance GYTxSpecialQueryMonad m => GYTxSpecialQueryMonad (Lazy.StateT s m) where systemStart = lift systemStart eraHistory = lift eraHistory protocolParams = lift protocolParams diff --git a/src/GeniusYield/Types/Ada.hs b/src/GeniusYield/Types/Ada.hs index 83685200..325ff436 100644 --- a/src/GeniusYield/Types/Ada.hs +++ b/src/GeniusYield/Types/Ada.hs @@ -24,7 +24,7 @@ import PlutusLedgerApi.V1.Value qualified as Value -- | Ada represented with a 'Micro' value. newtype Ada = Ada Micro deriving stock (Eq, Ord, Show) - deriving newtype (Num) + deriving newtype Num -- | Convert Ada amount to its corresponding Lovelace unit. toLovelace :: Ada -> Integer diff --git a/src/GeniusYield/Types/Address.hs b/src/GeniusYield/Types/Address.hs index d304fb19..bca9075c 100644 --- a/src/GeniusYield/Types/Address.hs +++ b/src/GeniusYield/Types/Address.hs @@ -195,9 +195,9 @@ addressToPlutus addr = case addressToApi addr of -- Lookup Ledger.Tx.CardanoAPI module in plutus-ledger. byronAddressToPlutus :: Api.S.Address Api.S.ByronAddr -> Plutus.Address byronAddressToPlutus (Api.B.ByronAddress addr) = Plutus.Address plutusCredential Nothing - where - plutusCredential :: Plutus.Credential - plutusCredential = Plutus.PubKeyCredential $ Plutus.PubKeyHash $ PlutusTx.toBuiltin $ addrToBase58 addr + where + plutusCredential :: Plutus.Credential + plutusCredential = Plutus.PubKeyCredential $ Plutus.PubKeyHash $ PlutusTx.toBuiltin $ addrToBase58 addr shelleyAddressToPlutus :: Api.Address Api.ShelleyAddr -> Plutus.Address shelleyAddressToPlutus (Api.S.ShelleyAddress _network credential stake) = @@ -231,31 +231,31 @@ addressFromPlutus nid addr = (Left $ UnknownPlutusToCardanoError $ Text.pack $ "addressFromPlutus: " <> show addr) (Right . GYAddress . Api.S.AddressShelley) $ Api.S.ShelleyAddress nid' <$> paymentCredential <*> stakeReference - where - nid' :: Ledger.Network - nid' = networkIdToLedger nid + where + nid' :: Ledger.Network + nid' = networkIdToLedger nid - credential :: Plutus.Credential -> Maybe (Ledger.Credential kr Ledger.StandardCrypto) - credential (Plutus.PubKeyCredential (Plutus.PubKeyHash (Plutus.BuiltinByteString bs))) = Ledger.KeyHashObj . Ledger.KeyHash <$> Crypto.hashFromBytes bs - credential (Plutus.ScriptCredential (Plutus.ScriptHash (Plutus.BuiltinByteString bs))) = Ledger.ScriptHashObj . Ledger.ScriptHash <$> Crypto.hashFromBytes bs + credential :: Plutus.Credential -> Maybe (Ledger.Credential kr Ledger.StandardCrypto) + credential (Plutus.PubKeyCredential (Plutus.PubKeyHash (Plutus.BuiltinByteString bs))) = Ledger.KeyHashObj . Ledger.KeyHash <$> Crypto.hashFromBytes bs + credential (Plutus.ScriptCredential (Plutus.ScriptHash (Plutus.BuiltinByteString bs))) = Ledger.ScriptHashObj . Ledger.ScriptHash <$> Crypto.hashFromBytes bs - paymentCredential :: Maybe (Ledger.PaymentCredential Ledger.StandardCrypto) - paymentCredential = credential $ Plutus.addressCredential addr + paymentCredential :: Maybe (Ledger.PaymentCredential Ledger.StandardCrypto) + paymentCredential = credential $ Plutus.addressCredential addr - stakeReference :: Maybe (Ledger.StakeReference Ledger.StandardCrypto) - stakeReference = case Plutus.addressStakingCredential addr of - Nothing -> Just Ledger.StakeRefNull - Just (Plutus.StakingHash c) -> Ledger.StakeRefBase <$> credential c - Just (Plutus.StakingPtr x y z) -> Ledger.StakeRefPtr <$> ptr x y z + stakeReference :: Maybe (Ledger.StakeReference Ledger.StandardCrypto) + stakeReference = case Plutus.addressStakingCredential addr of + Nothing -> Just Ledger.StakeRefNull + Just (Plutus.StakingHash c) -> Ledger.StakeRefBase <$> credential c + Just (Plutus.StakingPtr x y z) -> Ledger.StakeRefPtr <$> ptr x y z - ptr :: Integer -> Integer -> Integer -> Maybe Ledger.Ptr - ptr x y z = Ledger.Ptr <$> coerce integerToWord64 x <*> coerce integerToWord64 y <*> coerce integerToWord64 z + ptr :: Integer -> Integer -> Integer -> Maybe Ledger.Ptr + ptr x y z = Ledger.Ptr <$> coerce integerToWord64 x <*> coerce integerToWord64 y <*> coerce integerToWord64 z - integerToWord64 :: Integer -> Maybe Word64 - integerToWord64 n - | n < 0 = Nothing - | n > toInteger (maxBound @Word64) = Nothing - | otherwise = Just $ fromInteger n + integerToWord64 :: Integer -> Maybe Word64 + integerToWord64 n + | n < 0 = Nothing + | n > toInteger (maxBound @Word64) = Nothing + | otherwise = Just $ fromInteger n {- | If an address is a shelley address, then we'll return payment credential wrapped in `Just`, `Nothing` otherwise. @@ -370,18 +370,18 @@ addressToPubKeyHash :: GYAddress -> Maybe GYPubKeyHash addressToPubKeyHash (GYAddress (Api.AddressByron (Api.B.ByronAddress _addr))) = Nothing -- It's not clear what to do with these, and whether GY should support Byron addresses at all (as owners of pools) addressToPubKeyHash (GYAddress (Api.AddressShelley (Api.S.ShelleyAddress _network credential _stake))) = f (Api.S.fromShelleyPaymentCredential credential) - where - f :: Api.S.PaymentCredential -> Maybe GYPubKeyHash - f (Api.S.PaymentCredentialByKey h) = Just (pubKeyHashFromApi h) - f (Api.S.PaymentCredentialByScript _) = Nothing + where + f :: Api.S.PaymentCredential -> Maybe GYPubKeyHash + f (Api.S.PaymentCredentialByKey h) = Just (pubKeyHashFromApi h) + f (Api.S.PaymentCredentialByScript _) = Nothing addressToValidatorHash :: GYAddress -> Maybe GYValidatorHash addressToValidatorHash (GYAddress (Api.AddressByron _)) = Nothing addressToValidatorHash (GYAddress (Api.AddressShelley (Api.S.ShelleyAddress _network credential _stake))) = f (Api.S.fromShelleyPaymentCredential credential) - where - f :: Api.S.PaymentCredential -> Maybe GYValidatorHash - f (Api.S.PaymentCredentialByKey _) = Nothing - f (Api.S.PaymentCredentialByScript h) = Just (validatorHashFromApi h) + where + f :: Api.S.PaymentCredential -> Maybe GYValidatorHash + f (Api.S.PaymentCredentialByKey _) = Nothing + f (Api.S.PaymentCredentialByScript h) = Just (validatorHashFromApi h) ------------------------------------------------------------------------------- -- Text conversions diff --git a/src/GeniusYield/Types/Certificate.hs b/src/GeniusYield/Types/Certificate.hs index ad53cd5e..ff3f2d90 100644 --- a/src/GeniusYield/Types/Certificate.hs +++ b/src/GeniusYield/Types/Certificate.hs @@ -55,9 +55,9 @@ finaliseCert pp = \case GYStakeAddressDeregistrationCertificatePB sc -> GYStakeAddressDeregistrationCertificate ppDep' sc GYStakeAddressDelegationCertificatePB sc del -> GYStakeAddressDelegationCertificate sc del GYStakeAddressRegistrationDelegationCertificatePB sc del -> GYStakeAddressRegistrationDelegationCertificate ppDep' sc del - where - Ledger.Coin ppDep = pp ^. Ledger.ppKeyDepositL - ppDep' :: Natural = fromIntegral ppDep + where + Ledger.Coin ppDep = pp ^. Ledger.ppKeyDepositL + ppDep' :: Natural = fromIntegral ppDep certificateToApi :: GYCertificate -> Api.Certificate ApiEra certificateToApi = \case @@ -73,9 +73,9 @@ certificateToApi = \case Api.makeStakeAddressDelegationCertificate $ Api.StakeDelegationRequirementsConwayOnwards Api.ConwayEraOnwardsConway (f sc) (g del) GYStakeAddressRegistrationDelegationCertificate dep sc del -> Api.makeStakeAddressAndDRepDelegationCertificate Api.ConwayEraOnwardsConway (f sc) (g del) (fromIntegral dep) - where - f = stakeCredentialToApi - g = delegateeToLedger + where + f = stakeCredentialToApi + g = delegateeToLedger certificateFromApiMaybe :: Api.Certificate ApiEra -> Maybe GYCertificate certificateFromApiMaybe (Api.ConwayCertificate _ x) = case x of @@ -87,9 +87,9 @@ certificateFromApiMaybe (Api.ConwayCertificate _ x) = case x of Ledger.ConwayDelegCert sc del -> Just $ GYStakeAddressDelegationCertificate (f sc) (g del) Ledger.ConwayRegDelegCert sc del dep -> Just $ GYStakeAddressRegistrationDelegationCertificate (fromIntegral dep) (f sc) (g del) _ -> Nothing - where - f = stakeCredentialFromLedger - g = delegateeFromLedger + where + f = stakeCredentialFromLedger + g = delegateeFromLedger certificateFromApiMaybe _ = Nothing certificateToStakeCredential :: GYCertificate -> GYStakeCredential diff --git a/src/GeniusYield/Types/Datum.hs b/src/GeniusYield/Types/Datum.hs index a88d16d4..f3d7108b 100644 --- a/src/GeniusYield/Types/Datum.hs +++ b/src/GeniusYield/Types/Datum.hs @@ -102,7 +102,7 @@ datumFromPlutus' :: PlutusTx.BuiltinData -> GYDatum datumFromPlutus' = GYDatum -- | Get a 'GYDatum' from any Plutus 'Plutus.ToData' type. -datumFromPlutusData :: (PlutusTx.ToData a) => a -> GYDatum +datumFromPlutusData :: PlutusTx.ToData a => a -> GYDatum datumFromPlutusData = GYDatum . PlutusTx.toBuiltinData {- | Unit datum @@ -141,7 +141,7 @@ instance Aeson.ToJSON GYDatum where ------------------------------------------------------------------------------- newtype GYDatumHash = GYDatumHash (Api.Hash Api.ScriptData) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, Ord, ToJSON, FromJSON) -- >>> Web.toUrlPiece (GYDatumHash "0103c27d58a7b32241bb7f03045fae8edc01dd2f2a70a349addc17f6536fde76") diff --git a/src/GeniusYield/Types/Key.hs b/src/GeniusYield/Types/Key.hs index 6fcde731..8689e4ab 100644 --- a/src/GeniusYield/Types/Key.hs +++ b/src/GeniusYield/Types/Key.hs @@ -112,7 +112,7 @@ import GeniusYield.Types.StakeKeyHash ( GYPaymentVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" -} newtype GYPaymentVerificationKey = GYPaymentVerificationKey (Api.VerificationKey Api.PaymentKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, IsString) {- | @@ -185,8 +185,8 @@ instance Printf.PrintfArg GYPaymentVerificationKey where GYPaymentSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" -} newtype GYPaymentSigningKey = GYPaymentSigningKey (Api.SigningKey Api.PaymentKey) - deriving stock (Show) - deriving newtype (IsString) + deriving stock Show + deriving newtype IsString instance Eq GYPaymentSigningKey where (==) = (==) `on` show @@ -199,8 +199,8 @@ instance ToShelleyWitnessSigningKey GYPaymentSigningKey where -- Handle key for extended signing key newtype GYExtendedPaymentSigningKey = GYExtendedPaymentSigningKey (Api.SigningKey Api.PaymentExtendedKey) - deriving stock (Show) - deriving newtype (IsString) + deriving stock Show + deriving newtype IsString instance Eq GYExtendedPaymentSigningKey where (==) = (==) `on` show @@ -253,11 +253,11 @@ readPaymentSigningKey fp = do case s of Left err -> fail (show err) --- throws IOError Right x -> return (GYPaymentSigningKey x) - where - acceptedTypes = - [ Api.FromSomeType (Api.AsSigningKey Api.AsGenesisUTxOKey) Api.castSigningKey - , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id - ] + where + acceptedTypes = + [ Api.FromSomeType (Api.AsSigningKey Api.AsGenesisUTxOKey) Api.castSigningKey + , Api.FromSomeType (Api.AsSigningKey Api.AsPaymentKey) id + ] -- | Reads extended payment signing key from file readExtendedPaymentSigningKey :: FilePath -> IO GYExtendedPaymentSigningKey @@ -346,7 +346,7 @@ generatePaymentSigningKey = paymentSigningKeyFromApi <$> Api.generateSigningKey GYStakeVerificationKey "0717bc56ed4897c3dde0690e3d9ce61e28a55f520fde454f6b5b61305b193605" -} newtype GYStakeVerificationKey = GYStakeVerificationKey (Api.VerificationKey Api.StakeKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, IsString) {- | @@ -413,8 +413,8 @@ instance Printf.PrintfArg GYStakeVerificationKey where GYStakeSigningKey "5ac75cb3435ef38c5bf15d11469b301b13729deb9595133a608fc0881fcec290" -} newtype GYStakeSigningKey = GYStakeSigningKey (Api.SigningKey Api.StakeKey) - deriving stock (Show) - deriving newtype (IsString) + deriving stock Show + deriving newtype IsString instance Eq GYStakeSigningKey where (==) = (==) `on` show @@ -427,8 +427,8 @@ instance ToShelleyWitnessSigningKey GYStakeSigningKey where -- Handle key for extended signing key newtype GYExtendedStakeSigningKey = GYExtendedStakeSigningKey (Api.SigningKey Api.StakeExtendedKey) - deriving stock (Show) - deriving newtype (IsString) + deriving stock Show + deriving newtype IsString instance Eq GYExtendedStakeSigningKey where (==) = (==) `on` show diff --git a/src/GeniusYield/Types/Ledger.hs b/src/GeniusYield/Types/Ledger.hs index c9ea2329..672912f6 100644 --- a/src/GeniusYield/Types/Ledger.hs +++ b/src/GeniusYield/Types/Ledger.hs @@ -21,4 +21,4 @@ data PlutusToCardanoError StakePtrAddressUnsupported Plutus.Address | -- | Wildcard unhandled constructors; shouldn't happen usually. UnknownPlutusToCardanoError {ptceTag :: Text} - deriving stock (Show) + deriving stock Show diff --git a/src/GeniusYield/Types/Logging.hs b/src/GeniusYield/Types/Logging.hs index f823cf86..6ef25318 100644 --- a/src/GeniusYield/Types/Logging.hs +++ b/src/GeniusYield/Types/Logging.hs @@ -216,7 +216,7 @@ logContextsToKatip :: GYLogContexts -> K.LogContexts logContextsToKatip = coerce -- | Add a context to the log contexts. See `sl`. -addContext :: (KC.LogItem i) => i -> GYLogContexts -> GYLogContexts +addContext :: KC.LogItem i => i -> GYLogContexts -> GYLogContexts addContext i ctx = ctx <> logContextsFromKatip (K.liftPayload i) {- | Construct a simple log payload. @@ -224,7 +224,7 @@ addContext i ctx = ctx <> logContextsFromKatip (K.liftPayload i) >>> Aeson.encode $ logContextsToKatip $ addContext (sl "key" "value") mempty "{\"key\":\"value\"}" -} -sl :: forall a. (ToJSON a) => Text -> a -> K.SimpleLogPayload +sl :: forall a. ToJSON a => Text -> a -> K.SimpleLogPayload sl = K.sl {- | Get textual representation of log contexts. @@ -232,7 +232,7 @@ sl = K.sl >>> logContextsToS @Text $ addContext (sl "key" "value") mempty "{\"key\":\"value\"}" -} -logContextsToS :: (StringConv LBS8.ByteString a) => GYLogContexts -> a +logContextsToS :: StringConv LBS8.ByteString a => GYLogContexts -> a logContextsToS = logContextsToKatip >>> Aeson.encode >>> toS ------------------------------------------------------------------------------- @@ -279,7 +279,7 @@ data GYLogConfiguration = GYLogConfiguration cfgAddNamespace :: GYLogNamespace -> GYLogConfiguration -> GYLogConfiguration cfgAddNamespace ns cfg = cfg {cfgLogNamespace = cfgLogNamespace cfg <> ns} -cfgAddContext :: (KC.LogItem i) => i -> GYLogConfiguration -> GYLogConfiguration +cfgAddContext :: KC.LogItem i => i -> GYLogConfiguration -> GYLogConfiguration cfgAddContext i cfg = cfg {cfgLogContexts = addContext i (cfgLogContexts cfg)} logRun :: (HasCallStack, MonadIO m, StringConv a Text) => GYLogConfiguration -> GYLogSeverity -> a -> m () @@ -411,29 +411,29 @@ mkScribe GYLogScribeConfig {..} = case cfgLogType of GYCustomSourceScribe source -> do scribe <- customSourceScribe source pure (scribe, Text.pack $ show source) - where - permit :: K.PermitFunc - permit = K.permitItem $ logSeverityToKatip cfgLogSeverity - - verbosity :: K.Verbosity - verbosity = logVerbosityToKatip cfgLogVerbosity - - customSourceScribe :: LogSrc -> IO K.Scribe - customSourceScribe (LogSrc uri) = case uri of - URI {uriScheme = "", uriPath = path} -> - K.mkFileScribe path permit verbosity - URI {uriScheme = s, uriAuthority = Just URIAuth {uriRegName = domainName}} - | s `elem` ["http:", "https:"] && "sentry.io" `isSuffixOf` domainName -> - Sentry.mkSentryScribe (Sentry.sentryService $ show uri) permit verbosity - x -> - fail $ "Unsupported LogSrc: " <> show x + where + permit :: K.PermitFunc + permit = K.permitItem $ logSeverityToKatip cfgLogSeverity + + verbosity :: K.Verbosity + verbosity = logVerbosityToKatip cfgLogVerbosity + + customSourceScribe :: LogSrc -> IO K.Scribe + customSourceScribe (LogSrc uri) = case uri of + URI {uriScheme = "", uriPath = path} -> + K.mkFileScribe path permit verbosity + URI {uriScheme = s, uriAuthority = Just URIAuth {uriRegName = domainName}} + | s `elem` ["http:", "https:"] && "sentry.io" `isSuffixOf` domainName -> + Sentry.mkSentryScribe (Sentry.sentryService $ show uri) permit verbosity + x -> + fail $ "Unsupported LogSrc: " <> show x mkLogEnv :: GYLogNamespace -> [GYLogScribeConfig] -> IO GYLogEnv mkLogEnv ns cfgs = do logEnv <- K.initLogEnv (logNamespaceToKatip $ "GeniusYield" <> ns) "" logEnvFromKatip <$> foldM f logEnv cfgs - where - f :: K.LogEnv -> GYLogScribeConfig -> IO K.LogEnv - f logEnv cfg = do - (scribe, name) <- mkScribe cfg - K.registerScribe name scribe K.defaultScribeSettings logEnv + where + f :: K.LogEnv -> GYLogScribeConfig -> IO K.LogEnv + f logEnv cfg = do + (scribe, name) <- mkScribe cfg + K.registerScribe name scribe K.defaultScribeSettings logEnv diff --git a/src/GeniusYield/Types/OpenApi.hs b/src/GeniusYield/Types/OpenApi.hs index 89ef5ffd..366b602c 100644 --- a/src/GeniusYield/Types/OpenApi.hs +++ b/src/GeniusYield/Types/OpenApi.hs @@ -42,31 +42,31 @@ liftSwaggerSchema swaggerSchema = & OpenApi.enum_ .~ swaggerSchema ^. Swagger.enum_ & OpenApi.multipleOf .~ swaggerSchema ^. Swagger.multipleOf & OpenApi.items .~ (convertSwaggerItems <$> swaggerSchema ^. Swagger.items) - where - convertSwaggerItems :: Swagger.SwaggerItems Swagger.SwaggerKindSchema -> OpenApi.OpenApiItems - convertSwaggerItems (Swagger.SwaggerItemsObject s) = OpenApi.OpenApiItemsObject (convertSwaggerReferencedSchema s) - convertSwaggerItems (Swagger.SwaggerItemsArray s) = OpenApi.OpenApiItemsArray (convertSwaggerReferencedSchema <$> s) - convertSwaggerItems (Swagger.SwaggerItemsPrimitive _ _) = error "Primitive array items found in schema description, but should only be used for query params, headers and path pieces" + where + convertSwaggerItems :: Swagger.SwaggerItems Swagger.SwaggerKindSchema -> OpenApi.OpenApiItems + convertSwaggerItems (Swagger.SwaggerItemsObject s) = OpenApi.OpenApiItemsObject (convertSwaggerReferencedSchema s) + convertSwaggerItems (Swagger.SwaggerItemsArray s) = OpenApi.OpenApiItemsArray (convertSwaggerReferencedSchema <$> s) + convertSwaggerItems (Swagger.SwaggerItemsPrimitive _ _) = error "Primitive array items found in schema description, but should only be used for query params, headers and path pieces" - convertSwaggerReferencedSchema :: Swagger.Referenced Swagger.Schema -> OpenApi.Referenced OpenApi.Schema - convertSwaggerReferencedSchema (Swagger.Inline s) = OpenApi.Inline (liftSwaggerSchema s) - convertSwaggerReferencedSchema (Swagger.Ref r) = OpenApi.Ref (convertSwaggerRef r) + convertSwaggerReferencedSchema :: Swagger.Referenced Swagger.Schema -> OpenApi.Referenced OpenApi.Schema + convertSwaggerReferencedSchema (Swagger.Inline s) = OpenApi.Inline (liftSwaggerSchema s) + convertSwaggerReferencedSchema (Swagger.Ref r) = OpenApi.Ref (convertSwaggerRef r) - convertSwaggerRef :: Swagger.Reference -> OpenApi.Reference - convertSwaggerRef (Swagger.Reference ref) = OpenApi.Reference ref + convertSwaggerRef :: Swagger.Reference -> OpenApi.Reference + convertSwaggerRef (Swagger.Reference ref) = OpenApi.Reference ref - convertSwaggerType :: Swagger.SwaggerType 'Swagger.SwaggerKindSchema -> OpenApiType - convertSwaggerType Swagger.SwaggerString = OpenApiString - convertSwaggerType Swagger.SwaggerNumber = OpenApiNumber - convertSwaggerType Swagger.SwaggerInteger = OpenApiInteger - convertSwaggerType Swagger.SwaggerBoolean = OpenApiBoolean - convertSwaggerType Swagger.SwaggerArray = OpenApiArray - convertSwaggerType Swagger.SwaggerNull = OpenApiNull - convertSwaggerType Swagger.SwaggerObject = OpenApiObject + convertSwaggerType :: Swagger.SwaggerType 'Swagger.SwaggerKindSchema -> OpenApiType + convertSwaggerType Swagger.SwaggerString = OpenApiString + convertSwaggerType Swagger.SwaggerNumber = OpenApiNumber + convertSwaggerType Swagger.SwaggerInteger = OpenApiInteger + convertSwaggerType Swagger.SwaggerBoolean = OpenApiBoolean + convertSwaggerType Swagger.SwaggerArray = OpenApiArray + convertSwaggerType Swagger.SwaggerNull = OpenApiNull + convertSwaggerType Swagger.SwaggerObject = OpenApiObject - convertSwaggerAdditionalProperties :: Swagger.AdditionalProperties -> OpenApi.AdditionalProperties - convertSwaggerAdditionalProperties (Swagger.AdditionalPropertiesAllowed b) = OpenApi.AdditionalPropertiesAllowed b - convertSwaggerAdditionalProperties (Swagger.AdditionalPropertiesSchema s) = OpenApi.AdditionalPropertiesSchema (convertSwaggerReferencedSchema s) + convertSwaggerAdditionalProperties :: Swagger.AdditionalProperties -> OpenApi.AdditionalProperties + convertSwaggerAdditionalProperties (Swagger.AdditionalPropertiesAllowed b) = OpenApi.AdditionalPropertiesAllowed b + convertSwaggerAdditionalProperties (Swagger.AdditionalPropertiesSchema s) = OpenApi.AdditionalPropertiesSchema (convertSwaggerReferencedSchema s) -- | Convert a @Swagger.NamedSchema@ to an @OpenApi.NamedSchema@. convertNamedSchema :: Swagger.NamedSchema -> OpenApi.NamedSchema diff --git a/src/GeniusYield/Types/PaymentKeyHash.hs b/src/GeniusYield/Types/PaymentKeyHash.hs index 9c90da2f..cb5a96a8 100644 --- a/src/GeniusYield/Types/PaymentKeyHash.hs +++ b/src/GeniusYield/Types/PaymentKeyHash.hs @@ -48,7 +48,7 @@ import Text.Printf qualified as Printf -} newtype GYPaymentKeyHash = GYPaymentKeyHash (Api.Hash Api.PaymentKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, Ord, IsString) instance AsPubKeyHash GYPaymentKeyHash where @@ -80,10 +80,10 @@ e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d -} paymentKeyHashToPlutus :: GYPaymentKeyHash -> Plutus.PubKeyHash paymentKeyHashToPlutus = coerce fromCardanoPaymentKeyHash - where - -- this is not exported from plutus-ledger - fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash - fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash + where + -- this is not exported from plutus-ledger + fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash + fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash {- | diff --git a/src/GeniusYield/Types/Providers.hs b/src/GeniusYield/Types/Providers.hs index 71183b71..980bd521 100644 --- a/src/GeniusYield/Types/Providers.hs +++ b/src/GeniusYield/Types/Providers.hs @@ -263,7 +263,7 @@ data GYAwaitTxParameters = GYAwaitTxParameters , confirmations :: !Word64 -- ^ Min number of block confirmation. __NOTE:__ We might wait for more blocks than what is mentioned here but certainly not less. } - deriving stock (Show) + deriving stock Show instance Default GYAwaitTxParameters where def = @@ -274,7 +274,7 @@ instance Default GYAwaitTxParameters where } newtype GYAwaitTxException = GYAwaitTxException GYAwaitTxParameters - deriving anyclass (Exception) + deriving anyclass Exception instance Show GYAwaitTxException where show (GYAwaitTxException awaitTxParams) = @@ -299,14 +299,14 @@ gyWaitForNextBlockDefault :: IO GYSlot -> IO GYSlot gyWaitForNextBlockDefault getSlotOfCurrentBlock = do s <- getSlotOfCurrentBlock go s - where - go :: GYSlot -> IO GYSlot - go s = do - threadDelay 100_000 - t <- getSlotOfCurrentBlock - if t > s - then return t - else go s + where + go :: GYSlot -> IO GYSlot + go s = do + threadDelay 100_000 + t <- getSlotOfCurrentBlock + if t > s + then return t + else go s {- | Wait until slot. @@ -314,15 +314,15 @@ Returns the new current slot, which might be larger. -} gyWaitUntilSlotDefault :: IO GYSlot -> GYSlot -> IO GYSlot gyWaitUntilSlotDefault getSlotOfCurrentBlock s = loop - where - loop :: IO GYSlot - loop = do - t <- getSlotOfCurrentBlock - if t >= s - then return t - else do - threadDelay 100_000 - loop + where + loop :: IO GYSlot + loop = do + t <- getSlotOfCurrentBlock + if t >= s + then return t + else do + threadDelay 100_000 + loop -- | Contains the data, alongside the time after which it should be refetched. data GYSlotStore = GYSlotStore !UTCTime !GYSlot @@ -350,21 +350,21 @@ makeSlotActions t getSlotOfCurrentBlock = do , gyWaitForNextBlock' = gyWaitForNextBlockDefault gcs , gyWaitUntilSlot' = gyWaitUntilSlotDefault gcs } - where - getSlotOfCurrentBlock' :: IO UTCTime -> StrictMVar IO GYSlotStore -> IO GYSlot - getSlotOfCurrentBlock' getTime var = do - -- See note: [Caching and concurrently accessible MVars]. - modifyMVar var $ \(GYSlotStore slotRefetchTime slotData) -> do - now <- getTime - if now < slotRefetchTime - then do - -- Return unmodified. - pure (GYSlotStore slotRefetchTime slotData, slotData) - else do - newSlot <- getSlotOfCurrentBlock - newNow <- getTime - let newSlotRefetchTime = addUTCTime t newNow - pure (GYSlotStore newSlotRefetchTime newSlot, newSlot) + where + getSlotOfCurrentBlock' :: IO UTCTime -> StrictMVar IO GYSlotStore -> IO GYSlot + getSlotOfCurrentBlock' getTime var = do + -- See note: [Caching and concurrently accessible MVars]. + modifyMVar var $ \(GYSlotStore slotRefetchTime slotData) -> do + now <- getTime + if now < slotRefetchTime + then do + -- Return unmodified. + pure (GYSlotStore slotRefetchTime slotData, slotData) + else do + newSlot <- getSlotOfCurrentBlock + newNow <- getTime + let newSlotRefetchTime = addUTCTime t newNow + pure (GYSlotStore newSlotRefetchTime newSlot, newSlot) ------------------------------------------------------------------------------- -- Protocol parameters @@ -439,14 +439,14 @@ makeGetParameters getProtParams getSysStart getEraHist getStkPools = do , gyGetStakePools' = getStkPools' , gyGetSlotConfig' = getSlotConf' } - where - beforeEnd _ Nothing = True - beforeEnd currTime (Just endTime) = currTime < endTime - makeSlotConfigIO sysStart = - either - (throwIO . GYConversionException . GYEraSummariesToSlotConfigError . Txt.pack) - pure - . makeSlotConfig sysStart + where + beforeEnd _ Nothing = True + beforeEnd currTime (Just endTime) = currTime < endTime + makeSlotConfigIO sysStart = + either + (throwIO . GYConversionException . GYEraSummariesToSlotConfigError . Txt.pack) + pure + . makeSlotConfig sysStart ------------------------------------------------------------------------------- -- Query UTxO @@ -496,31 +496,31 @@ gyQueryUtxosAtTxOutRefsDefault queryUtxoAtTxOutRef orefs = do pure $ utxosFromList $ catMaybes utxos -- | Lookup UTxOs at given 'GYAddress' with their datums. This is a default implementation using `utxosAtAddress` and `lookupDatum`. -gyQueryUtxosAtAddressWithDatumsDefault :: (Monad m) => (GYAddress -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYAddress -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtAddressWithDatumsDefault :: Monad m => (GYAddress -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYAddress -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtAddressWithDatumsDefault utxosAtAddressFun lookupDatumFun addr mAssetClass = do utxosWithoutDatumResolutions <- utxosAtAddressFun addr mAssetClass utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Lookup UTxOs at zero or more 'GYAddress' with their datums. This is a default implementation using `utxosAtAddresses` and `lookupDatum`. -gyQueryUtxosAtAddressesWithDatumsDefault :: (Monad m) => ([GYAddress] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtAddressesWithDatumsDefault :: Monad m => ([GYAddress] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYAddress] -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtAddressesWithDatumsDefault utxosAtAddressesFun lookupDatumFun addrs = do utxosWithoutDatumResolutions <- utxosAtAddressesFun addrs utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Lookup UTxOs at zero or more 'GYPaymentCredential' with their datums. This is a default implementation using `utxosAtPaymentCredentials` and `lookupDatum`. -gyQueryUtxosAtPaymentCredsWithDatumsDefault :: (Monad m) => ([GYPaymentCredential] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtPaymentCredsWithDatumsDefault :: Monad m => ([GYPaymentCredential] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtPaymentCredsWithDatumsDefault utxosAtPaymentCredsFun lookupDatumFun pcs = do utxosWithoutDatumResolutions <- utxosAtPaymentCredsFun pcs utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Lookup UTxOs at given 'GYPaymentCredential' with their datums. This is a default implementation using `utxosAtPaymentCredential` and `lookupDatum`. -gyQueryUtxosAtPaymentCredWithDatumsDefault :: (Monad m) => (GYPaymentCredential -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYPaymentCredential -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtPaymentCredWithDatumsDefault :: Monad m => (GYPaymentCredential -> Maybe GYAssetClass -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> GYPaymentCredential -> Maybe GYAssetClass -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtPaymentCredWithDatumsDefault utxosAtPaymentCredFun lookupDatumFun cred mAssetClass = do utxosWithoutDatumResolutions <- utxosAtPaymentCredFun cred mAssetClass utxosDatumResolver utxosWithoutDatumResolutions lookupDatumFun -- | Append UTxO information with their fetched datum. -utxosDatumResolver :: (Monad m) => GYUTxOs -> (GYDatumHash -> m (Maybe GYDatum)) -> m [(GYUTxO, Maybe GYDatum)] +utxosDatumResolver :: Monad m => GYUTxOs -> (GYDatumHash -> m (Maybe GYDatum)) -> m [(GYUTxO, Maybe GYDatum)] utxosDatumResolver utxos lookupDatumFun = do let utxosWithoutDatumResolutions = utxosToList utxos forM utxosWithoutDatumResolutions $ \utxo -> do @@ -530,7 +530,7 @@ utxosDatumResolver utxos lookupDatumFun = do GYOutDatumHash h -> (utxo,) <$> lookupDatumFun h -- | Lookup UTxOs at zero or more 'GYTxOutRef' with their datums. This is a default implementation using `utxosAtTxOutRefs` and `lookupDatum`. -gyQueryUtxosAtTxOutRefsWithDatumsDefault :: (Monad m) => ([GYTxOutRef] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYTxOutRef] -> m [(GYUTxO, Maybe GYDatum)] +gyQueryUtxosAtTxOutRefsWithDatumsDefault :: Monad m => ([GYTxOutRef] -> m GYUTxOs) -> (GYDatumHash -> m (Maybe GYDatum)) -> [GYTxOutRef] -> m [(GYUTxO, Maybe GYDatum)] gyQueryUtxosAtTxOutRefsWithDatumsDefault utxosAtTxOutRefsFun lookupDatumFun refs = do utxosWithoutDatumResolutions <- utxosToList <$> utxosAtTxOutRefsFun refs forM utxosWithoutDatumResolutions $ \utxo -> do diff --git a/src/GeniusYield/Types/PubKeyHash.hs b/src/GeniusYield/Types/PubKeyHash.hs index 19eb40f0..3704277a 100644 --- a/src/GeniusYield/Types/PubKeyHash.hs +++ b/src/GeniusYield/Types/PubKeyHash.hs @@ -46,14 +46,14 @@ import Text.Printf qualified as Printf -} newtype GYPubKeyHash = GYPubKeyHash (Api.Hash Api.PaymentKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, Ord, IsString) class AsPubKeyHash a where toPubKeyHash :: a -> GYPubKeyHash fromPubKeyHash :: GYPubKeyHash -> a -class (AsPubKeyHash a) => CanSignTx a +class AsPubKeyHash a => CanSignTx a instance AsPubKeyHash GYPubKeyHash where toPubKeyHash = id @@ -84,10 +84,10 @@ e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d -} pubKeyHashToPlutus :: GYPubKeyHash -> Plutus.PubKeyHash pubKeyHashToPlutus = coerce fromCardanoPaymentKeyHash - where - -- this is not exported from plutus-ledger - fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash - fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash + where + -- this is not exported from plutus-ledger + fromCardanoPaymentKeyHash :: Api.Hash Api.PaymentKey -> Plutus.PubKeyHash + fromCardanoPaymentKeyHash paymentKeyHash = Plutus.PubKeyHash $ Plutus.toBuiltin $ Api.serialiseToRawBytes paymentKeyHash {- | diff --git a/src/GeniusYield/Types/Redeemer.hs b/src/GeniusYield/Types/Redeemer.hs index e848eeb9..b5964436 100644 --- a/src/GeniusYield/Types/Redeemer.hs +++ b/src/GeniusYield/Types/Redeemer.hs @@ -25,7 +25,7 @@ import PlutusLedgerApi.V1 qualified as PlutusV1 import PlutusTx qualified newtype GYRedeemer = GYRedeemer PlutusTx.BuiltinData - deriving (Eq) + deriving Eq instance Show GYRedeemer where showsPrec d (GYRedeemer x) = @@ -48,7 +48,7 @@ redeemerFromPlutus (PlutusV1.Redeemer x) = GYRedeemer x redeemerFromPlutus' :: PlutusTx.BuiltinData -> GYRedeemer redeemerFromPlutus' = GYRedeemer -redeemerFromPlutusData :: (PlutusTx.ToData a) => a -> GYRedeemer +redeemerFromPlutusData :: PlutusTx.ToData a => a -> GYRedeemer redeemerFromPlutusData = GYRedeemer . PlutusTx.toBuiltinData redeemerToApi :: GYRedeemer -> Api.HashableScriptData diff --git a/src/GeniusYield/Types/Script.hs b/src/GeniusYield/Types/Script.hs index 355eb8ff..e5e7f68a 100644 --- a/src/GeniusYield/Types/Script.hs +++ b/src/GeniusYield/Types/Script.hs @@ -202,10 +202,10 @@ instance GShow GYValidator where -- FIXME: Seeing inclusion of CIP-69, we should likely get rid of all these different types of scripts and just have one type of script. -- To make it use BuiltinUnit. -validatorFromPlutus :: forall v. (SingPlutusVersionI v) => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYValidator v +validatorFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYValidator v validatorFromPlutus = coerce (scriptFromPlutus @v) -validatorFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYValidator v +validatorFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYValidator v validatorFromSerialisedScript = coerce . scriptFromSerialisedScript validatorToSerialisedScript :: GYValidator v -> Plutus.SerialisedScript @@ -217,7 +217,7 @@ validatorToScript = coerce validatorToApi :: GYValidator v -> Api.PlutusScript (PlutusVersionToApi v) validatorToApi = coerce scriptToApi -validatorFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYValidator v +validatorFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYValidator v validatorFromApi = coerce (scriptFromApi @v) validatorHash :: GYValidator v -> GYValidatorHash @@ -246,7 +246,7 @@ writeValidator :: FilePath -> GYValidator v -> IO () writeValidator file = writeScriptCore "Validator" file . coerce -- | Reads a validator from a file. -readValidator :: (SingPlutusVersionI v) => FilePath -> IO (GYValidator v) +readValidator :: SingPlutusVersionI v => FilePath -> IO (GYValidator v) readValidator = coerce readScript newtype GYValidatorHash = GYValidatorHash Api.ScriptHash @@ -320,10 +320,10 @@ mintingPolicyIdFromWitness :: GYMintScript v -> GYMintingPolicyId mintingPolicyIdFromWitness (GYMintScript p) = mintingPolicyId p mintingPolicyIdFromWitness (GYMintReference _ s) = mintingPolicyId $ coerce s -mintingPolicyFromPlutus :: forall v. (SingPlutusVersionI v) => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYMintingPolicy v +mintingPolicyFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYMintingPolicy v mintingPolicyFromPlutus = coerce (scriptFromPlutus @v) -mintingPolicyFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYMintingPolicy v +mintingPolicyFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYMintingPolicy v mintingPolicyFromSerialisedScript = coerce . scriptFromSerialisedScript mintingPolicyToSerialisedScript :: GYMintingPolicy v -> Plutus.SerialisedScript @@ -335,7 +335,7 @@ mintingPolicyToScript = coerce mintingPolicyToApi :: GYMintingPolicy v -> Api.PlutusScript (PlutusVersionToApi v) mintingPolicyToApi = coerce scriptToApi -mintingPolicyFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYMintingPolicy v +mintingPolicyFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYMintingPolicy v mintingPolicyFromApi = coerce (scriptFromApi @v) mintingPolicyCurrencySymbol :: GYMintingPolicy v -> PlutusV1.CurrencySymbol @@ -357,9 +357,9 @@ mintingPolicyToApiPlutusScriptWitness (GYMintingPolicy s) = data GYMintScript (u :: PlutusVersion) where -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. - GYMintScript :: (v `VersionIsGreaterOrEqual` u) => GYMintingPolicy v -> GYMintScript u + GYMintScript :: v `VersionIsGreaterOrEqual` u => GYMintingPolicy v -> GYMintScript u -- | Reference inputs can be only used in V2 transactions. - GYMintReference :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYMintScript v + GYMintReference :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYMintScript v deriving instance Show (GYMintScript v) @@ -395,7 +395,7 @@ writeMintingPolicy :: FilePath -> GYMintingPolicy v -> IO () writeMintingPolicy file = writeScriptCore "Minting Policy" file . coerce -- | Reads a minting policy from a file. -readMintingPolicy :: (SingPlutusVersionI v) => FilePath -> IO (GYMintingPolicy v) +readMintingPolicy :: SingPlutusVersionI v => FilePath -> IO (GYMintingPolicy v) readMintingPolicy = coerce readScript -- | Minting policy identifier, also a currency symbol. @@ -422,14 +422,14 @@ instance Show GYMintingPolicyId where instance Web.FromHttpApiData GYMintingPolicyId where parseUrlPiece = first Text.pack . Atto.parseOnly parser . TE.encodeUtf8 - where - parser :: Atto.Parser GYMintingPolicyId - parser = do - cs <- Atto.takeWhile1 isHexDigit + where + parser :: Atto.Parser GYMintingPolicyId + parser = do + cs <- Atto.takeWhile1 isHexDigit - case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of - Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x - Right cs' -> return $ mintingPolicyIdFromApi cs' + case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of + Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x + Right cs' -> return $ mintingPolicyIdFromApi cs' instance Web.ToHttpApiData GYMintingPolicyId where toUrlPiece = mintingPolicyIdToText @@ -491,8 +491,8 @@ mintingPolicyIdFromText policyid = bimap customError mintingPolicyIdFromApi . Api.deserialiseFromRawBytesHex Api.S.AsPolicyId $ TE.encodeUtf8 policyid - where - customError err = "Invalid minting policy: " ++ show policyid ++ "; Reason: " ++ show err + where + customError err = "Invalid minting policy: " ++ show policyid ++ "; Reason: " ++ show err ------------------------------------------------------------------------------- -- Stake validator @@ -514,10 +514,10 @@ stakeValidatorVersionFromWitness :: GYStakeValScript v -> PlutusVersion stakeValidatorVersionFromWitness (GYStakeValScript mp) = fromSingPlutusVersion $ stakeValidatorVersion mp stakeValidatorVersionFromWitness (GYStakeValReference _ s) = fromSingPlutusVersion $ stakeValidatorVersion $ coerce s -stakeValidatorFromPlutus :: forall v. (SingPlutusVersionI v) => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYStakeValidator v +stakeValidatorFromPlutus :: forall v. SingPlutusVersionI v => PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) -> GYStakeValidator v stakeValidatorFromPlutus = coerce (scriptFromPlutus @v) -stakeValidatorFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYStakeValidator v +stakeValidatorFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYStakeValidator v stakeValidatorFromSerialisedScript = coerce . scriptFromSerialisedScript stakeValidatorToSerialisedScript :: GYStakeValidator v -> Plutus.SerialisedScript @@ -529,7 +529,7 @@ stakeValidatorToScript = coerce stakeValidatorToApi :: GYStakeValidator v -> Api.PlutusScript (PlutusVersionToApi v) stakeValidatorToApi = coerce scriptToApi -stakeValidatorFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYStakeValidator v +stakeValidatorFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYStakeValidator v stakeValidatorFromApi = coerce (scriptFromApi @v) stakeValidatorToApiPlutusScriptWitness :: @@ -542,9 +542,9 @@ stakeValidatorToApiPlutusScriptWitness (GYStakeValidator s) = data GYStakeValScript (u :: PlutusVersion) where -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. - GYStakeValScript :: (v `VersionIsGreaterOrEqual` u) => GYStakeValidator v -> GYStakeValScript u + GYStakeValScript :: v `VersionIsGreaterOrEqual` u => GYStakeValidator v -> GYStakeValScript u -- | Reference inputs can be only used in V2 transactions. - GYStakeValReference :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYStakeValScript v + GYStakeValReference :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYStakeValScript v deriving instance Show (GYStakeValScript v) @@ -633,7 +633,7 @@ writeStakeValidator :: FilePath -> GYStakeValidator v -> IO () writeStakeValidator file = writeScriptCore "Stake Validator" file . coerce -- | Reads a stake validator from a file. -readStakeValidator :: (SingPlutusVersionI v) => FilePath -> IO (GYStakeValidator v) +readStakeValidator :: SingPlutusVersionI v => FilePath -> IO (GYStakeValidator v) readStakeValidator = coerce readScript ------------------------------------------------------------------------------- @@ -687,10 +687,10 @@ instance GShow GYScript where hashScript :: GYScript v -> GYScriptHash hashScript = scriptApiHash >>> scriptHashFromApi -scriptFromPlutus :: forall v a. (SingPlutusVersionI v) => PlutusTx.CompiledCode a -> GYScript v +scriptFromPlutus :: forall v a. SingPlutusVersionI v => PlutusTx.CompiledCode a -> GYScript v scriptFromPlutus script = scriptFromApi $ Api.S.PlutusScriptSerialised $ Plutus.serialiseCompiledCode script -scriptFromSerialisedScript :: forall v. (SingPlutusVersionI v) => Plutus.SerialisedScript -> GYScript v +scriptFromSerialisedScript :: forall v. SingPlutusVersionI v => Plutus.SerialisedScript -> GYScript v scriptFromSerialisedScript serialisedScript = scriptFromApi $ Api.S.PlutusScriptSerialised @(PlutusVersionToApi v) serialisedScript @@ -711,8 +711,8 @@ someScriptToReferenceApi (GYPlutusScript (GYScript v apiScript _)) = Api.S.BabbageEraOnwardsConway $ Api.ScriptInAnyLang (Api.PlutusScriptLanguage v') $ Api.PlutusScript v' apiScript - where - v' = singPlutusVersionToApi v + where + v' = singPlutusVersionToApi v someScriptToReferenceApi (GYSimpleScript s) = Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway @@ -736,9 +736,9 @@ someScriptFromReferenceApi (Api.PlutusScript _ x) ) ) = Just (GYPlutusScript y) - where - y :: GYScript 'PlutusV1 - y = scriptFromApi x + where + y :: GYScript 'PlutusV1 + y = scriptFromApi x someScriptFromReferenceApi ( Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway @@ -747,9 +747,9 @@ someScriptFromReferenceApi (Api.PlutusScript _ x) ) ) = Just (GYPlutusScript y) - where - y :: GYScript 'PlutusV2 - y = scriptFromApi x + where + y :: GYScript 'PlutusV2 + y = scriptFromApi x someScriptFromReferenceApi ( Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway @@ -758,28 +758,28 @@ someScriptFromReferenceApi (Api.PlutusScript _ x) ) ) = Just (GYPlutusScript y) - where - y :: GYScript 'PlutusV3 - y = scriptFromApi x + where + y :: GYScript 'PlutusV3 + y = scriptFromApi x -scriptFromApi :: forall v. (SingPlutusVersionI v) => Api.PlutusScript (PlutusVersionToApi v) -> GYScript v +scriptFromApi :: forall v. SingPlutusVersionI v => Api.PlutusScript (PlutusVersionToApi v) -> GYScript v scriptFromApi script = GYScript v script apiHash - where - v = singPlutusVersion @v - apiScript :: Api.S.Script (PlutusVersionToApi v) - apiScript = Api.PlutusScript (singPlutusVersionToApi v) script - apiHash = Api.hashScript apiScript + where + v = singPlutusVersion @v + apiScript :: Api.S.Script (PlutusVersionToApi v) + apiScript = Api.PlutusScript (singPlutusVersionToApi v) script + apiHash = Api.hashScript apiScript -- >>> scriptFromCBOR @'PlutusV2 "59212d010000323232323322332233223232323322323232323232323332223332223232323232332232323232323232323233322232323232323233223232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323223232323223232322323253353232323232323232323232323304e3301c4912054687265616420746f6b656e206d697373696e672066726f6d20696e7075742e00330553304d301a50043035500b480094cd4c0e0030854cd4c100034854ccd400454cccccd4028418041808418441804cc140cc0792411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e005007221062106015333333500a1330503301e4911c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e00500710602106110601060221062153333335009105f13304f3301d49011c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d4914043616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f7220666972737420706c617965722773206d6f76652e0033350455052350443332001505948009402cc071401ccc075241124e4654206d757374206265206275726e742e00500621060105f105f221330513301f49011b4e6f74207369676e656420627920666972737420706c617965722e003355073301c50093355073078303d500e330513301f49110436f6d6d6974206d69736d617463682e0033036372466e28008c178004c10c03ccc144cc07d241104d697373656420646561646c696e652e003335047505433502f3039500e500d301e50095333553353332001505d001003106d1533553335001153335003106110621061153335003106110611062153335003106210611061106c106b1330513301f49011357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406d330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d24012d5365636f6e6420706c617965722773207374616b65206d697373696e6720696e2064726177206f75747075742e00330583505f301d5006303a500e13301f4901124e4654206d757374206265206275726e742e0050081330513301f4911357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406b330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d240126596f75206c6f73742c2063616e6e6f742074616b65207374616b652066726f6d2067616d652e00330583505f301d50063332001505948010c0e9403854cd4c0fc0308417c54cccccd40204178417884cc13ccc0752411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d49120466972737420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50053038500c3304f3301d4901215365636f6e6420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50043332001505748010c0e14030cc13ccc07524011357726f6e67206f757470757420646174756d2e003304f3303430415003304100d3304f3332001505a3039500335079001325335001210611061304050033304f3301d491104d697373656420646561646c696e652e003335045505233502d3037500c500a301c50073301d49011a546f6b656e206d697373696e672066726f6d206f75747075742e00330563304e301b50043036500c480084cc138cc07124011b4e6f74207369676e656420627920666972737420706c617965722e003355070301950063075303a500b3304e3301c4914143616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f72207365636f6e6420706c617965722773206d6f76652e00333504450513504333320015058480094024c06d4018cc071241124e4654206d757374206265206275726e742e005005105e22106015335303e50012100113507c4901334d6174636820726573756c7420657870656374656420627574206f757470757420646174756d20686173206e6f7468696e672e001335506e05f306f500115335335506d3355302a1200122533532323304f33033303b002303b0013304f33033303a002303a0013304f33056303800230380013304f33056303700230370013304f33056303f002303f0013304f3232350022235003225335333573466e3c0100081981944cc0e800c0044194c0dc008c0d8008cc13ccc0c8c0d4008c0d4004cc13ccc0d0c0f0008c0f0004cc13ccc158c0f4008c0f4004cc13ccc0d0c108008c108004cc0d0c10c008c10c004c0f4030c0f0cd541bc180c1c00084cd41c4008004400541c14cd4c0ac01084d400488d40048888d402c88d4008888888888888ccd54c0fc4800488d400888894cd4cc1280600104cd42280401801440154214040284c98c81f0cd5ce2481024c660007c13507a491384e6f206f7574707574206174207468697320736372697074206164647265737320686176696e672073616d6520706172616d65746572732e00221533500110022213507e49012145787065637465642065786163746c79206f6e652067616d65206f75747075742e0015335302a00321350012200113507949011347616d6520696e707574206d697373696e672e00133050330483235001222222222222008500130305006480044d400488008cccd5cd19b8735573aa00e9000119910919800801801191919191919191919191919191999ab9a3370e6aae754031200023333333333332222222222221233333333333300100d00c00b00a00900800700600500400300233502502635742a01866a04a04c6ae85402ccd409409cd5d0a805199aa814bae502835742a012666aa052eb940a0d5d0a80419a8128179aba150073335502903075a6ae854018c8c8c8cccd5cd19b8735573aa0049000119a8289919191999ab9a3370e6aae7540092000233505633503a75a6ae854008c0ecd5d09aba2500223263208f013357380c011e0211a0226aae7940044dd50009aba150023232323333573466e1cd55cea80124000466a0b066a074eb4d5d0a801181d9aba135744a004464c6411e0266ae7018023c04234044d55cf280089baa001357426ae8940088c98c822c04cd5ce02e045808448089aab9e5001137540026ae854014cd4095d71aba150043335502902c200135742a006666aa052eb88004d5d0a80118171aba135744a004464c6410e0266ae7016021c04214044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135573ca00226ea8004d5d0a803980f1aba135744a00e464c640f266ae701281e41dccccd5cd19b87500848028848888880188cccd5cd19b87500948020848888880088cccd5cd19b87500a48018848888880148cccd5cd19b87500b480108488888800c8cccd5cd19b87500c480088c8c84888888cc00402001cc134d5d09aba2500f375c6ae8540388cccd5cd19b87500d480008c84888888c01001cc134d5d09aab9e501023263207d33573809c0fa0f60f40f20f00ee0ec26664002a09e605aa00464002606aa00426664002a09c6664002a09c6058a002640026068a002640026068a002260640026666ae68cdc39aab9d500b480008cccc160c8c8c8c8c8c8c8c8c8c8c8c8cccd5cd19b8735573aa016900011999999999983218121aba1500b302435742a0146eb4d5d0a8049bad35742a0106eb4d5d0a8039919191999ab9a3370e6aae75400920002335507a375c6ae854008dd71aba135744a004464c6410a0266ae701582140420c044d55cf280089baa00135742a00c604e6ae854014dd71aba15004375a6ae85400cdd71aba15002375c6ae84d5d128011193190408099ab9c0520810107f135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226aae7940044dd50009aba1500b375c6ae854028cd4060110d5d0a80499a80c1191999ab9a3370ea0029002103111999ab9a3370ea0049001103091999ab9a3370ea0069000103191931903c99ab9c04a079077076075135573a6ea8004d5d09aba2500923263207433573808a0e80e420e626a0e292010350543500135573ca00226ea80044d55cea80109aab9e50011375400226ae8940044d5d1280089aab9e500113754002446a004444444444444a66a666aa604a24002a0484a66a666ae68cdc780700082a82a09a8370008a8368021082a882991a800911100191a80091111111111100291299a8008822899ab9c0020441232230023758002640026aa0c8446666aae7c004941688cd4164c010d5d080118019aba2002065232323333573466e1cd55cea8012400046644246600200600460166ae854008c014d5d09aba2500223263206533573806c0ca0c626aae7940044dd50009191919191999ab9a3370e6aae7540112000233332222123333001005004003002300935742a008666aa010eb9401cd5d0a8019919191999ab9a3370ea0029002119091118010021aba135573ca00646666ae68cdc3a80124004464244460020086eb8d5d09aab9e500423333573466e1d400d20002122200323263206c33573807a0d80d40d20d026aae7540044dd50009aba1500233500a75c6ae84d5d1280111931903319ab9c037066064135744a00226ae8940044d55cf280089baa0011335500175ceb44488c88c008dd5800990009aa83091191999aab9f0022505823350573355059300635573aa004600a6aae794008c010d5d100183189aba1001232323333573466e1cd55cea801240004660b060166ae854008cd4014028d5d09aba250022326320613357380640c20be26aae7940044dd500089119191999ab9a3370ea002900011a82d18029aba135573ca00646666ae68cdc3a801240044a0b4464c640c466ae700cc18818017c4d55cea80089baa001232323333573466e1d400520062321222230040053007357426aae79400c8cccd5cd19b875002480108c848888c008014c024d5d09aab9e500423333573466e1d400d20022321222230010053007357426aae7940148cccd5cd19b875004480008c848888c00c014dd71aba135573ca00c464c640c466ae700cc18818017c1781744d55cea80089baa001232323333573466e1cd55cea80124000466086600a6ae854008dd69aba135744a004464c640bc66ae700bc1781704d55cf280089baa0012323333573466e1cd55cea800a400046eb8d5d09aab9e500223263205c33573805a0b80b426ea80048c8c8c8c8c8cccd5cd19b8750014803084888888800c8cccd5cd19b875002480288488888880108cccd5cd19b875003480208cc8848888888cc004024020dd71aba15005375a6ae84d5d1280291999ab9a3370ea00890031199109111111198010048041bae35742a00e6eb8d5d09aba2500723333573466e1d40152004233221222222233006009008300c35742a0126eb8d5d09aba2500923333573466e1d40192002232122222223007008300d357426aae79402c8cccd5cd19b875007480008c848888888c014020c038d5d09aab9e500c23263206533573806c0ca0c60c40c20c00be0bc0ba26aae7540104d55cf280189aab9e5002135573ca00226ea80048c8c8c8c8cccd5cd19b875001480088ccc15cdd69aba15004375a6ae85400cdd69aba135744a00646666ae68cdc3a80124000460b260106ae84d55cf280311931902f19ab9c02f05e05c05b135573aa00626ae8940044d55cf280089baa001232323333573466e1d4005200223056375c6ae84d55cf280191999ab9a3370ea00490001182c1bae357426aae7940108c98c816ccd5ce01602d82c82c09aab9d50011375400224464646666ae68cdc3a800a40084a04a46666ae68cdc3a8012400446a04e600c6ae84d55cf280211999ab9a3370ea00690001091100111931902e19ab9c02d05c05a059058135573aa00226ea80048c8cccd5cd19b8750014800880dc8cccd5cd19b8750024800080dc8c98c8160cd5ce01482c02b02a89aab9d375400224466a03666a0386a04200406a66a03c6a04200206a640026aa0a64422444a66a00220044426600a004666aa600e2400200a00800246a002446a0044444444444446666a01a4a0b24a0b24a0b24666aa602424002a02246a00244a66a6602c00400826a0ba0062a0b801a264246600244a66a004420062002004a090640026aa0a04422444a66a00226a00644002442666a00a440046008004666aa600e2400200a00800244a66a666ae68cdc79a801110011a800910010180178999ab9a3370e6a004440026a0024400206005e205e446a004446a006446466a00a466a0084a66a666ae68cdc780100081b01a8a801881a901a919a802101a9299a999ab9a3371e00400206c06a2a006206a2a66a00642a66a0044266a004466a004466a004466a00446601a0040024070466a004407046601a00400244407044466a0084070444a66a666ae68cdc380300181d81d0a99a999ab9a3370e00a0040760742660620080022074207420662a66a00242066206644666ae68cdc780100081701691a8009111111111100291a8009111111111100311a8009111111111100411a8009111111111100491a800911100111a8009111111111100511a8009111111111100591a8009111111111100211a8009111111111100191a800911100211a8009111111111100391a800911100091a800911100191a8009111111111100111a800911111111110008919a80199a8021a80480080e99a803280400e89111a801111a801111a802911a801112999a999a8080058030010a99a8008a99a8028999a80700580180388128999a80700580180388128999a8070058018038910919800801801091091980080180109111a801111a801912999a999a8048038020010a99a8018800880f880f080f89109198008018010911191919192999a80310a999a80310a999a80410980224c26006930a999a80390980224c2600693080a08090a999a80390980224c26006930a999a80310980224c260069308098a999a80290808880908080a999a80290a999a803909802a4c26008930a999a803109802a4c2600893080988088a999a803109802a4c26008930a999a802909802a4c2600893080912999a80290a999a80390a999a80390999a8068050010008b0b0b08090a999a80310a999a80310999a8060048010008b0b0b0808880812999a80210a999a80310a999a80310999a8060048010008b0b0b08088a999a80290a999a80290999a8058040010008b0b0b0808080792999a80190a999a80290a999a80290999a8058040010008b0b0b08080a999a80210a999a80210999a8050038010008b0b0b0807880712999a80110a999a80210a999a80210999a8050038010008b0b0b08078a999a80190a999a80190999a8048030010008b0b0b08070806890911180180208911000891a80091111111003911a8009119980a00200100091299a801080088091191999ab9a3370ea0029002100c91999ab9a3370ea0049001100e11999ab9a3370ea0069000100e11931901a99ab9c006035033032031135573a6ea8005241035054310011233333333001005225335333573466e1c008004044040401854cd4ccd5cd19b890020010110101004100522333573466e2000800404404088ccd5cd19b8900200101101022333573466e2400800404004488ccd5cd19b88002001010011225335333573466e2400800404404040044008894cd4ccd5cd19b890020010110101002100112220031222002122200122333573466e1c00800403002c488cdc10010008912999a8010a999a8008805080488048a999a8008804880508048a999a80088048804880509119b8000200113222533500221533500221330050020011009153350012100910095001122533350021533350011007100610061533350011006100710061533350011006100610072333500148905506170657200488104526f636b0048810853636973736f72730012320013330020010050052223232300100532001355027223350014800088d4008894cd4ccd5cd19b8f00200900c00b130070011300600332001355026223350014800088d4008894cd4ccd5cd19b8f00200700b00a100113006003122002122001488100253353355010232323232323333333574800c46666ae68cdc39aab9d5006480008cccd55cfa8031281011999aab9f500625021233335573ea00c4a04446666aae7d40189408c8cccd55cf9aba2500725335533553355335323232323232323232323232323333333574801a46666ae68cdc39aab9d500d480008cccd55cfa8069281a11999aab9f500d25035233335573ea01a4a06c46666aae7d4034940dc8cccd55cfa8069281c11999aab9f500d25039233335573ea01a4a07446666aae7d4034940ec8cccd55cfa8069281e11999aab9f500d2503d233335573ea01a4a07c46666aae7cd5d128071299aa99aa99aa99aa99aa99aa99aa99aa99aa99aa99a98199aba150192135041302b0011503f215335303435742a032426a08460040022a0802a07e42a66a606a6ae85406084d4108c00800454100540fc854cd4c0d4d5d0a80b909a82118010008a8200a81f90a99a981a9aba1501621350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c100d5d0a80390a99a98209aba15007213504c33550480020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501521350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c8c8c8ccccccd5d200191999ab9a3370e6aae75400d2000233335573ea0064a09e46666aae7cd5d128021299a98239aba15005213505200115050250500570562504e0542504d2504d2504d2504d054135573ca00226ea8004d5d0a80390a99a981f9aba15007213504c330380020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501421350423002001150401503f215335303735742a026426a08460040022a0802a07e42a66a606a6ae85404884d4108c00800454100540fc854cd4c0dcd5d0a808909a82118010008a8200a81f90a99a981b9aba1501021350423002001150401503f2503f04604504404304204104003f03e03d03c03b2503303925032250322503225032039135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d55cf280089baa00135742a016426a04c60220022a04842a66a60386ae85402c84d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01a2502c03323333573466e1d400d2002233335573ea00a46a05c03a4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc074940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402884d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01f2502c03323333573466e1d400d2002233335573ea00a46a05c03c4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc080940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402484d409cc0080045409454090940900ac0a80a40a009c9407c094940789407894078940780944d5d1280089aba25001135744a00226aae7940044dd50008009080089a80ea491e446174756d20636f756c646e277420626520646573657269616c697365640022222222222123333333333300100c00b00a009008007006005004003002222212333300100500400300222123300100300212220031222002122200112220031222002122200123232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021280991999aab9f500425014233335573e6ae89401494cd4c02cd5d0a80390a99a99a807119191919191999999aba400623333573466e1d40092002233335573ea00c4a03e46666aae7d4018940808cccd55cfa8031281091999aab9f35744a00e4a66a602e6ae854028854cd4c060d5d0a80510a99a980c9aba1500a21350263330270030020011502415023150222502202902802702623333573466e1d400d2000233335573ea00e4a04046666aae7cd5d128041299a980b9aba150092135023302500115021250210280272501f0250242501d2501d2501d2501d024135573aa00826ae8940044d5d1280089aab9e5001137540026ae85401c84d4060cc05800800454058540549405407006c06894048060940449404494044940440604d5d1280089aab9e50011375400246666666ae900049403494034940348d4038dd68011280680a11919191999999aba400423333573466e1d40092002233335573ea0084a02246666aae7cd5d128029299a98049aba1500621350143017001150122501201901823333573466e1d400d2000233335573ea00a4a02446666aae7cd5d128031299a98051aba1500721350153019001150132501301a019250110170162500f2500f2500f2500f016135573aa00426aae7940044dd500091999999aba40012500b2500b2500b2500b23500c375c0040242446464646666666ae900108cccd5cd19b875002480008cccd55cfa8021280811999aab9f35744a00a4a66a60126ae85401884d404cd404c004540449404406005c8cccd5cd19b875003480088cccd55cfa80291a80928089280880c1280800b00a9280712807128071280700a89aab9d5002135573ca00226ea80044488c00800494ccd4d400488880084d40352411e47616d65206f757470757420646f65736e2774206861766520646174756d0021001213500e49012647616d65206f757470757420646f65736e2774206861766520646174756d20696e6c696e65640011220021221223300100400311221233001003002253353500122335002235007001250062100113500949012d4e6f205075624b65792063726564656e7469616c7320657869737420666f72207468697320616464726573732e002212330010030021212230020031122001212230020032221223330010050040032122300200321223001003123263200333573800200693090008891918008009119801980100100081" -- Just (GYScript "5a2f01c4186061b8197e6a4646d34ec8fd1f3cbdeb67fbb8ab831b25") -scriptFromCBOR :: forall v. (SingPlutusVersionI v) => Text -> Maybe (GYScript v) +scriptFromCBOR :: forall v. SingPlutusVersionI v => Text -> Maybe (GYScript v) scriptFromCBOR = scriptFromCBOR' . encodeUtf8 -- >>> scriptFromCBOR' @'PlutusV2 "59212d010000323232323322332233223232323322323232323232323332223332223232323232332232323232323232323233322232323232323233223232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323232323223232323223232322323253353232323232323232323232323304e3301c4912054687265616420746f6b656e206d697373696e672066726f6d20696e7075742e00330553304d301a50043035500b480094cd4c0e0030854cd4c100034854ccd400454cccccd4028418041808418441804cc140cc0792411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e005007221062106015333333500a1330503301e4911c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355072301b50083355072077303b500d3301e4901124e4654206d757374206265206275726e742e00500710602106110601060221062153333335009105f13304f3301d49011c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d4914043616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f7220666972737420706c617965722773206d6f76652e0033350455052350443332001505948009402cc071401ccc075241124e4654206d757374206265206275726e742e00500621060105f105f221330513301f49011b4e6f74207369676e656420627920666972737420706c617965722e003355073301c50093355073078303d500e330513301f49110436f6d6d6974206d69736d617463682e0033036372466e28008c178004c10c03ccc144cc07d241104d697373656420646561646c696e652e003335047505433502f3039500e500d301e50095333553353332001505d001003106d1533553335001153335003106110621061153335003106110611062153335003106210611061106c106b1330513301f49011357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406d330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d24012d5365636f6e6420706c617965722773207374616b65206d697373696e6720696e2064726177206f75747075742e00330583505f301d5006303a500e13301f4901124e4654206d757374206265206275726e742e0050081330513301f4911357726f6e67206f757470757420646174756d2e00330513303630435005305e001330513332001505c303b50053507b0033332001505a500406b330513301f4911a546f6b656e206d697373696e672066726f6d206f75747075742e003305833050301d50063038500e48008cc07d240126596f75206c6f73742c2063616e6e6f742074616b65207374616b652066726f6d2067616d652e00330583505f301d50063332001505948010c0e9403854cd4c0fc0308417c54cccccd40204178417884cc13ccc0752411c4e6f74207369676e6564206279207365636f6e6420706c617965722e003355071301a50073355071076303a500c3304f3301d49120466972737420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50053038500c3304f3301d4901215365636f6e6420706c617965722773207374616b65206973206d697373696e672e00330563505d301b50043332001505748010c0e14030cc13ccc07524011357726f6e67206f757470757420646174756d2e003304f3303430415003304100d3304f3332001505a3039500335079001325335001210611061304050033304f3301d491104d697373656420646561646c696e652e003335045505233502d3037500c500a301c50073301d49011a546f6b656e206d697373696e672066726f6d206f75747075742e00330563304e301b50043036500c480084cc138cc07124011b4e6f74207369676e656420627920666972737420706c617965722e003355070301950063075303a500b3304e3301c4914143616e6e6f7420636c61696d206265666f72652074696d65206475726174696f6e20676976656e20666f72207365636f6e6420706c617965722773206d6f76652e00333504450513504333320015058480094024c06d4018cc071241124e4654206d757374206265206275726e742e005005105e22106015335303e50012100113507c4901334d6174636820726573756c7420657870656374656420627574206f757470757420646174756d20686173206e6f7468696e672e001335506e05f306f500115335335506d3355302a1200122533532323304f33033303b002303b0013304f33033303a002303a0013304f33056303800230380013304f33056303700230370013304f33056303f002303f0013304f3232350022235003225335333573466e3c0100081981944cc0e800c0044194c0dc008c0d8008cc13ccc0c8c0d4008c0d4004cc13ccc0d0c0f0008c0f0004cc13ccc158c0f4008c0f4004cc13ccc0d0c108008c108004cc0d0c10c008c10c004c0f4030c0f0cd541bc180c1c00084cd41c4008004400541c14cd4c0ac01084d400488d40048888d402c88d4008888888888888ccd54c0fc4800488d400888894cd4cc1280600104cd42280401801440154214040284c98c81f0cd5ce2481024c660007c13507a491384e6f206f7574707574206174207468697320736372697074206164647265737320686176696e672073616d6520706172616d65746572732e00221533500110022213507e49012145787065637465642065786163746c79206f6e652067616d65206f75747075742e0015335302a00321350012200113507949011347616d6520696e707574206d697373696e672e00133050330483235001222222222222008500130305006480044d400488008cccd5cd19b8735573aa00e9000119910919800801801191919191919191919191919191999ab9a3370e6aae754031200023333333333332222222222221233333333333300100d00c00b00a00900800700600500400300233502502635742a01866a04a04c6ae85402ccd409409cd5d0a805199aa814bae502835742a012666aa052eb940a0d5d0a80419a8128179aba150073335502903075a6ae854018c8c8c8cccd5cd19b8735573aa0049000119a8289919191999ab9a3370e6aae7540092000233505633503a75a6ae854008c0ecd5d09aba2500223263208f013357380c011e0211a0226aae7940044dd50009aba150023232323333573466e1cd55cea80124000466a0b066a074eb4d5d0a801181d9aba135744a004464c6411e0266ae7018023c04234044d55cf280089baa001357426ae8940088c98c822c04cd5ce02e045808448089aab9e5001137540026ae854014cd4095d71aba150043335502902c200135742a006666aa052eb88004d5d0a80118171aba135744a004464c6410e0266ae7016021c04214044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135573ca00226ea8004d5d0a803980f1aba135744a00e464c640f266ae701281e41dccccd5cd19b87500848028848888880188cccd5cd19b87500948020848888880088cccd5cd19b87500a48018848888880148cccd5cd19b87500b480108488888800c8cccd5cd19b87500c480088c8c84888888cc00402001cc134d5d09aba2500f375c6ae8540388cccd5cd19b87500d480008c84888888c01001cc134d5d09aab9e501023263207d33573809c0fa0f60f40f20f00ee0ec26664002a09e605aa00464002606aa00426664002a09c6664002a09c6058a002640026068a002640026068a002260640026666ae68cdc39aab9d500b480008cccc160c8c8c8c8c8c8c8c8c8c8c8c8cccd5cd19b8735573aa016900011999999999983218121aba1500b302435742a0146eb4d5d0a8049bad35742a0106eb4d5d0a8039919191999ab9a3370e6aae75400920002335507a375c6ae854008dd71aba135744a004464c6410a0266ae701582140420c044d55cf280089baa00135742a00c604e6ae854014dd71aba15004375a6ae85400cdd71aba15002375c6ae84d5d128011193190408099ab9c0520810107f135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226aae7940044dd50009aba1500b375c6ae854028cd4060110d5d0a80499a80c1191999ab9a3370ea0029002103111999ab9a3370ea0049001103091999ab9a3370ea0069000103191931903c99ab9c04a079077076075135573a6ea8004d5d09aba2500923263207433573808a0e80e420e626a0e292010350543500135573ca00226ea80044d55cea80109aab9e50011375400226ae8940044d5d1280089aab9e500113754002446a004444444444444a66a666aa604a24002a0484a66a666ae68cdc780700082a82a09a8370008a8368021082a882991a800911100191a80091111111111100291299a8008822899ab9c0020441232230023758002640026aa0c8446666aae7c004941688cd4164c010d5d080118019aba2002065232323333573466e1cd55cea8012400046644246600200600460166ae854008c014d5d09aba2500223263206533573806c0ca0c626aae7940044dd50009191919191999ab9a3370e6aae7540112000233332222123333001005004003002300935742a008666aa010eb9401cd5d0a8019919191999ab9a3370ea0029002119091118010021aba135573ca00646666ae68cdc3a80124004464244460020086eb8d5d09aab9e500423333573466e1d400d20002122200323263206c33573807a0d80d40d20d026aae7540044dd50009aba1500233500a75c6ae84d5d1280111931903319ab9c037066064135744a00226ae8940044d55cf280089baa0011335500175ceb44488c88c008dd5800990009aa83091191999aab9f0022505823350573355059300635573aa004600a6aae794008c010d5d100183189aba1001232323333573466e1cd55cea801240004660b060166ae854008cd4014028d5d09aba250022326320613357380640c20be26aae7940044dd500089119191999ab9a3370ea002900011a82d18029aba135573ca00646666ae68cdc3a801240044a0b4464c640c466ae700cc18818017c4d55cea80089baa001232323333573466e1d400520062321222230040053007357426aae79400c8cccd5cd19b875002480108c848888c008014c024d5d09aab9e500423333573466e1d400d20022321222230010053007357426aae7940148cccd5cd19b875004480008c848888c00c014dd71aba135573ca00c464c640c466ae700cc18818017c1781744d55cea80089baa001232323333573466e1cd55cea80124000466086600a6ae854008dd69aba135744a004464c640bc66ae700bc1781704d55cf280089baa0012323333573466e1cd55cea800a400046eb8d5d09aab9e500223263205c33573805a0b80b426ea80048c8c8c8c8c8cccd5cd19b8750014803084888888800c8cccd5cd19b875002480288488888880108cccd5cd19b875003480208cc8848888888cc004024020dd71aba15005375a6ae84d5d1280291999ab9a3370ea00890031199109111111198010048041bae35742a00e6eb8d5d09aba2500723333573466e1d40152004233221222222233006009008300c35742a0126eb8d5d09aba2500923333573466e1d40192002232122222223007008300d357426aae79402c8cccd5cd19b875007480008c848888888c014020c038d5d09aab9e500c23263206533573806c0ca0c60c40c20c00be0bc0ba26aae7540104d55cf280189aab9e5002135573ca00226ea80048c8c8c8c8cccd5cd19b875001480088ccc15cdd69aba15004375a6ae85400cdd69aba135744a00646666ae68cdc3a80124000460b260106ae84d55cf280311931902f19ab9c02f05e05c05b135573aa00626ae8940044d55cf280089baa001232323333573466e1d4005200223056375c6ae84d55cf280191999ab9a3370ea00490001182c1bae357426aae7940108c98c816ccd5ce01602d82c82c09aab9d50011375400224464646666ae68cdc3a800a40084a04a46666ae68cdc3a8012400446a04e600c6ae84d55cf280211999ab9a3370ea00690001091100111931902e19ab9c02d05c05a059058135573aa00226ea80048c8cccd5cd19b8750014800880dc8cccd5cd19b8750024800080dc8c98c8160cd5ce01482c02b02a89aab9d375400224466a03666a0386a04200406a66a03c6a04200206a640026aa0a64422444a66a00220044426600a004666aa600e2400200a00800246a002446a0044444444444446666a01a4a0b24a0b24a0b24666aa602424002a02246a00244a66a6602c00400826a0ba0062a0b801a264246600244a66a004420062002004a090640026aa0a04422444a66a00226a00644002442666a00a440046008004666aa600e2400200a00800244a66a666ae68cdc79a801110011a800910010180178999ab9a3370e6a004440026a0024400206005e205e446a004446a006446466a00a466a0084a66a666ae68cdc780100081b01a8a801881a901a919a802101a9299a999ab9a3371e00400206c06a2a006206a2a66a00642a66a0044266a004466a004466a004466a00446601a0040024070466a004407046601a00400244407044466a0084070444a66a666ae68cdc380300181d81d0a99a999ab9a3370e00a0040760742660620080022074207420662a66a00242066206644666ae68cdc780100081701691a8009111111111100291a8009111111111100311a8009111111111100411a8009111111111100491a800911100111a8009111111111100511a8009111111111100591a8009111111111100211a8009111111111100191a800911100211a8009111111111100391a800911100091a800911100191a8009111111111100111a800911111111110008919a80199a8021a80480080e99a803280400e89111a801111a801111a802911a801112999a999a8080058030010a99a8008a99a8028999a80700580180388128999a80700580180388128999a8070058018038910919800801801091091980080180109111a801111a801912999a999a8048038020010a99a8018800880f880f080f89109198008018010911191919192999a80310a999a80310a999a80410980224c26006930a999a80390980224c2600693080a08090a999a80390980224c26006930a999a80310980224c260069308098a999a80290808880908080a999a80290a999a803909802a4c26008930a999a803109802a4c2600893080988088a999a803109802a4c26008930a999a802909802a4c2600893080912999a80290a999a80390a999a80390999a8068050010008b0b0b08090a999a80310a999a80310999a8060048010008b0b0b0808880812999a80210a999a80310a999a80310999a8060048010008b0b0b08088a999a80290a999a80290999a8058040010008b0b0b0808080792999a80190a999a80290a999a80290999a8058040010008b0b0b08080a999a80210a999a80210999a8050038010008b0b0b0807880712999a80110a999a80210a999a80210999a8050038010008b0b0b08078a999a80190a999a80190999a8048030010008b0b0b08070806890911180180208911000891a80091111111003911a8009119980a00200100091299a801080088091191999ab9a3370ea0029002100c91999ab9a3370ea0049001100e11999ab9a3370ea0069000100e11931901a99ab9c006035033032031135573a6ea8005241035054310011233333333001005225335333573466e1c008004044040401854cd4ccd5cd19b890020010110101004100522333573466e2000800404404088ccd5cd19b8900200101101022333573466e2400800404004488ccd5cd19b88002001010011225335333573466e2400800404404040044008894cd4ccd5cd19b890020010110101002100112220031222002122200122333573466e1c00800403002c488cdc10010008912999a8010a999a8008805080488048a999a8008804880508048a999a80088048804880509119b8000200113222533500221533500221330050020011009153350012100910095001122533350021533350011007100610061533350011006100710061533350011006100610072333500148905506170657200488104526f636b0048810853636973736f72730012320013330020010050052223232300100532001355027223350014800088d4008894cd4ccd5cd19b8f00200900c00b130070011300600332001355026223350014800088d4008894cd4ccd5cd19b8f00200700b00a100113006003122002122001488100253353355010232323232323333333574800c46666ae68cdc39aab9d5006480008cccd55cfa8031281011999aab9f500625021233335573ea00c4a04446666aae7d40189408c8cccd55cf9aba2500725335533553355335323232323232323232323232323333333574801a46666ae68cdc39aab9d500d480008cccd55cfa8069281a11999aab9f500d25035233335573ea01a4a06c46666aae7d4034940dc8cccd55cfa8069281c11999aab9f500d25039233335573ea01a4a07446666aae7d4034940ec8cccd55cfa8069281e11999aab9f500d2503d233335573ea01a4a07c46666aae7cd5d128071299aa99aa99aa99aa99aa99aa99aa99aa99aa99aa99a98199aba150192135041302b0011503f215335303435742a032426a08460040022a0802a07e42a66a606a6ae85406084d4108c00800454100540fc854cd4c0d4d5d0a80b909a82118010008a8200a81f90a99a981a9aba1501621350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c100d5d0a80390a99a98209aba15007213504c33550480020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501521350423002001150401503f215335323232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021282391999aab9f500425048233335573e6ae89401494cd4c8c8c8ccccccd5d200191999ab9a3370e6aae75400d2000233335573ea0064a09e46666aae7cd5d128021299a98239aba15005213505200115050250500570562504e0542504d2504d2504d2504d054135573ca00226ea8004d5d0a80390a99a981f9aba15007213504c330380020011504a150492504905004f04e2504604c2504525045250452504504c135744a00226aae7940044dd50009aba1501421350423002001150401503f215335303735742a026426a08460040022a0802a07e42a66a606a6ae85404884d4108c00800454100540fc854cd4c0dcd5d0a808909a82118010008a8200a81f90a99a981b9aba1501021350423002001150401503f2503f04604504404304204104003f03e03d03c03b2503303925032250322503225032039135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d55cf280089baa00135742a016426a04c60220022a04842a66a60386ae85402c84d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01a2502c03323333573466e1d400d2002233335573ea00a46a05c03a4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc074940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402884d409cc0080045409454090854cd4cd40748c8c8c8ccccccd5d200211999ab9a3370ea004900211999aab9f500423502d01f2502c03323333573466e1d400d2002233335573ea00a46a05c03c4a05a06846666ae68cdc3a8022400046666aae7d40188d40bc080940b80d4940b40cc0c80c4940a8940a8940a8940a80c44d55cea80109aab9e5001137540026ae85402484d409cc0080045409454090940900ac0a80a40a009c9407c094940789407894078940780944d5d1280089aba25001135744a00226aae7940044dd50008009080089a80ea491e446174756d20636f756c646e277420626520646573657269616c697365640022222222222123333333333300100c00b00a009008007006005004003002222212333300100500400300222123300100300212220031222002122200112220031222002122200123232323333333574800846666ae68cdc39aab9d5004480008cccd55cfa8021280991999aab9f500425014233335573e6ae89401494cd4c02cd5d0a80390a99a99a807119191919191999999aba400623333573466e1d40092002233335573ea00c4a03e46666aae7d4018940808cccd55cfa8031281091999aab9f35744a00e4a66a602e6ae854028854cd4c060d5d0a80510a99a980c9aba1500a21350263330270030020011502415023150222502202902802702623333573466e1d400d2000233335573ea00e4a04046666aae7cd5d128041299a980b9aba150092135023302500115021250210280272501f0250242501d2501d2501d2501d024135573aa00826ae8940044d5d1280089aab9e5001137540026ae85401c84d4060cc05800800454058540549405407006c06894048060940449404494044940440604d5d1280089aab9e50011375400246666666ae900049403494034940348d4038dd68011280680a11919191999999aba400423333573466e1d40092002233335573ea0084a02246666aae7cd5d128029299a98049aba1500621350143017001150122501201901823333573466e1d400d2000233335573ea00a4a02446666aae7cd5d128031299a98051aba1500721350153019001150132501301a019250110170162500f2500f2500f2500f016135573aa00426aae7940044dd500091999999aba40012500b2500b2500b2500b23500c375c0040242446464646666666ae900108cccd5cd19b875002480008cccd55cfa8021280811999aab9f35744a00a4a66a60126ae85401884d404cd404c004540449404406005c8cccd5cd19b875003480088cccd55cfa80291a80928089280880c1280800b00a9280712807128071280700a89aab9d5002135573ca00226ea80044488c00800494ccd4d400488880084d40352411e47616d65206f757470757420646f65736e2774206861766520646174756d0021001213500e49012647616d65206f757470757420646f65736e2774206861766520646174756d20696e6c696e65640011220021221223300100400311221233001003002253353500122335002235007001250062100113500949012d4e6f205075624b65792063726564656e7469616c7320657869737420666f72207468697320616464726573732e002212330010030021212230020031122001212230020032221223330010050040032122300200321223001003123263200333573800200693090008891918008009119801980100100081" -- Just (GYScript "5a2f01c4186061b8197e6a4646d34ec8fd1f3cbdeb67fbb8ab831b25") -scriptFromCBOR' :: forall v. (SingPlutusVersionI v) => ByteString -> Maybe (GYScript v) +scriptFromCBOR' :: forall v. SingPlutusVersionI v => ByteString -> Maybe (GYScript v) scriptFromCBOR' b = do bs <- rightToMaybe (BS16.decode b) case singPlutusVersion @v of @@ -820,7 +820,7 @@ scriptToApiPlutusScriptWitness (GYScript v api _) = case v of (Api.S.PScript api) referenceScriptToApiPlutusScriptWitness :: - (VersionIsGreaterOrEqual v 'PlutusV2) => + VersionIsGreaterOrEqual v 'PlutusV2 => GYTxOutRef -> GYScript v -> Api.S.ScriptDatum witctx -> @@ -842,7 +842,7 @@ writeScript :: forall v. FilePath -> GYScript v -> IO () writeScript = writeScriptCore "Script" -- | Reads a script from a file. -readScript :: forall v. (SingPlutusVersionI v) => FilePath -> IO (GYScript v) +readScript :: forall v. SingPlutusVersionI v => FilePath -> IO (GYScript v) readScript file = case singPlutusVersion @v of SingPlutusV1 -> do e <- Api.readFileTextEnvelope (Api.AsPlutusScript Api.AsPlutusScriptV1) (Api.File file) @@ -894,12 +894,12 @@ hashAnyScript (GYPlutusScript s) = hashScript s anyScriptToApiScriptInEra :: GYAnyScript -> Api.ScriptInEra ApiEra anyScriptToApiScriptInEra (GYPlutusScript s@(GYScript v _ _)) = Api.ScriptInEra scriptInLanguageEra (scriptToApiScript s) - where - scriptInLanguageEra = case singPlutusVersionToApi v of - Api.PlutusScriptV1 -> Api.PlutusScriptV1InConway - Api.PlutusScriptV2 -> Api.PlutusScriptV2InConway - Api.PlutusScriptV3 -> Api.PlutusScriptV3InConway - - scriptToApiScript :: GYScript v -> Api.Script (PlutusVersionToApi v) - scriptToApiScript (GYScript v' api _) = Api.PlutusScript (singPlutusVersionToApi v') api + where + scriptInLanguageEra = case singPlutusVersionToApi v of + Api.PlutusScriptV1 -> Api.PlutusScriptV1InConway + Api.PlutusScriptV2 -> Api.PlutusScriptV2InConway + Api.PlutusScriptV3 -> Api.PlutusScriptV3InConway + + scriptToApiScript :: GYScript v -> Api.Script (PlutusVersionToApi v) + scriptToApiScript (GYScript v' api _) = Api.PlutusScript (singPlutusVersionToApi v') api anyScriptToApiScriptInEra (GYSimpleScript s) = Api.ScriptInEra Api.SimpleScriptInConway (Api.SimpleScript $ simpleScriptToApi s) diff --git a/src/GeniusYield/Types/Script/SimpleScript.hs b/src/GeniusYield/Types/Script/SimpleScript.hs index c70ad6d2..fcc92914 100644 --- a/src/GeniusYield/Types/Script/SimpleScript.hs +++ b/src/GeniusYield/Types/Script/SimpleScript.hs @@ -113,8 +113,8 @@ getTotalKeysInSimpleScript = \case RequireAllOf ss -> f ss RequireAnyOf ss -> f ss RequireMOf _ ss -> f ss - where - f = foldMap' getTotalKeysInSimpleScript + where + f = foldMap' getTotalKeysInSimpleScript hashSimpleScript :: GYSimpleScript -> GYScriptHash hashSimpleScript = scriptHashFromApi . hashSimpleScript' diff --git a/src/GeniusYield/Types/Slot.hs b/src/GeniusYield/Types/Slot.hs index f239baf0..c7f0fac4 100644 --- a/src/GeniusYield/Types/Slot.hs +++ b/src/GeniusYield/Types/Slot.hs @@ -63,9 +63,9 @@ advanceSlot :: GYSlot -> Natural -> Maybe GYSlot advanceSlot (GYSlot s) t | st > fromIntegral (maxBound :: Word64) = Nothing | otherwise = Just (GYSlot (fromIntegral st)) - where - st :: Natural - st = fromIntegral s + t + where + st :: Natural + st = fromIntegral s + t -- | Unsafe advance 'GYSlot'. Doesn't check for the overflow. unsafeAdvanceSlot :: GYSlot -> Natural -> GYSlot diff --git a/src/GeniusYield/Types/SlotConfig.hs b/src/GeniusYield/Types/SlotConfig.hs index a5f78695..88b82536 100644 --- a/src/GeniusYield/Types/SlotConfig.hs +++ b/src/GeniusYield/Types/SlotConfig.hs @@ -110,28 +110,28 @@ This is the recommended, robust, way to create slot config. -} makeSlotConfig :: CSlot.SystemStart -> Api.EraHistory -> Either String GYSlotConfig makeSlotConfig sysStart eraHist = GYSlotConfig sysStart <$!> simplifiedEraSumms - where - simplifiedEraSumms :: Either String (NonEmpty GYEraSlotConfig) - !simplifiedEraSumms = case extractEraSummaries eraHist of - -- This pattern match ensures the summaries start with the very first era (Bound should be all 0). - summ@(Ouroboros.Summary eraSumms@(Ouroboros.NonEmptyCons Ouroboros.EraSummary {eraStart = FirstEraBound} _)) -> - -- Verify the rest of the invariants. - runExcept (invariantSummary summ) - -- Convert the summaries into a collection of 'GYEraSlotConfig'. - $> (toEraSlotConf <$!> toNonEmpty eraSumms) - _ -> - Left $! - "Initial era element within given EraHistory must be the very first ledger era" - ++ " (Era Start bound should be 0)" - toEraSlotConf :: Ouroboros.EraSummary -> GYEraSlotConfig - toEraSlotConf - Ouroboros.EraSummary - { eraStart = Ouroboros.Bound {boundTime, boundSlot} - , eraParams = Ouroboros.EraParams {eraSlotLength} - } = GYEraSlotConfig {gyEraSlotStart = slotFromApi boundSlot, gyEraSlotLength = eraSlotLength, gyEraSlotZeroTime = boundTime} - toNonEmpty :: Ouroboros.NonEmpty xs a -> NonEmpty a - toNonEmpty (Ouroboros.NonEmptyOne x) = x :| [] - toNonEmpty (Ouroboros.NonEmptyCons x xs) = x :| toList xs + where + simplifiedEraSumms :: Either String (NonEmpty GYEraSlotConfig) + !simplifiedEraSumms = case extractEraSummaries eraHist of + -- This pattern match ensures the summaries start with the very first era (Bound should be all 0). + summ@(Ouroboros.Summary eraSumms@(Ouroboros.NonEmptyCons Ouroboros.EraSummary {eraStart = FirstEraBound} _)) -> + -- Verify the rest of the invariants. + runExcept (invariantSummary summ) + -- Convert the summaries into a collection of 'GYEraSlotConfig'. + $> (toEraSlotConf <$!> toNonEmpty eraSumms) + _ -> + Left $! + "Initial era element within given EraHistory must be the very first ledger era" + ++ " (Era Start bound should be 0)" + toEraSlotConf :: Ouroboros.EraSummary -> GYEraSlotConfig + toEraSlotConf + Ouroboros.EraSummary + { eraStart = Ouroboros.Bound {boundTime, boundSlot} + , eraParams = Ouroboros.EraParams {eraSlotLength} + } = GYEraSlotConfig {gyEraSlotStart = slotFromApi boundSlot, gyEraSlotLength = eraSlotLength, gyEraSlotZeroTime = boundTime} + toNonEmpty :: Ouroboros.NonEmpty xs a -> NonEmpty a + toNonEmpty (Ouroboros.NonEmptyOne x) = x :| [] + toNonEmpty (Ouroboros.NonEmptyCons x xs) = x :| toList xs -- The era start bound for the very first era. pattern FirstEraBound :: Ouroboros.Bound @@ -165,21 +165,21 @@ slotToBeginPOSIXTime' (GYSlotConfig sysStart slotConfs) slot = -- SystemStart + relativeResult $ CSlot.fromRelativeTime sysStart relativeResult - where - -- slotZeroTime + (slot - startSlotNo) * slotLength - relativeResult = - CSlot.getSlotLength gyEraSlotLength - `CSlot.multNominalDiffTime` (slotToInteger slot - slotToInteger gyEraSlotStart) - `CSlot.addRelativeTime` gyEraSlotZeroTime - GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs - {- Finds the slot config for the given slot. Essentially, the chosen slot config must have its starting slot - less than, or equal to, the given slot. Furthermore, the chosen slot config's end slot, i.e next slot config's - starting slot (or unbounded if final era), should be greater than the given slot. - -} - findSlotConf (x :| []) = x - findSlotConf - (thisSlotConf@GYEraSlotConfig {gyEraSlotStart = startSlot} :| nextSlotConf@GYEraSlotConfig {gyEraSlotStart = endSlot} : rest) = - if slot >= startSlot && slot < endSlot then thisSlotConf else findSlotConf $ nextSlotConf :| rest + where + -- slotZeroTime + (slot - startSlotNo) * slotLength + relativeResult = + CSlot.getSlotLength gyEraSlotLength + `CSlot.multNominalDiffTime` (slotToInteger slot - slotToInteger gyEraSlotStart) + `CSlot.addRelativeTime` gyEraSlotZeroTime + GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs + {- Finds the slot config for the given slot. Essentially, the chosen slot config must have its starting slot + less than, or equal to, the given slot. Furthermore, the chosen slot config's end slot, i.e next slot config's + starting slot (or unbounded if final era), should be greater than the given slot. + -} + findSlotConf (x :| []) = x + findSlotConf + (thisSlotConf@GYEraSlotConfig {gyEraSlotStart = startSlot} :| nextSlotConf@GYEraSlotConfig {gyEraSlotStart = endSlot} : rest) = + if slot >= startSlot && slot < endSlot then thisSlotConf else findSlotConf $ nextSlotConf :| rest {- | Get the ending 'GYTime' of a 'GYSlot' (inclusive) given a 'GYSlotConfig'. @@ -189,9 +189,9 @@ GYTime 13.999s slotToEndTimePure :: GYSlotConfig -> GYSlot -> GYTime slotToEndTimePure sc@(GYSlotConfig _ _) slot = timeFromPOSIX $ slotToBeginPOSIXTime' sc (unsafeAdvanceSlot slot 1) - oneMs - where - oneMs :: Time.NominalDiffTime - oneMs = 0.001 + where + oneMs :: Time.NominalDiffTime + oneMs = 0.001 {- | Get the 'GYSlot' of a 'GYTime' given a 'GYSlotConfig'. @@ -209,24 +209,24 @@ enclosingSlotFromTimePure (GYSlotConfig sysStart slotConfs) (timeToPOSIX -> absT | otherwise = -- startSlotNo + relativeResult Just . slotFromApi . Ouroboros.addSlots relativeResult $ slotToApi gyEraSlotStart - where - absTimeUtc = Time.posixSecondsToUTCTime absTime - -- absTime - SystemStart - relTime = CSlot.toRelativeTime sysStart absTimeUtc - -- (relTime - slotZeroTime) / slotLength - relativeResult = (relTime `CSlot.diffRelativeTime` gyEraSlotZeroTime) `div'` CSlot.getSlotLength gyEraSlotLength - GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs - {- Finds the slot config for the given relative time. Essentially, the chosen slot config must have its starting time - greater than, or equal to, the given relative time. Furthermore, the chosen slot config's end time, i.e next slot config's - starting time (or unbounded if final era), should be greater than the given relative time. - -} - findSlotConf (x :| []) = x - findSlotConf - ( thisSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = startTime} - :| nextSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = endTime} - : rest - ) = - if relTime >= startTime && relTime < endTime then thisSlotConf else findSlotConf $ nextSlotConf :| rest + where + absTimeUtc = Time.posixSecondsToUTCTime absTime + -- absTime - SystemStart + relTime = CSlot.toRelativeTime sysStart absTimeUtc + -- (relTime - slotZeroTime) / slotLength + relativeResult = (relTime `CSlot.diffRelativeTime` gyEraSlotZeroTime) `div'` CSlot.getSlotLength gyEraSlotLength + GYEraSlotConfig {gyEraSlotZeroTime, gyEraSlotStart, gyEraSlotLength} = findSlotConf slotConfs + {- Finds the slot config for the given relative time. Essentially, the chosen slot config must have its starting time + greater than, or equal to, the given relative time. Furthermore, the chosen slot config's end time, i.e next slot config's + starting time (or unbounded if final era), should be greater than the given relative time. + -} + findSlotConf (x :| []) = x + findSlotConf + ( thisSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = startTime} + :| nextSlotConf@GYEraSlotConfig {gyEraSlotZeroTime = endTime} + : rest + ) = + if relTime >= startTime && relTime < endTime then thisSlotConf else findSlotConf $ nextSlotConf :| rest -- | Partial version of 'enclosingSlotFromTimePure'. unsafeEnclosingSlotFromTimePure :: GYSlotConfig -> GYTime -> GYSlot @@ -249,66 +249,66 @@ invariantSummary :: Ouroboros.Summary xs -> Except String () invariantSummary = \(Ouroboros.Summary summary) -> -- Pretend the start of the first era is the "end of the previous" one go (Ouroboros.eraStart (Ouroboros.nonEmptyHead summary)) (toList summary) - where - go :: - Ouroboros.Bound -> - -- \^ End of the previous era - [Ouroboros.EraSummary] -> - Except String () - go _ [] = return () - go prevEnd (curSummary : next) = do - unless (curStart == prevEnd) $ - throwError $ - mconcat - [ "Bounds don't line up: end of previous era " - , show prevEnd - , " /= start of current era " - , show curStart - ] - - case mCurEnd of - Ouroboros.EraUnbounded -> - unless (null next) $ - throwError "Unbounded non-final era" - Ouroboros.EraEnd curEnd -> do - -- Check the invariants mentioned at 'EraSummary' - -- - -- o @epochsInEra@ corresponds to @e' - e@ - -- o @slotsInEra@ corresponds to @(e' - e) * epochSize)@ - -- o @timeInEra@ corresponds to @((e' - e) * epochSize * slotLen@ - -- which, if INV-1b holds, equals @(s' - s) * slotLen@ - let epochsInEra, slotsInEra :: Word64 - epochsInEra = Ouroboros.countEpochs (Ouroboros.boundEpoch curEnd) (Ouroboros.boundEpoch curStart) - slotsInEra = epochsInEra * CSlot.unEpochSize (Ouroboros.eraEpochSize curParams) - - timeInEra :: NominalDiffTime - timeInEra = - fromIntegral slotsInEra - * CSlot.getSlotLength (Ouroboros.eraSlotLength curParams) - - -- NOTE: The only change is here, using >= rather than > - unless (Ouroboros.boundEpoch curEnd >= Ouroboros.boundEpoch curStart) $ - throwError "Empty era" - - unless (Ouroboros.boundSlot curEnd == Ouroboros.addSlots slotsInEra (Ouroboros.boundSlot curStart)) $ - throwError $ - mconcat - [ "Invalid final boundSlot in " - , show curSummary - , " (INV-1b)" - ] - - unless (Ouroboros.boundTime curEnd == Ouroboros.addRelTime timeInEra (Ouroboros.boundTime curStart)) $ - throwError $ - mconcat - [ "Invalid final boundTime in " - , show curSummary - , " (INV-2b)" - ] - - go curEnd next - where - curStart :: Ouroboros.Bound - mCurEnd :: Ouroboros.EraEnd - curParams :: Ouroboros.EraParams - Ouroboros.EraSummary curStart mCurEnd curParams = curSummary + where + go :: + Ouroboros.Bound -> + -- \^ End of the previous era + [Ouroboros.EraSummary] -> + Except String () + go _ [] = return () + go prevEnd (curSummary : next) = do + unless (curStart == prevEnd) $ + throwError $ + mconcat + [ "Bounds don't line up: end of previous era " + , show prevEnd + , " /= start of current era " + , show curStart + ] + + case mCurEnd of + Ouroboros.EraUnbounded -> + unless (null next) $ + throwError "Unbounded non-final era" + Ouroboros.EraEnd curEnd -> do + -- Check the invariants mentioned at 'EraSummary' + -- + -- o @epochsInEra@ corresponds to @e' - e@ + -- o @slotsInEra@ corresponds to @(e' - e) * epochSize)@ + -- o @timeInEra@ corresponds to @((e' - e) * epochSize * slotLen@ + -- which, if INV-1b holds, equals @(s' - s) * slotLen@ + let epochsInEra, slotsInEra :: Word64 + epochsInEra = Ouroboros.countEpochs (Ouroboros.boundEpoch curEnd) (Ouroboros.boundEpoch curStart) + slotsInEra = epochsInEra * CSlot.unEpochSize (Ouroboros.eraEpochSize curParams) + + timeInEra :: NominalDiffTime + timeInEra = + fromIntegral slotsInEra + * CSlot.getSlotLength (Ouroboros.eraSlotLength curParams) + + -- NOTE: The only change is here, using >= rather than > + unless (Ouroboros.boundEpoch curEnd >= Ouroboros.boundEpoch curStart) $ + throwError "Empty era" + + unless (Ouroboros.boundSlot curEnd == Ouroboros.addSlots slotsInEra (Ouroboros.boundSlot curStart)) $ + throwError $ + mconcat + [ "Invalid final boundSlot in " + , show curSummary + , " (INV-1b)" + ] + + unless (Ouroboros.boundTime curEnd == Ouroboros.addRelTime timeInEra (Ouroboros.boundTime curStart)) $ + throwError $ + mconcat + [ "Invalid final boundTime in " + , show curSummary + , " (INV-2b)" + ] + + go curEnd next + where + curStart :: Ouroboros.Bound + mCurEnd :: Ouroboros.EraEnd + curParams :: Ouroboros.EraParams + Ouroboros.EraSummary curStart mCurEnd curParams = curSummary diff --git a/src/GeniusYield/Types/StakeKeyHash.hs b/src/GeniusYield/Types/StakeKeyHash.hs index 0a4cafd2..e6259674 100644 --- a/src/GeniusYield/Types/StakeKeyHash.hs +++ b/src/GeniusYield/Types/StakeKeyHash.hs @@ -43,7 +43,7 @@ import Text.Printf qualified as Printf -} newtype GYStakeKeyHash = GYStakeKeyHash (Api.Hash Api.StakeKey) - deriving stock (Show) + deriving stock Show deriving newtype (Eq, Ord, IsString) instance AsPubKeyHash GYStakeKeyHash where diff --git a/src/GeniusYield/Types/Time.hs b/src/GeniusYield/Types/Time.hs index 1169c776..695b8f2d 100644 --- a/src/GeniusYield/Types/Time.hs +++ b/src/GeniusYield/Types/Time.hs @@ -162,7 +162,7 @@ Just (GYTime 33.333s) >>> gyIso8601ParseM @Maybe "1970-01-01T00:00:33.333" Nothing -} -gyIso8601ParseM :: (MonadFail m) => String -> m GYTime +gyIso8601ParseM :: MonadFail m => String -> m GYTime gyIso8601ParseM = fmap (GYTime . Time.utcTimeToPOSIXSeconds) . Time.iso8601ParseM {- | diff --git a/src/GeniusYield/Types/Tx.hs b/src/GeniusYield/Types/Tx.hs index fc739420..83e4f0b6 100644 --- a/src/GeniusYield/Types/Tx.hs +++ b/src/GeniusYield/Types/Tx.hs @@ -187,13 +187,13 @@ writeTx file tx = do Right () -> pure () data PlutusTxId (v :: PlutusVersion) where - PlutusTxIdBeforeV3 :: (PlutusV3 `VersionIsGreater` v) => PlutusV1.TxId -> PlutusTxId v + PlutusTxIdBeforeV3 :: PlutusV3 `VersionIsGreater` v => PlutusV1.TxId -> PlutusTxId v PlutusTxIdV3 :: PlutusV3.TxId -> PlutusTxId 'PlutusV3 -- | Transaction hash/id of a particular transaction. newtype GYTxId = GYTxId Api.TxId deriving (Eq, Ord) - deriving newtype (FromJSON) -- TODO: Also derive ToJSON? + deriving newtype FromJSON -- TODO: Also derive ToJSON? instance PQ.ToField GYTxId where toField (GYTxId txId) = PQ.toField (PQ.Binary (Api.serialiseToRawBytes txId)) @@ -278,7 +278,7 @@ txIdFromPlutus (PlutusTxIdV3 (PlutusV3.TxId (Plutus.BuiltinByteString bs))) = tx -- | Wrapper around transaction witness set. Note that Babbage ledger also uses the same @TxWitness@ type defined in Alonzo ledger, which was updated for Plutus-V2 scripts and same is expected for Plutus-V3. newtype GYTxWitness = GYTxWitness (AlonzoTxWits (Conway.ConwayEra Crypto.StandardCrypto)) - deriving newtype (Show) + deriving newtype Show instance Swagger.ToSchema GYTxWitness where declareNamedSchema _ = diff --git a/src/GeniusYield/Types/TxBody.hs b/src/GeniusYield/Types/TxBody.hs index 61bc8313..6eed7d14 100644 --- a/src/GeniusYield/Types/TxBody.hs +++ b/src/GeniusYield/Types/TxBody.hs @@ -71,7 +71,7 @@ import GeniusYield.Types.Value -- | Transaction body: the part which is then signed. newtype GYTxBody = GYTxBody (Api.TxBody ApiEra) - deriving (Show) + deriving Show txBodyFromApi :: Api.TxBody ApiEra -> GYTxBody txBodyFromApi = coerce @@ -80,11 +80,11 @@ txBodyToApi :: GYTxBody -> Api.TxBody ApiEra txBodyToApi = coerce -- | Sign a transaction body with (potentially) multiple keys. -signGYTxBody :: (ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> GYTx +signGYTxBody :: ToShelleyWitnessSigningKey a => GYTxBody -> [a] -> GYTx signGYTxBody = signTx {-# DEPRECATED signTx "Use signGYTxBody." #-} -signTx :: (ToShelleyWitnessSigningKey a) => GYTxBody -> [a] -> GYTx +signTx :: ToShelleyWitnessSigningKey a => GYTxBody -> [a] -> GYTx signTx (GYTxBody txBody) skeys = txFromApi $ Api.signShelleyTransaction @@ -120,7 +120,7 @@ appendWitnessGYTx' appendKeyWitnessList previousTx = in makeSignedTransaction' (previousKeyWitnessesList ++ appendKeyWitnessList) txBody -- | Sign a transaction with (potentially) multiple keys and add your witness(s) among previous key witnesses, if any. -signGYTx :: (ToShelleyWitnessSigningKey a) => GYTx -> [a] -> GYTx +signGYTx :: ToShelleyWitnessSigningKey a => GYTx -> [a] -> GYTx signGYTx previousTx skeys = signGYTx'' previousTx $ map toShelleyWitnessSigningKey skeys -- | Sign a transaction with (potentially) multiple keys and add your witness(s) among previous key witnesses, if any. @@ -179,11 +179,11 @@ txBodyFeeValue = valueFromLovelace . txBodyFee txBodyUTxOs :: GYTxBody -> GYUTxOs txBodyUTxOs (GYTxBody body@(Api.TxBody Api.TxBodyContent {txOuts})) = utxosFromList $ zipWith f [0 ..] txOuts - where - txId = Api.getTxId body + where + txId = Api.getTxId body - f :: Word -> Api.TxOut Api.CtxTx ApiEra -> GYUTxO - f i = utxoFromApi (Api.TxIn txId (Api.TxIx i)) + f :: Word -> Api.TxOut Api.CtxTx ApiEra -> GYUTxO + f i = utxoFromApi (Api.TxIn txId (Api.TxIx i)) -- | Returns the 'GYTxOutRef' consumed by the tx. txBodyTxIns :: GYTxBody -> [GYTxOutRef] @@ -224,14 +224,14 @@ txBodyValidityRange body = let cnt = txBodyToApiTxBodyContent body in case (Api.txValidityLowerBound cnt, Api.txValidityUpperBound cnt) of (lb, ub) -> (f lb, g ub) - where - f :: Api.TxValidityLowerBound ApiEra -> Maybe GYSlot - f Api.TxValidityNoLowerBound = Nothing - f (Api.TxValidityLowerBound _ sn) = Just $ slotFromApi sn - - g :: Api.TxValidityUpperBound ApiEra -> Maybe GYSlot - g (Api.TxValidityUpperBound _ Nothing) = Nothing - g (Api.TxValidityUpperBound _ (Just sn)) = Just $ slotFromApi sn + where + f :: Api.TxValidityLowerBound ApiEra -> Maybe GYSlot + f Api.TxValidityNoLowerBound = Nothing + f (Api.TxValidityLowerBound _ sn) = Just $ slotFromApi sn + + g :: Api.TxValidityUpperBound ApiEra -> Maybe GYSlot + g (Api.TxValidityUpperBound _ Nothing) = Nothing + g (Api.TxValidityUpperBound _ (Just sn)) = Just $ slotFromApi sn -- | Returns the set of 'GYTxOutRef' used as collateral in the given 'GYTxBody'. txBodyCollateral :: GYTxBody -> Set GYTxOutRef diff --git a/src/GeniusYield/Types/TxCert/Internal.hs b/src/GeniusYield/Types/TxCert/Internal.hs index 3e8b0205..296cf732 100644 --- a/src/GeniusYield/Types/TxCert/Internal.hs +++ b/src/GeniusYield/Types/TxCert/Internal.hs @@ -57,12 +57,12 @@ txCertToApi :: GYTxCert' v -> (Api.Certificate ApiEra, Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake ApiEra)) txCertToApi (GYTxCert' cert wit) = (certificateToApi cert, wit <&> (\wit' -> (certificateToStakeCredential cert & stakeCredentialToApi, f wit'))) - where - f :: GYTxCertWitness v -> Api.Witness Api.WitCtxStake ApiEra - f GYTxCertWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr - f (GYTxCertWitnessScript v r) = - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - gyStakeValScriptWitnessToApiPlutusSW - v - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + where + f :: GYTxCertWitness v -> Api.Witness Api.WitCtxStake ApiEra + f GYTxCertWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr + f (GYTxCertWitnessScript v r) = + Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ + gyStakeValScriptWitnessToApiPlutusSW + v + (redeemerToApi r) + (Api.ExecutionUnits 0 0) diff --git a/src/GeniusYield/Types/TxIn.hs b/src/GeniusYield/Types/TxIn.hs index bfd7b018..620c92c9 100644 --- a/src/GeniusYield/Types/TxIn.hs +++ b/src/GeniusYield/Types/TxIn.hs @@ -51,9 +51,9 @@ data GYTxInWitness v data GYInScript (u :: PlutusVersion) where -- | 'VersionIsGreaterOrEqual' restricts which version validators can be used in this transaction. - GYInScript :: forall u v. (v `VersionIsGreaterOrEqual` u) => GYValidator v -> GYInScript u + GYInScript :: forall u v. v `VersionIsGreaterOrEqual` u => GYValidator v -> GYInScript u -- | Reference inputs can be only used in V2 transactions. - GYInReference :: forall v. (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYInScript v + GYInReference :: forall v. v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYInScript v -- | Returns the 'PlutusVersion' of the given 'GYInScript'. inScriptVersion :: GYInScript v -> PlutusVersion @@ -74,7 +74,7 @@ instance Eq (GYInScript v) where data GYInSimpleScript (u :: PlutusVersion) where GYInSimpleScript :: !GYSimpleScript -> GYInSimpleScript u - GYInReferenceSimpleScript :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !GYSimpleScript -> GYInSimpleScript v + GYInReferenceSimpleScript :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !GYSimpleScript -> GYInSimpleScript v deriving instance Show (GYInSimpleScript v) @@ -93,20 +93,20 @@ txInToApi :: GYTxIn v -> (Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn ApiEra)) txInToApi useInline (GYTxIn oref m) = (txOutRefToApi oref, Api.BuildTxWith $ f m) - where - f :: GYTxInWitness v -> Api.Witness Api.WitCtxTxIn ApiEra - f GYTxInWitnessKey = Api.KeyWitness Api.KeyWitnessForSpending - f (GYTxInWitnessScript v d r) = - Api.ScriptWitness Api.ScriptWitnessForSpending $ - ( case v of - GYInScript s -> validatorToApiPlutusScriptWitness s - GYInReference ref s -> referenceScriptToApiPlutusScriptWitness ref s - ) - (if useInline then Api.InlineScriptDatum else Api.ScriptDatumForTxIn $ Just $ datumToApi' d) - (redeemerToApi r) - (Api.ExecutionUnits 0 0) - f (GYTxInWitnessSimpleScript v) = - Api.ScriptWitness Api.ScriptWitnessForSpending $ Api.SimpleScriptWitness Api.SimpleScriptInConway $ h v - - h (GYInSimpleScript v) = Api.SScript $ simpleScriptToApi v - h (GYInReferenceSimpleScript ref s) = Api.SReferenceScript (txOutRefToApi ref) $ Just $ hashSimpleScript' s + where + f :: GYTxInWitness v -> Api.Witness Api.WitCtxTxIn ApiEra + f GYTxInWitnessKey = Api.KeyWitness Api.KeyWitnessForSpending + f (GYTxInWitnessScript v d r) = + Api.ScriptWitness Api.ScriptWitnessForSpending $ + ( case v of + GYInScript s -> validatorToApiPlutusScriptWitness s + GYInReference ref s -> referenceScriptToApiPlutusScriptWitness ref s + ) + (if useInline then Api.InlineScriptDatum else Api.ScriptDatumForTxIn $ Just $ datumToApi' d) + (redeemerToApi r) + (Api.ExecutionUnits 0 0) + f (GYTxInWitnessSimpleScript v) = + Api.ScriptWitness Api.ScriptWitnessForSpending $ Api.SimpleScriptWitness Api.SimpleScriptInConway $ h v + + h (GYInSimpleScript v) = Api.SScript $ simpleScriptToApi v + h (GYInReferenceSimpleScript ref s) = Api.SReferenceScript (txOutRefToApi ref) $ Just $ hashSimpleScript' s diff --git a/src/GeniusYield/Types/TxMetadata.hs b/src/GeniusYield/Types/TxMetadata.hs index 54bc86d8..e8d343a1 100644 --- a/src/GeniusYield/Types/TxMetadata.hs +++ b/src/GeniusYield/Types/TxMetadata.hs @@ -126,6 +126,6 @@ metadataMsgs :: [Text] -> Maybe GYTxMetadata metadataMsgs msgs = case metaValue of GYTxMetaList [] -> Nothing _ -> Just $ GYTxMetadata $ Map.fromList [(674, GYTxMetaMap [(GYTxMetaText "msg", metaValue)])] - where - metaValue :: GYTxMetadataValue - metaValue = txMetadataValueFromApi $ Api.TxMetaList $ concatMap constructTxMetadataTextChunks' msgs + where + metaValue :: GYTxMetadataValue + metaValue = txMetadataValueFromApi $ Api.TxMetaList $ concatMap constructTxMetadataTextChunks' msgs diff --git a/src/GeniusYield/Types/TxOut.hs b/src/GeniusYield/Types/TxOut.hs index 9548fe41..aaee4a72 100644 --- a/src/GeniusYield/Types/TxOut.hs +++ b/src/GeniusYield/Types/TxOut.hs @@ -39,7 +39,7 @@ data GYTxOut (v :: PlutusVersion) = GYTxOut deriving stock (Eq, Show) data GYTxOutUseInlineDatum (v :: PlutusVersion) where - GYTxOutUseInlineDatum :: (v `VersionIsGreaterOrEqual` 'PlutusV2) => GYTxOutUseInlineDatum v + GYTxOutUseInlineDatum :: v `VersionIsGreaterOrEqual` 'PlutusV2 => GYTxOutUseInlineDatum v GYTxOutDontUseInlineDatum :: GYTxOutUseInlineDatum v deriving instance Show (GYTxOutUseInlineDatum v) @@ -79,20 +79,20 @@ txOutToApi (GYTxOut addr v md mrs) = (valueToApiTxOutValue v) (mkDatum md) (maybe Api.S.ReferenceScriptNone (Api.S.ReferenceScript Api.S.BabbageEraOnwardsConway . resolveOutputScript) mrs) - where - resolveOutputScript (GYSimpleScript s) = Api.ScriptInAnyLang Api.SimpleScriptLanguage (Api.SimpleScript $ simpleScriptToApi s) - resolveOutputScript (GYPlutusScript s) = - let version = singPlutusVersionToApi $ scriptVersion s - in Api.ScriptInAnyLang (Api.PlutusScriptLanguage version) (Api.PlutusScript version (scriptToApi s)) + where + resolveOutputScript (GYSimpleScript s) = Api.ScriptInAnyLang Api.SimpleScriptLanguage (Api.SimpleScript $ simpleScriptToApi s) + resolveOutputScript (GYPlutusScript s) = + let version = singPlutusVersionToApi $ scriptVersion s + in Api.ScriptInAnyLang (Api.PlutusScriptLanguage version) (Api.PlutusScript version (scriptToApi s)) - mkDatum :: Maybe (GYDatum, GYTxOutUseInlineDatum v) -> Api.TxOutDatum Api.CtxTx ApiEra - mkDatum Nothing = Api.TxOutDatumNone - mkDatum (Just (d, di)) - | di' = Api.TxOutDatumInline Api.BabbageEraOnwardsConway d' - | otherwise = Api.TxOutDatumInTx Api.AlonzoEraOnwardsConway d' - where - d' = datumToApi' d + mkDatum :: Maybe (GYDatum, GYTxOutUseInlineDatum v) -> Api.TxOutDatum Api.CtxTx ApiEra + mkDatum Nothing = Api.TxOutDatumNone + mkDatum (Just (d, di)) + | di' = Api.TxOutDatumInline Api.BabbageEraOnwardsConway d' + | otherwise = Api.TxOutDatumInTx Api.AlonzoEraOnwardsConway d' + where + d' = datumToApi' d - di' = case di of - GYTxOutUseInlineDatum -> True - GYTxOutDontUseInlineDatum -> False + di' = case di of + GYTxOutUseInlineDatum -> True + GYTxOutDontUseInlineDatum -> False diff --git a/src/GeniusYield/Types/TxOutRef.hs b/src/GeniusYield/Types/TxOutRef.hs index af6615c4..19d98420 100644 --- a/src/GeniusYield/Types/TxOutRef.hs +++ b/src/GeniusYield/Types/TxOutRef.hs @@ -89,17 +89,17 @@ Left (UnknownPlutusToCardanoError {ptceTag = "txOutRefFromPlutus: txOutRefIdx 12 -} txOutRefFromPlutus :: Plutus.TxOutRef -> Either PlutusToCardanoError GYTxOutRef txOutRefFromPlutus (Plutus.TxOutRef tid@(Plutus.TxId (Plutus.BuiltinByteString bs)) ix) = coerce . Api.TxIn <$> etid <*> eix - where - etid :: Either PlutusToCardanoError Api.TxId - etid = - mapLeft (\e -> UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: invalid txOutRefId " <> show tid <> ", error: " <> show e) $ - Api.deserialiseFromRawBytes Api.AsTxId bs - - eix :: Either PlutusToCardanoError Api.TxIx - eix - | ix < 0 = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: negative txOutRefIdx " ++ show ix - | ix > toInteger (maxBound @Word) = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: txOutRefIdx " ++ show ix ++ " too large" - | otherwise = Right $ Api.TxIx $ fromInteger ix + where + etid :: Either PlutusToCardanoError Api.TxId + etid = + mapLeft (\e -> UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: invalid txOutRefId " <> show tid <> ", error: " <> show e) $ + Api.deserialiseFromRawBytes Api.AsTxId bs + + eix :: Either PlutusToCardanoError Api.TxIx + eix + | ix < 0 = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: negative txOutRefIdx " ++ show ix + | ix > toInteger (maxBound @Word) = Left $ UnknownPlutusToCardanoError $ Text.pack $ "txOutRefFromPlutus: txOutRefIdx " ++ show ix ++ " too large" + | otherwise = Right $ Api.TxIx $ fromInteger ix {- | @@ -143,14 +143,14 @@ instance Web.FromHttpApiData GYTxOutRef where parseUrlPiece tr = case Atto.parseOnly parser (TE.encodeUtf8 tr) of Left err -> Left (T.pack ("GYTxOutRef: " ++ err)) Right x -> Right x - where - parser :: Atto.Parser GYTxOutRef - parser = do - tx <- Base16.decodeLenient <$> Atto.takeWhile1 isHexDigit - _ <- Atto.char '#' - ix <- Atto.decimal - tx' <- either (\e -> fail $ "not txid bytes: " <> show tx <> " , error: " <> show e) pure $ Api.deserialiseFromRawBytes Api.AsTxId tx - return (GYTxOutRef (Api.TxIn tx' (Api.TxIx ix))) + where + parser :: Atto.Parser GYTxOutRef + parser = do + tx <- Base16.decodeLenient <$> Atto.takeWhile1 isHexDigit + _ <- Atto.char '#' + ix <- Atto.decimal + tx' <- either (\e -> fail $ "not txid bytes: " <> show tx <> " , error: " <> show e) pure $ Api.deserialiseFromRawBytes Api.AsTxId tx + return (GYTxOutRef (Api.TxIn tx' (Api.TxIx ix))) instance Web.ToHttpApiData GYTxOutRef where toUrlPiece = showTxOutRef diff --git a/src/GeniusYield/Types/TxWdrl.hs b/src/GeniusYield/Types/TxWdrl.hs index 59db48ab..d853cbb3 100644 --- a/src/GeniusYield/Types/TxWdrl.hs +++ b/src/GeniusYield/Types/TxWdrl.hs @@ -43,12 +43,12 @@ txWdrlToApi :: GYTxWdrl v -> (Api.StakeAddress, Ledger.Coin, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxStake ApiEra)) txWdrlToApi (GYTxWdrl stakeAddr amt wit) = (stakeAddressToApi stakeAddr, Ledger.Coin (toInteger amt), Api.BuildTxWith $ f wit) - where - f :: GYTxWdrlWitness v -> Api.Witness Api.WitCtxStake ApiEra - f GYTxWdrlWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr - f (GYTxWdrlWitnessScript v r) = - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - gyStakeValScriptWitnessToApiPlutusSW - v - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + where + f :: GYTxWdrlWitness v -> Api.Witness Api.WitCtxStake ApiEra + f GYTxWdrlWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr + f (GYTxWdrlWitnessScript v r) = + Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ + gyStakeValScriptWitnessToApiPlutusSW + v + (redeemerToApi r) + (Api.ExecutionUnits 0 0) diff --git a/src/GeniusYield/Types/UTxO.hs b/src/GeniusYield/Types/UTxO.hs index 137a387b..0c8b762f 100644 --- a/src/GeniusYield/Types/UTxO.hs +++ b/src/GeniusYield/Types/UTxO.hs @@ -123,27 +123,27 @@ utxosFromApi (Api.UTxO m) = utxosToApi :: GYUTxOs -> Api.UTxO ApiEra utxosToApi (GYUTxOs m) = Api.UTxO $ Map.foldlWithKey' f Map.empty m - where - f :: - Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) -> - GYTxOutRef -> - (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> - Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) - f m' oref out = Map.insert (txOutRefToApi oref) (g out) m' - - g :: (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> Api.TxOut Api.CtxUTxO ApiEra - g (addr, v, md, ms) = - Api.TxOut - (addressToApi' addr) - (valueToApiTxOutValue v) - (outDatumToApi md) - (maybe Api.S.ReferenceScriptNone someScriptToReferenceApi ms) - - outDatumToApi GYOutDatumNone = Api.TxOutDatumNone - outDatumToApi (GYOutDatumHash h) = - Api.TxOutDatumHash Api.AlonzoEraOnwardsConway $ datumHashToApi h - outDatumToApi (GYOutDatumInline d) = - Api.TxOutDatumInline Api.BabbageEraOnwardsConway $ datumToApi' d + where + f :: + Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) -> + GYTxOutRef -> + (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> + Map Api.TxIn (Api.TxOut Api.CtxUTxO ApiEra) + f m' oref out = Map.insert (txOutRefToApi oref) (g out) m' + + g :: (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> Api.TxOut Api.CtxUTxO ApiEra + g (addr, v, md, ms) = + Api.TxOut + (addressToApi' addr) + (valueToApiTxOutValue v) + (outDatumToApi md) + (maybe Api.S.ReferenceScriptNone someScriptToReferenceApi ms) + + outDatumToApi GYOutDatumNone = Api.TxOutDatumNone + outDatumToApi (GYOutDatumHash h) = + Api.TxOutDatumHash Api.AlonzoEraOnwardsConway $ datumHashToApi h + outDatumToApi (GYOutDatumInline d) = + Api.TxOutDatumInline Api.BabbageEraOnwardsConway $ datumToApi' d utxoFromApi :: Api.TxIn -> Api.TxOut Api.CtxTx ApiEra -> GYUTxO utxoFromApi txIn (Api.TxOut a v d s) = @@ -154,12 +154,12 @@ utxoFromApi txIn (Api.TxOut a v d s) = , utxoOutDatum = f d , utxoRefScript = someScriptFromReferenceApi s } - where - f :: Api.TxOutDatum Api.CtxTx ApiEra -> GYOutDatum - f Api.TxOutDatumNone = GYOutDatumNone - f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash - f (Api.TxOutDatumInTx _ sd) = GYOutDatumHash . hashDatum $ datumFromApi' sd - f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd + where + f :: Api.TxOutDatum Api.CtxTx ApiEra -> GYOutDatum + f Api.TxOutDatumNone = GYOutDatumNone + f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash + f (Api.TxOutDatumInTx _ sd) = GYOutDatumHash . hashDatum $ datumFromApi' sd + f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd utxoFromApi' :: Api.TxIn -> Api.TxOut Api.CtxUTxO era -> GYUTxO utxoFromApi' txIn (Api.TxOut a v d s) = @@ -170,11 +170,11 @@ utxoFromApi' txIn (Api.TxOut a v d s) = , utxoOutDatum = f d , utxoRefScript = someScriptFromReferenceApi s } - where - f :: Api.TxOutDatum Api.CtxUTxO era -> GYOutDatum - f Api.TxOutDatumNone = GYOutDatumNone - f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash - f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd + where + f :: Api.TxOutDatum Api.CtxUTxO era -> GYOutDatum + f Api.TxOutDatumNone = GYOutDatumNone + f (Api.TxOutDatumHash _ hash) = GYOutDatumHash $ datumHashFromApi hash + f (Api.TxOutDatumInline _ sd) = GYOutDatumInline $ datumFromApi' sd utxoToPlutus :: GYUTxO -> Plutus.TxOut utxoToPlutus GYUTxO {..} = @@ -234,11 +234,11 @@ Used to pick an input for minting, or selecting collateral (in tests). -} someTxOutRef :: GYUTxOs -> Maybe (GYTxOutRef, GYUTxOs) someTxOutRef (GYUTxOs m) = f <$> Map.minViewWithKey m - where - f ((oref, _), m') = (oref, GYUTxOs m') + where + f ((oref, _), m') = (oref, GYUTxOs m') -- | Get a random output reference from 'GYUTxOs'. -randomTxOutRef :: (MonadRandom m) => GYUTxOs -> m (Maybe (GYTxOutRef, GYUTxOs)) +randomTxOutRef :: MonadRandom m => GYUTxOs -> m (Maybe (GYTxOutRef, GYUTxOs)) randomTxOutRef (GYUTxOs m) | Map.null m = pure Nothing | otherwise = @@ -251,24 +251,24 @@ randomTxOutRef (GYUTxOs m) -- | Filter 'GYUTxOs' with a predicate on 'GYUTxO'. filterUTxOs :: (GYUTxO -> Bool) -> GYUTxOs -> GYUTxOs filterUTxOs p (GYUTxOs m) = GYUTxOs $ Map.filterWithKey p' m - where - p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms + where + p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms -- | Map & filter 'GYUTxOs' contents. mapMaybeUTxOs :: (GYUTxO -> Maybe a) -> GYUTxOs -> Map GYTxOutRef a mapMaybeUTxOs p (GYUTxOs m) = Map.mapMaybeWithKey p' m - where - p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms + where + p' r (a, v, mh, ms) = p $ GYUTxO r a v mh ms -- | Map 'GYUTxOs' contents. mapUTxOs :: (GYUTxO -> a) -> GYUTxOs -> Map GYTxOutRef a mapUTxOs f = mapMaybeUTxOs $ Just . f -- | Applicative version of 'mapMaybeUTxOs'. -witherUTxOs :: (Applicative f) => (GYUTxO -> f (Maybe a)) -> GYUTxOs -> f (Map GYTxOutRef a) +witherUTxOs :: Applicative f => (GYUTxO -> f (Maybe a)) -> GYUTxOs -> f (Map GYTxOutRef a) witherUTxOs f (GYUTxOs m) = iwither g m - where - g ref (a, v, mh, ms) = f (GYUTxO ref a v mh ms) + where + g ref (a, v, mh, ms) = f (GYUTxO ref a v mh ms) -- | Returns a 'GYUTxOs' from a given list of 'GYUTxO's. utxosFromList :: [GYUTxO] -> GYUTxOs @@ -294,25 +294,25 @@ utxosFromUTxO utxo = utxosFromList [utxo] -- | Fold operation over a 'GYUTxOs'. foldlUTxOs' :: forall a. (a -> GYUTxO -> a) -> a -> GYUTxOs -> a foldlUTxOs' f x (GYUTxOs m) = Map.foldlWithKey' f' x m - where - f' :: a -> GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> a - f' y r (a, v, mh, ms) = f y $ GYUTxO r a v mh ms + where + f' :: a -> GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> a + f' y r (a, v, mh, ms) = f y $ GYUTxO r a v mh ms -- | FoldMap operation over a 'GYUTxOs'. -foldMapUTxOs :: (Monoid m) => (GYUTxO -> m) -> GYUTxOs -> m +foldMapUTxOs :: Monoid m => (GYUTxO -> m) -> GYUTxOs -> m foldMapUTxOs f = foldlUTxOs' (\m utxo -> m <> f utxo) mempty -forUTxOs_ :: forall f a. (Applicative f) => GYUTxOs -> (GYUTxO -> f a) -> f () +forUTxOs_ :: forall f a. Applicative f => GYUTxOs -> (GYUTxO -> f a) -> f () forUTxOs_ (GYUTxOs m) f = ifor_ m f' - where - f' :: GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> f a - f' r (a, v, mh, ms) = f $ GYUTxO r a v mh ms + where + f' :: GYTxOutRef -> (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript) -> f a + f' r (a, v, mh, ms) = f $ GYUTxO r a v mh ms -foldMUTxOs :: forall m a. (Monad m) => (a -> GYUTxO -> m a) -> a -> GYUTxOs -> m a +foldMUTxOs :: forall m a. Monad m => (a -> GYUTxO -> m a) -> a -> GYUTxOs -> m a foldMUTxOs f x (GYUTxOs m) = foldM f' x $ Map.toList m - where - f' :: a -> (GYTxOutRef, (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript)) -> m a - f' y (r, (a, v, mh, ms)) = f y $ GYUTxO r a v mh ms + where + f' :: a -> (GYTxOutRef, (GYAddress, GYValue, GYOutDatum, Maybe GYAnyScript)) -> m a + f' y (r, (a, v, mh, ms)) = f y $ GYUTxO r a v mh ms instance Printf.PrintfArg GYUTxOs where formatArg (GYUTxOs m) = diff --git a/src/GeniusYield/Types/Value.hs b/src/GeniusYield/Types/Value.hs index 9159016a..07709c80 100644 --- a/src/GeniusYield/Types/Value.hs +++ b/src/GeniusYield/Types/Value.hs @@ -141,8 +141,8 @@ data GYFromPlutusValueError -- | Value: a (total) map from asset classes ('GYAssetClass') to amount ('Integer'). newtype GYValue = GYValue (Map.Map GYAssetClass Integer) - deriving (Eq) - deriving newtype (Ord) + deriving Eq + deriving newtype Ord {- | Check the 'GYValue' representation invariants. @@ -170,9 +170,9 @@ instance Monoid GYValue where -- | Converts a 'GYValue' to a Plutus 'Plutus.Value' valueToPlutus :: GYValue -> Plutus.Value valueToPlutus (GYValue m) = foldMap f (Map.toList m) - where - f :: (GYAssetClass, Integer) -> Plutus.Value - f (assetClassToPlutus -> Plutus.AssetClass (cs, tn), n) = Plutus.singleton cs tn n + where + f :: (GYAssetClass, Integer) -> Plutus.Value + f (assetClassToPlutus -> Plutus.AssetClass (cs, tn), n) = Plutus.singleton cs tn n {- | Converts a Plutus 'Plutus.Value' to a 'GYValue'. Returns Left 'GYFromPlutusValueError' if it fails. @@ -278,9 +278,9 @@ instance Printf.PrintfArg GYValue where showValue :: Plutus.Value -> String showValue = intercalate " + " . map f . Plutus.flattenValue - where - f :: (Plutus.CurrencySymbol, Plutus.TokenName, Integer) -> String - f (cs, tn, n) = show n ++ " " ++ showAssetClass (Plutus.AssetClass (cs, tn)) + where + f :: (Plutus.CurrencySymbol, Plutus.TokenName, Integer) -> String + f (cs, tn, n) = show n ++ " " ++ showAssetClass (Plutus.AssetClass (cs, tn)) {- | @@ -300,11 +300,11 @@ instance Csv.FromField GYValue where Just v -> pure v Nothing -> fail $ "Error Parsing GYValue: " <> show value -assetPairToKV :: (Aeson.KeyValue e kv) => GYAssetClass -> Integer -> kv +assetPairToKV :: Aeson.KeyValue e kv => GYAssetClass -> Integer -> kv assetPairToKV ac i = K.fromText (f ac) .= i - where - f GYLovelace = "lovelace" - f (GYToken cs tk) = mintingPolicyIdToText cs <> T.cons '.' (tokenNameToHex tk) + where + f GYLovelace = "lovelace" + f (GYToken cs tk) = mintingPolicyIdToText cs <> T.cons '.' (tokenNameToHex tk) {- | @@ -325,18 +325,18 @@ parseValueKM allowWithoutSep km = case KM.toList km of [] -> pure $ valueMake mempty xs -> valueFromList <$> traverse go xs - where - go :: (Aeson.Key, Aeson.Value) -> Aeson.Parser (GYAssetClass, Integer) - go (k, v) = do - let k' = K.toText k - parseWithSep = parseAssetClassWithSep '.' k' - ac <- - either fail pure $ - either (\(Left -> e) -> if allowWithoutSep then parseAssetClassWithoutSep k' <> e else e) Right parseWithSep - scN <- parseJSON v - case SC.floatingOrInteger @Double scN of - Left d -> fail $ "Expected amount to be an integer; amount: " <> show d - Right i -> pure (ac, i) + where + go :: (Aeson.Key, Aeson.Value) -> Aeson.Parser (GYAssetClass, Integer) + go (k, v) = do + let k' = K.toText k + parseWithSep = parseAssetClassWithSep '.' k' + ac <- + either fail pure $ + either (\(Left -> e) -> if allowWithoutSep then parseAssetClassWithoutSep k' <> e else e) Right parseWithSep + scN <- parseJSON v + case SC.floatingOrInteger @Double scN of + Left d -> fail $ "Expected amount to be an integer; amount: " <> show d + Right i -> pure (ac, i) instance Swagger.ToSchema GYValue where declareNamedSchema _ = do @@ -409,8 +409,8 @@ valueAssetClass (GYValue m) ac = Map.findWithDefault 0 ac m -} valueSplitSign :: GYValue -> (GYValue, GYValue) valueSplitSign (GYValue m) = (GYValue positiveVal, GYValue $ negate <$> negativeVal) - where - (positiveVal, negativeVal) = Map.partition (> 0) m + where + (positiveVal, negativeVal) = Map.partition (> 0) m -- | Verify the value only consists of positive amounts, returning a map containing naturals as a result. valueVerifyNonNegative :: GYValue -> Maybe (Map GYAssetClass Natural) @@ -656,11 +656,11 @@ parseAssetClass msep = case msep of Just sep -> parseAssetClassCore sep tnParser Nothing -> parseAssetClassCore' Nothing tnParser - where - tnParser tn = - case tokenNameFromHexBS tn of - Left err -> fail $ T.unpack err - Right x -> pure x + where + tnParser tn = + case tokenNameFromHexBS tn of + Left err -> fail $ T.unpack err + Right x -> pure x parseAssetClassCore :: Char -> (BS.ByteString -> Atto.Parser GYTokenName) -> Text -> Either String GYAssetClass parseAssetClassCore = parseAssetClassCore' . Just @@ -669,16 +669,16 @@ parseAssetClassCore' :: Maybe Char -> (BS.ByteString -> Atto.Parser GYTokenName) parseAssetClassCore' _ _ "lovelace" = pure GYLovelace parseAssetClassCore' _ _ "" = pure GYLovelace parseAssetClassCore' msep tkParser t = Atto.parseOnly parser (TE.encodeUtf8 t) - where - parser :: Atto.Parser GYAssetClass - parser = do - cs <- Atto.take 56 - case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of - Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x - Right cs' -> do - for_ msep (void . Atto.char) - tn <- Atto.takeWhile isAlphaNum - GYToken (mintingPolicyIdFromApi cs') <$> tkParser tn + where + parser :: Atto.Parser GYAssetClass + parser = do + cs <- Atto.take 56 + case Api.deserialiseFromRawBytesHex Api.AsPolicyId cs of + Left x -> fail $ "Invalid currency symbol: " ++ show cs ++ "; Reason: " ++ show x + Right cs' -> do + for_ msep (void . Atto.char) + tn <- Atto.takeWhile isAlphaNum + GYToken (mintingPolicyIdFromApi cs') <$> tkParser tn ------------------------------------------------------------------------------- -- TokenName @@ -706,8 +706,8 @@ instance IsString GYTokenName where fromMaybe (error $ "fromString @GYTokenName " ++ show s ++ ": token name too long") (tokenNameFromBS bs) - where - bs = fromString s -- TODO: utf8-encode #33 (https://github.com/geniusyield/atlas/issues/33) + where + bs = fromString s -- TODO: utf8-encode #33 (https://github.com/geniusyield/atlas/issues/33) instance Swagger.ToParamSchema GYTokenName where toParamSchema _ = @@ -787,7 +787,7 @@ tokenNameToPlutus :: GYTokenName -> Plutus.TokenName tokenNameToPlutus (GYTokenName bs) = Plutus.TokenName (toBuiltin bs) -- | Convert Plutus 'Plutus.TokenName' to 'GYTokenName'. -tokenNameFromPlutus :: (HasCallStack) => Plutus.TokenName -> Maybe GYTokenName +tokenNameFromPlutus :: HasCallStack => Plutus.TokenName -> Maybe GYTokenName tokenNameFromPlutus (Plutus.TokenName bbs) = tokenNameFromBS (fromBuiltin bbs) tokenNameFromBS :: BS.ByteString -> Maybe GYTokenName diff --git a/src/GeniusYield/Types/Wallet.hs b/src/GeniusYield/Types/Wallet.hs index 83619b23..c4a913ae 100644 --- a/src/GeniusYield/Types/Wallet.hs +++ b/src/GeniusYield/Types/Wallet.hs @@ -68,25 +68,25 @@ walletKeysFromMnemonicIndexed mns nAcctIndex nAddrIndex = accIx = indexFromWord32 $ minHardenedPathValue + nAcctIndex addrIx = indexFromWord32 nAddrIndex in deriveWalletKeys rootK accIx addrIx - where - deriveWalletKeys :: - S.Shelley 'RootK XPrv -> - -- \^ The Root Key - Maybe (Index 'Hardened 'AccountK) -> - -- \^ The Index for Account - Maybe (Index 'Soft 'PaymentK) -> - -- \^ The Index for Address - Either String WalletKeys - deriveWalletKeys _ Nothing _ = Left $ "Invalid Account Index: " <> show nAcctIndex - deriveWalletKeys _ _ Nothing = Left $ "Invalid Address Index: " <> show nAddrIndex - deriveWalletKeys rootK (Just accIx) (Just addIx) = - let acctK = deriveAccountPrivateKey rootK accIx - paymentK = deriveAddressPrivateKey acctK S.UTxOExternal addIx - stakeK = S.deriveDelegationPrivateKey acctK - in Right WalletKeys {wkRootKey = rootK, wkAcctKey = acctK, wkPaymentKey = paymentK, wkStakeKey = stakeK} + where + deriveWalletKeys :: + S.Shelley 'RootK XPrv -> + -- \^ The Root Key + Maybe (Index 'Hardened 'AccountK) -> + -- \^ The Index for Account + Maybe (Index 'Soft 'PaymentK) -> + -- \^ The Index for Address + Either String WalletKeys + deriveWalletKeys _ Nothing _ = Left $ "Invalid Account Index: " <> show nAcctIndex + deriveWalletKeys _ _ Nothing = Left $ "Invalid Address Index: " <> show nAddrIndex + deriveWalletKeys rootK (Just accIx) (Just addIx) = + let acctK = deriveAccountPrivateKey rootK accIx + paymentK = deriveAddressPrivateKey acctK S.UTxOExternal addIx + stakeK = S.deriveDelegationPrivateKey acctK + in Right WalletKeys {wkRootKey = rootK, wkAcctKey = acctK, wkPaymentKey = paymentK, wkStakeKey = stakeK} - -- value for '0H' index - minHardenedPathValue = 0x80000000 + -- value for '0H' index + minHardenedPathValue = 0x80000000 -- | Derives @WalletKeys@ from mnemonic with first account index, using derivation path @1852H/1815H/0H/2/0@ for stake key and derivation path @1852H/1815H/0H/0/0@ for payment key. walletKeysFromMnemonic :: Mnemonic -> Either String WalletKeys @@ -126,10 +126,10 @@ walletKeysToAddress WalletKeys {wkPaymentKey, wkStakeKey} netId = let paymentCredential = S.PaymentFromExtendedKey $ toXPub <$> wkPaymentKey delegationCredential = S.DelegationFromExtendedKey $ toXPub <$> wkStakeKey in S.delegationAddress netId' paymentCredential delegationCredential & bech32 & unsafeAddressFromText - where - netId' = case netId of - GYMainnet -> S.shelleyMainnet - GYTestnetPreprod -> S.shelleyTestnet - GYTestnetPreview -> S.shelleyTestnet - GYTestnetLegacy -> S.shelleyTestnet - GYPrivnet {} -> S.shelleyTestnet + where + netId' = case netId of + GYMainnet -> S.shelleyMainnet + GYTestnetPreprod -> S.shelleyTestnet + GYTestnetPreview -> S.shelleyTestnet + GYTestnetLegacy -> S.shelleyTestnet + GYPrivnet {} -> S.shelleyTestnet diff --git a/src/GeniusYield/Utils.hs b/src/GeniusYield/Utils.hs index 2a0649a0..713eb706 100644 --- a/src/GeniusYield/Utils.hs +++ b/src/GeniusYield/Utils.hs @@ -37,10 +37,10 @@ fieldNamePrefixStripN :: Int -> String -> String fieldNamePrefixStripN n fldName = case drop n fldName of x : xs -> toLower x : xs; [] -> [] -- | Map the exception type in an 'ExceptT' with a function. -modifyException :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a +modifyException :: Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a modifyException f (ExceptT meith) = ExceptT $ first f <$> meith -serialiseToBech32WithPrefix :: (SerialiseAsRawBytes a) => Text -> a -> Text +serialiseToBech32WithPrefix :: SerialiseAsRawBytes a => Text -> a -> Text serialiseToBech32WithPrefix prefix = case Bech32.humanReadablePartFromText prefix of Left e -> diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index 1ac09db1..181f144a 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -43,43 +43,43 @@ placeBetTests setup = ) . failingMultipleBetsTest ] - where - mkPrivnetTestFor_ = flip mkPrivnetTestFor setup - firstBetTest :: (GYTxGameMonad m) => TestInfo -> m () - firstBetTest = firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) . testWallets - multipleBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - multipleBetsTest TestInfo {..} = - multipleBetsTraceWrapper - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) - ] - testWallets - failingMultipleBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - failingMultipleBetsTest TestInfo {..} = - multipleBetsTraceWrapper - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 <> valueSingleton testGoldAsset 1_000) - ] - testWallets + where + mkPrivnetTestFor_ = flip mkPrivnetTestFor setup + firstBetTest :: GYTxGameMonad m => TestInfo -> m () + firstBetTest = firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) . testWallets + multipleBetsTest :: GYTxGameMonad m => TestInfo -> m () + multipleBetsTest TestInfo {..} = + multipleBetsTraceWrapper + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + testWallets + failingMultipleBetsTest :: GYTxGameMonad m => TestInfo -> m () + failingMultipleBetsTest TestInfo {..} = + multipleBetsTraceWrapper + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 <> valueSingleton testGoldAsset 1_000) + ] + testWallets -- ----------------------------------------------------------------------------- -- Super-trivial example -- ----------------------------------------------------------------------------- -- | Trace for a super-simple spending transaction. -simplSpendingTxTrace :: (GYTxGameMonad m) => Wallets -> m () +simplSpendingTxTrace :: GYTxGameMonad m => Wallets -> m () simplSpendingTxTrace Wallets {w1} = do gyLogDebug' "" "Hey there!" -- balance assetion check @@ -93,7 +93,7 @@ simplSpendingTxTrace Wallets {w1} = do gyLogDebug' "" $ printf "tx submitted, txId: %s" txId -- Pretend off-chain code written in 'GYTxUserQueryMonad m' -mkTrivialTx :: (GYTxUserQueryMonad m) => m (GYTxSkeleton 'PlutusV2) +mkTrivialTx :: GYTxUserQueryMonad m => m (GYTxSkeleton 'PlutusV2) mkTrivialTx = do addr <- ownChangeAddress gyLogDebug' "" $ printf "ownAddr: %s" (show addr) @@ -127,7 +127,7 @@ Level 3. The action (Off-chain code) -- | Trace for placing the first bet. firstBetTrace :: - (GYTxGameMonad m) => + GYTxGameMonad m => -- | Guess OracleAnswerDatum -> -- | Bet @@ -148,7 +148,7 @@ firstBetTrace dat bet ws@Wallets {w1} = do -- | Function to compute the parameters for the contract and add the corresponding refernce script. computeParamsAndAddRefScript :: - (GYTxGameMonad m) => + GYTxGameMonad m => -- | Bet Until slot Integer -> -- | Bet Reveal slot @@ -179,7 +179,7 @@ computeParamsAndAddRefScript betUntil' betReveal' betStep Wallets {..} = do pure (brp, refScript) -- | Run to call the `placeBet` operation. -placeBetRun :: (GYTxMonad m) => GYTxOutRef -> BetRefParams -> OracleAnswerDatum -> GYValue -> Maybe GYTxOutRef -> m GYTxId +placeBetRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> OracleAnswerDatum -> GYValue -> Maybe GYTxOutRef -> m GYTxId placeBetRun refScript brp guess bet mPreviousBetsUtxoRef = do addr <- ownChangeAddress gyLogDebug' "" $ printf "bet: %s" (show bet) @@ -197,7 +197,7 @@ placeBetRun refScript brp guess bet mPreviousBetsUtxoRef = do -- | Trace which allows for multiple bets. multipleBetsTraceWrapper :: - (GYTxGameMonad m) => + GYTxGameMonad m => -- | slot for betUntil Integer -> -- | slot for betReveal @@ -219,7 +219,7 @@ multipleBetsTraceWrapper betUntil' betReveal' betStep walletBets ws = do -- | Trace which allows for multiple bets. multipleBetsTraceCore :: - (GYTxGameMonad m) => + GYTxGameMonad m => BetRefParams -> -- | Reference script GYTxOutRef -> @@ -272,26 +272,26 @@ multipleBetsTraceCore brp refScript walletBets ws@Wallets {..} = do gyLogDebug' "" $ printf "balanceAfterAllTheseOps: %s" (mconcat balanceAfterAllTheseOps) -- Check the difference asUser w1 $ verify (zip3 balanceDiffWithoutFees balanceBeforeAllTheseOps balanceAfterAllTheseOps) - where - -- \| Function to verify that the wallet indeed lost by /roughly/ the bet amount. - -- We say /roughly/ as fees is assumed to be within (0, 1.5 ada]. - -- Suppose that wallet x places bet 3 times, where for simplicity assume each tx costed 0.6 ada as fees then the threshold should be above 1.8 ada. - verify [] = return () - verify (((wallet, diff), vBefore, vAfter) : xs) = - let vAfterWithoutFees = vBefore <> diff - (expectedAdaWithoutFees, expectedOtherAssets) = valueSplitAda vAfterWithoutFees - (actualAda, actualOtherAssets) = valueSplitAda vAfter - threshold = 1_500_000 -- 1.5 ada - in if expectedOtherAssets == actualOtherAssets - && actualAda < expectedAdaWithoutFees - && expectedAdaWithoutFees - threshold <= actualAda - then verify xs - else - throwAppError . someBackendError . T.pack $ - ( "For wallet " - <> show (userAddr wallet) - <> " expected value (without fees) " - <> show vAfterWithoutFees - <> " but actual is " - <> show vAfter - ) + where + -- \| Function to verify that the wallet indeed lost by /roughly/ the bet amount. + -- We say /roughly/ as fees is assumed to be within (0, 1.5 ada]. + -- Suppose that wallet x places bet 3 times, where for simplicity assume each tx costed 0.6 ada as fees then the threshold should be above 1.8 ada. + verify [] = return () + verify (((wallet, diff), vBefore, vAfter) : xs) = + let vAfterWithoutFees = vBefore <> diff + (expectedAdaWithoutFees, expectedOtherAssets) = valueSplitAda vAfterWithoutFees + (actualAda, actualOtherAssets) = valueSplitAda vAfter + threshold = 1_500_000 -- 1.5 ada + in if expectedOtherAssets == actualOtherAssets + && actualAda < expectedAdaWithoutFees + && expectedAdaWithoutFees - threshold <= actualAda + then verify xs + else + throwAppError . someBackendError . T.pack $ + ( "For wallet " + <> show (userAddr wallet) + <> " expected value (without fees) " + <> show vAfterWithoutFees + <> " but actual is " + <> show vAfter + ) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index 140fedbd..da1f53bf 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -31,63 +31,63 @@ takeBetPotTests setup = , mkTestFor "Must fail even if old guess was closest but updated one is not" $ mustFail . badUpdatedGuessTakeBetsTest , mkPrivnetTestFor_ "Must fail even if old guess was closest but updated one is not - privnet" $ mustFailPrivnet . badUpdatedGuessTakeBetsTest ] - where - mkPrivnetTestFor_ = flip mkPrivnetTestFor setup - takeBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - takeBetsTest TestInfo {..} = - takeBetsTrace - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) - ] - 4 - w2 - testWallets - wrongGuesserTakeBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - wrongGuesserTakeBetsTest TestInfo {..} = - takeBetsTrace - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) - ] - 5 - w2 - testWallets - badUpdatedGuessTakeBetsTest :: (GYTxGameMonad m) => TestInfo -> m () - badUpdatedGuessTakeBetsTest TestInfo {..} = - takeBetsTrace - 400 - 1_000 - (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) - ] - 2 - w2 - testWallets - -- Must fail with script execution error (which is fired in the body error auto balance). - mustFailPrivnet = - handleError - ( \case - GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () - e -> throwError e - ) + where + mkPrivnetTestFor_ = flip mkPrivnetTestFor setup + takeBetsTest :: GYTxGameMonad m => TestInfo -> m () + takeBetsTest TestInfo {..} = + takeBetsTrace + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + 4 + w2 + testWallets + wrongGuesserTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () + wrongGuesserTakeBetsTest TestInfo {..} = + takeBetsTrace + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + 5 + w2 + testWallets + badUpdatedGuessTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () + badUpdatedGuessTakeBetsTest TestInfo {..} = + takeBetsTrace + 400 + 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + 2 + w2 + testWallets + -- Must fail with script execution error (which is fired in the body error auto balance). + mustFailPrivnet = + handleError + ( \case + GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () + e -> throwError e + ) -- | Run to call the `takeBets` operation. -takeBetsRun :: (GYTxMonad m) => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId +takeBetsRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId takeBetsRun refScript brp toConsume refInput = do addr <- ownChangeAddress skeleton <- takeBets refScript brp toConsume addr refInput @@ -95,7 +95,7 @@ takeBetsRun refScript brp toConsume refInput = do -- | Trace for taking bet pot. takeBetsTrace :: - (GYTxGameMonad m) => + GYTxGameMonad m => -- | slot for betUntil Integer -> -- | slot for betReveal diff --git a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs index 6ad20a1b..eebb7e0c 100644 --- a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs +++ b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs @@ -144,23 +144,23 @@ mkBetRefValidator' (BetRefParams oraclePkh betUntil betReveal betStep) (BetRefDa && traceIfFalse "Guess is not closest" (all (\pg -> getGuessDiff (snd pg) >= guessDiff) previousGuesses) - where - info :: TxInfo - info = scriptContextTxInfo ctx - - validRange :: POSIXTimeRange - validRange = txInfoValidRange info - - signerPkh :: PubKeyHash - signerPkh = case txInfoSignatories info of - [signerPkh'] -> signerPkh' - [] -> traceError "No signatory" - _anyOtherMatch -> traceError "Expected only one signatory" - - outputToDatum :: (FromData b) => TxOut -> Maybe b - outputToDatum o = case txOutDatum o of - NoOutputDatum -> Nothing - OutputDatum d -> processDatum d - OutputDatumHash dh -> processDatum =<< findDatum dh info - where - processDatum = fromBuiltinData . getDatum + where + info :: TxInfo + info = scriptContextTxInfo ctx + + validRange :: POSIXTimeRange + validRange = txInfoValidRange info + + signerPkh :: PubKeyHash + signerPkh = case txInfoSignatories info of + [signerPkh'] -> signerPkh' + [] -> traceError "No signatory" + _anyOtherMatch -> traceError "Expected only one signatory" + + outputToDatum :: FromData b => TxOut -> Maybe b + outputToDatum o = case txOutDatum o of + NoOutputDatum -> Nothing + OutputDatum d -> processDatum d + OutputDatumHash dh -> processDatum =<< findDatum dh info + where + processDatum = fromBuiltinData . getDatum diff --git a/tests/GeniusYield/Test/CoinSelection.hs b/tests/GeniusYield/Test/CoinSelection.hs index f6d76b21..c6eddcad 100644 --- a/tests/GeniusYield/Test/CoinSelection.hs +++ b/tests/GeniusYield/Test/CoinSelection.hs @@ -27,7 +27,7 @@ data CoinSelectionTestParams = CoinSelectionTestParams , cstpOwnUtxos :: [GYValue] -- ^ This shouldn't contain the collateral. } - deriving (Show) + deriving Show prettyTestParams :: CoinSelectionTestParams -> String prettyTestParams CoinSelectionTestParams {..} = @@ -287,11 +287,11 @@ randomImproveTests = testCaseBody expectedAdditionalInps expectedChangeOuts (tokenSalePlaceTestParams 19_902_000_000 rideTheWave) ] ] - where - testCaseBody expectedAdditionalInps expectedChangeOuts params = do - case runCoinSelectionTest GYRandomImproveMultiAsset params of - Left err -> assertFailure $ "Selection failed: " ++ show err - Right x -> (expectedAdditionalInps, expectedChangeOuts) @=? x + where + testCaseBody expectedAdditionalInps expectedChangeOuts params = do + case runCoinSelectionTest GYRandomImproveMultiAsset params of + Left err -> assertFailure $ "Selection failed: " ++ show err + Right x -> (expectedAdditionalInps, expectedChangeOuts) @=? x ------------------------------------------------------------------------------- -- Transaction representing place token sale order @@ -309,10 +309,10 @@ tokenSalePlaceTestParams payment wallet = , cstpTxMint = gyTokenVal , cstpOwnUtxos = wallet } - where - lovelaceAmount = max minLovelace $ valueAssetClass gyTokenVal GYLovelace - minLovelace = toInteger $ mockMinimumUtxo gyTokenVal - gyTokenVal = valueSingleton gyToken 1 + where + lovelaceAmount = max minLovelace $ valueAssetClass gyTokenVal GYLovelace + minLovelace = toInteger $ mockMinimumUtxo gyTokenVal + gyTokenVal = valueSingleton gyToken 1 ------------------------------------------------------------------------------- -- Different mock wallet distributions @@ -403,9 +403,9 @@ runCoinSelectionTest cstrat cstParams = do let inpVals = gyTxInDetValue <$> additionalInps changeVals = gyTxOutValue <$> changeOuts pure (inpVals, changeVals) - where - -- We use a pure StdGen for reproducible tests. - pureStdGen = mkStdGen 936 -- 42 wasn't random enough. + where + -- We use a pure StdGen for reproducible tests. + pureStdGen = mkStdGen 936 -- 42 wasn't random enough. coinSelectionTestParamsToEnv :: CoinSelectionTestParams -> GYCoinSelectionEnv v coinSelectionTestParamsToEnv CoinSelectionTestParams {cstpTxExtInps, cstpTxOwnInps, cstpTxOuts, cstpTxMint, cstpOwnUtxos} = @@ -416,9 +416,9 @@ coinSelectionTestParamsToEnv CoinSelectionTestParams {cstpTxExtInps, cstpTxOwnIn -- (https://github.com/geniusyield/atlas/issues/36) ((mockRecipientAddress,) <$> cstpTxOuts) cstpTxMint - where - ownUtxos = buildOwnUtxos cstpOwnUtxos - inps = buildInps cstpTxExtInps cstpTxOwnInps + where + ownUtxos = buildOwnUtxos cstpOwnUtxos + inps = buildInps cstpTxExtInps cstpTxOwnInps buildEnvWith :: GYUTxOs -> [GYTxInDetailed v] -> [(GYAddress, GYValue)] -> GYValue -> GYCoinSelectionEnv v buildEnvWith ownUtxos existingInps targetOuts mintVal = @@ -437,18 +437,18 @@ buildEnvWith ownUtxos existingInps targetOuts mintVal = buildInps :: [GYValue] -> [GYValue] -> [GYTxInDetailed v] buildInps ext own = go (ext ++ own) - where - go = - zipWith - ( \i v -> - GYTxInDetailed - (GYTxIn (txOutRefFromTuple (mockTxId1, i)) GYTxInWitnessKey) - mockInpAddress - v - GYOutDatumNone - Nothing - ) - [0 ..] + where + go = + zipWith + ( \i v -> + GYTxInDetailed + (GYTxIn (txOutRefFromTuple (mockTxId1, i)) GYTxInWitnessKey) + mockInpAddress + v + GYOutDatumNone + Nothing + ) + [0 ..] buildOwnUtxos :: [GYValue] -> GYUTxOs buildOwnUtxos = @@ -509,13 +509,13 @@ testCaseQuickCheckBody strat prop = forAllShrinkShow genParamsLovelace shrinkPar Right (addInputs, changeOuts) -> monitor (counterexample (getReason addInputs changeOuts)) >> M.assert (prop cstEnv addInputs changeOuts) - where - getReason addInputs changeOuts = - unlines - [ "* AdditionalInputs: " ++ show addInputs - , "* ChangeOuts: " ++ show changeOuts - ] - outputsHaveLovelace env = all (\(_, v) -> valueAssetClass v GYLovelace > 0) (requiredOutputs env) + where + getReason addInputs changeOuts = + unlines + [ "* AdditionalInputs: " ++ show addInputs + , "* ChangeOuts: " ++ show changeOuts + ] + outputsHaveLovelace env = all (\(_, v) -> valueAssetClass v GYLovelace > 0) (requiredOutputs env) propInputsAreSubset :: GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool propInputsAreSubset env addIns _ = all ((`elem` utxosRefs (ownUtxos env)) . gyTxInTxOutRef . gyTxInDet) addIns @@ -523,18 +523,18 @@ propInputsAreSubset env addIns _ = all ((`elem` utxosRefs (ownUtxos env)) . gyTx propInputsAreEnough :: GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool propInputsAreEnough env addIns _ = allInputsValue `valueGreaterOrEqual` allOutputsValue - where - allInputsValue = sumEntries (existingInputs env ++ addIns) <> mintValue env - allOutputsValue = mconcat $ map snd (requiredOutputs env) + where + allInputsValue = sumEntries (existingInputs env ++ addIns) <> mintValue env + allOutputsValue = mconcat $ map snd (requiredOutputs env) propChangeIsEnough :: GYCoinSelectionEnv v -> [GYTxInDetailed v] -> [GYTxOut v] -> Bool propChangeIsEnough env addIns changeOuts = changeAssets == txAssets - where - changeValue = mconcat (map gyTxOutValue changeOuts) - changeAssets = snd $ valueSplitAda changeValue - allInputsValue = sumEntries (existingInputs env ++ addIns) <> mintValue env - allOutputsValue = mconcat (map snd (requiredOutputs env)) <> naturalToValue (extraLovelace env) - txAssets = snd $ valueSplitAda $ allInputsValue `valueMinus` allOutputsValue + where + changeValue = mconcat (map gyTxOutValue changeOuts) + changeAssets = snd $ valueSplitAda changeValue + allInputsValue = sumEntries (existingInputs env ++ addIns) <> mintValue env + allOutputsValue = mconcat (map snd (requiredOutputs env)) <> naturalToValue (extraLovelace env) + txAssets = snd $ valueSplitAda $ allInputsValue `valueMinus` allOutputsValue ------------------------------------------------------------------------------- -- QuickCheck Generators @@ -559,41 +559,41 @@ genCoinSelectionParams extraLovelace = do , cstpTxMint = minted , cstpOwnUtxos = ownUtxos } - where - genGYAssetClass :: Gen GYAssetClass - genGYAssetClass = elements $ map mockAsset ["A", "B", "C", "D", "E", "F", "G", "H", "I"] - - genGYValue :: Gen GYValue - genGYValue = oneof [genLovelaceValue, genSingleAssetValue, genAssetValue] - - genLovelaceValue :: Gen GYValue - genLovelaceValue = valueFromLovelace <$> chooseInteger (2_000_000, 200_000_000) - - genSingleAssetValue :: Gen GYValue - genSingleAssetValue = do - lovelaceVal <- genLovelaceValue - assetClass <- genGYAssetClass - amount <- chooseInteger (1, 10_000) - return (lovelaceVal <> valueSingleton assetClass amount) - - genAssetValue :: Gen GYValue - genAssetValue = do - lovelaceVal <- genLovelaceValue - assetClasses <- listOf1 genGYAssetClass - amounts <- vectorOf (length assetClasses) $ chooseInteger (1, 10_000) - return $ lovelaceVal <> valueFromList (zip assetClasses amounts) - - genInputs :: Gen ([GYValue], [GYValue], [GYValue], GYValue) - genInputs = do - extIns <- listOf genGYValue - ownIns <- listOf genGYValue - ownUtxos <- listOf genGYValue - minted <- frequency [(3, genAssetValue), (1, return mempty)] - let assetsMinted = snd $ valueSplitAda minted - return (extIns, ownIns, ownUtxos, assetsMinted) - - genValidInputs :: [GYValue] -> Gen ([GYValue], [GYValue], [GYValue], GYValue) - genValidInputs outs = genInputs `suchThat` inputsAreValid outs extraLovelace + where + genGYAssetClass :: Gen GYAssetClass + genGYAssetClass = elements $ map mockAsset ["A", "B", "C", "D", "E", "F", "G", "H", "I"] + + genGYValue :: Gen GYValue + genGYValue = oneof [genLovelaceValue, genSingleAssetValue, genAssetValue] + + genLovelaceValue :: Gen GYValue + genLovelaceValue = valueFromLovelace <$> chooseInteger (2_000_000, 200_000_000) + + genSingleAssetValue :: Gen GYValue + genSingleAssetValue = do + lovelaceVal <- genLovelaceValue + assetClass <- genGYAssetClass + amount <- chooseInteger (1, 10_000) + return (lovelaceVal <> valueSingleton assetClass amount) + + genAssetValue :: Gen GYValue + genAssetValue = do + lovelaceVal <- genLovelaceValue + assetClasses <- listOf1 genGYAssetClass + amounts <- vectorOf (length assetClasses) $ chooseInteger (1, 10_000) + return $ lovelaceVal <> valueFromList (zip assetClasses amounts) + + genInputs :: Gen ([GYValue], [GYValue], [GYValue], GYValue) + genInputs = do + extIns <- listOf genGYValue + ownIns <- listOf genGYValue + ownUtxos <- listOf genGYValue + minted <- frequency [(3, genAssetValue), (1, return mempty)] + let assetsMinted = snd $ valueSplitAda minted + return (extIns, ownIns, ownUtxos, assetsMinted) + + genValidInputs :: [GYValue] -> Gen ([GYValue], [GYValue], [GYValue], GYValue) + genValidInputs outs = genInputs `suchThat` inputsAreValid outs extraLovelace genParamsLovelace :: Gen (CoinSelectionTestParams, Natural) genParamsLovelace = do diff --git a/tests/GeniusYield/Test/GYTxBody.hs b/tests/GeniusYield/Test/GYTxBody.hs index e01b18c0..61e049d2 100644 --- a/tests/GeniusYield/Test/GYTxBody.hs +++ b/tests/GeniusYield/Test/GYTxBody.hs @@ -128,19 +128,19 @@ adjustTxTests = ] val `adjustedShouldEqual` (val <> valueFromLovelace 1_184_380) ] - where - mockAdjust :: GYTxOut v -> GYTxOut v - mockAdjust = adjustTxOut mockMinimumUTxO + where + mockAdjust :: GYTxOut v -> GYTxOut v + mockAdjust = adjustTxOut mockMinimumUTxO - mockMinimumUTxO :: GYTxOut v -> Natural - mockMinimumUTxO = minimumUTxO mockProtocolParams + mockMinimumUTxO :: GYTxOut v -> Natural + mockMinimumUTxO = minimumUTxO mockProtocolParams - lovelacesAdjustedShouldEqual :: Integer -> Integer -> Assertion - lovelacesAdjustedShouldEqual n m = - mockAdjust (mockTxOutFromLovelace n) @?= mockTxOutFromLovelace m + lovelacesAdjustedShouldEqual :: Integer -> Integer -> Assertion + lovelacesAdjustedShouldEqual n m = + mockAdjust (mockTxOutFromLovelace n) @?= mockTxOutFromLovelace m - adjustedShouldEqual :: GYValue -> GYValue -> Assertion - adjustedShouldEqual v1 v2 = mockAdjust (mockTxOut v1) @?= mockTxOut v2 + adjustedShouldEqual :: GYValue -> GYValue -> Assertion + adjustedShouldEqual v1 v2 = mockAdjust (mockTxOut v1) @?= mockTxOut v2 balanceTxStepTests :: [TestTree] balanceTxStepTests = @@ -231,14 +231,14 @@ mockBuildTxEnv wallet = , gyBTxEnvChangeAddr = mockChangeAddress , gyBTxEnvCollateral = collateralUtxo } - where - slotLen = fromInteger (scSlotLength defaultSlotConfig) / 1000 - slotZero = - posixSecondsToUTCTime $ - timeToPOSIX $ - timeFromPlutus $ - scSlotZeroTime defaultSlotConfig - mockSystemStart = gyscSystemStart $ simpleSlotConfig slotZero slotLen + where + slotLen = fromInteger (scSlotLength defaultSlotConfig) / 1000 + slotZero = + posixSecondsToUTCTime $ + timeToPOSIX $ + timeFromPlutus $ + scSlotZeroTime defaultSlotConfig + mockSystemStart = gyscSystemStart $ simpleSlotConfig slotZero slotLen buildOwnUtxos :: [GYValue] -> GYUTxOs buildOwnUtxos = diff --git a/tests/GeniusYield/Test/GYTxSkeleton.hs b/tests/GeniusYield/Test/GYTxSkeleton.hs index 10c9aa79..bb39d20b 100644 --- a/tests/GeniusYield/Test/GYTxSkeleton.hs +++ b/tests/GeniusYield/Test/GYTxSkeleton.hs @@ -243,13 +243,13 @@ mockTxOut2 = mkGYTxOutNoDatum mockOutAddress (mockOutValue <> mockOutValue) mockPkh1 :: GYPubKeyHash mockPkh1 = fromRight err $ pubKeyHashFromPlutus "e1cbb80db89e292269aeb93ec15eb963dda5176b66949fe1c2a6a38d" - where - err = error "absurd" + where + err = error "absurd" mockPkh2 :: GYPubKeyHash mockPkh2 = fromRight err $ pubKeyHashFromPlutus "69aeb93ec15eb963dda5176b66949fe1c2a6a38de1cbb80db89e2922" - where - err = error "absurd" + where + err = error "absurd" mockSlot :: GYSlot mockSlot = mockSlot' 1000 diff --git a/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs b/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs index d927d035..c4d44218 100644 --- a/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs +++ b/tests/GeniusYield/Test/OnChain/GuessRefInputDatum.hs @@ -32,31 +32,31 @@ mkGuessRefInputDatumValidator :: BuiltinData -> BuiltinData -> BuiltinData -> () mkGuessRefInputDatumValidator _ red' ctx' | guess == original = () | otherwise = error () - where - ctx :: ScriptContext - ctx = unsafeFromBuiltinData ctx' - - Guess guess = unsafeFromBuiltinData red' - - info :: TxInfo - info = scriptContextTxInfo ctx - - refIn :: TxOut - refIn = case map txInInfoResolved (txInfoReferenceInputs info) of - [refIn'] -> refIn' - [] -> traceError "No reference input provided." - _anyOther -> traceError "Expected only one reference input but found more than one." - - outputToDatum :: (FromData b) => TxOut -> Maybe b - outputToDatum o = case txOutDatum o of - NoOutputDatum -> Nothing - OutputDatum d -> processDatum d - OutputDatumHash dh -> processDatum =<< findDatum dh info - where - processDatum = fromBuiltinData . getDatum - - original :: Integer - original = - case outputToDatum refIn of - Nothing -> traceError "Datum not present or parsed." - Just (RefInputDatum original') -> original' + where + ctx :: ScriptContext + ctx = unsafeFromBuiltinData ctx' + + Guess guess = unsafeFromBuiltinData red' + + info :: TxInfo + info = scriptContextTxInfo ctx + + refIn :: TxOut + refIn = case map txInInfoResolved (txInfoReferenceInputs info) of + [refIn'] -> refIn' + [] -> traceError "No reference input provided." + _anyOther -> traceError "Expected only one reference input but found more than one." + + outputToDatum :: FromData b => TxOut -> Maybe b + outputToDatum o = case txOutDatum o of + NoOutputDatum -> Nothing + OutputDatum d -> processDatum d + OutputDatumHash dh -> processDatum =<< findDatum dh info + where + processDatum = fromBuiltinData . getDatum + + original :: Integer + original = + case outputToDatum refIn of + Nothing -> traceError "Datum not present or parsed." + Just (RefInputDatum original') -> original' diff --git a/tests/GeniusYield/Test/Providers.hs b/tests/GeniusYield/Test/Providers.hs index 448e9d0c..3d4bd03b 100644 --- a/tests/GeniusYield/Test/Providers.hs +++ b/tests/GeniusYield/Test/Providers.hs @@ -205,74 +205,74 @@ maestroTests token netId = res @?= expected ] ] - where - getQueryUtxo :: Text.Text -> IO GYQueryUTxO - getQueryUtxo pToken = maestroQueryUtxo <$> networkIdToMaestroEnv pToken netId - - getUTxOsAtAddress :: GYAddress -> Text.Text -> IO (Api.UTxO ApiEra) - getUTxOsAtAddress addr pToken = do - queryUtxo <- getQueryUtxo pToken - utxos <- gyQueryUtxosAtAddress' queryUtxo addr Nothing - return $ utxosToApi utxos - - getUTxOsAtAddresses :: [GYAddress] -> Text.Text -> IO (Api.UTxO ApiEra) - getUTxOsAtAddresses addrs pToken = do - queryUtxo <- getQueryUtxo pToken - utxos <- gyQueryUtxosAtAddresses' queryUtxo addrs - return $ utxosToApi utxos - - getUTxOAtRef :: GYTxOutRef -> Text.Text -> IO (Api.UTxO ApiEra) - getUTxOAtRef ref pToken = do - queryUtxo <- getQueryUtxo pToken - utxo <- gyQueryUtxoAtTxOutRef' queryUtxo ref - return $ utxosToApi $ utxosFromList [fromJust utxo] - - getUTxOsRefsAtAddress :: GYAddress -> Text.Text -> IO [GYTxOutRef] - getUTxOsRefsAtAddress addr pToken = do - queryUtxo <- getQueryUtxo pToken - gyQueryUtxoRefsAtAddress' queryUtxo addr - - getFileRefs :: String -> IO [GYTxOutRef] - getFileRefs fileName = do - json <- BS.readFile fileName - let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) - refs = utxosRefs $ utxosFromApi utxos - return refs - - getFileUTxOs :: String -> IO (Api.UTxO ApiEra) - getFileUTxOs fileName = do - json <- BS.readFile fileName - let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) - return utxos - - compareUTxOs :: Api.UTxO ApiEra -> Api.UTxO ApiEra -> IO (Maybe String) - compareUTxOs utxosFile utxosQuery = do - let utxosFileMap = Api.unUTxO utxosFile - utxosQueryMap = Api.unUTxO utxosQuery - return $ - if Map.isSubmapOf utxosFileMap utxosQueryMap - then Nothing - else Just $ show (Map.difference utxosFileMap utxosQueryMap) - - compareRefs :: [GYTxOutRef] -> [GYTxOutRef] -> IO (Maybe String) - compareRefs refsFile refsQuery = do - let refSetQuery = Set.fromList refsQuery - refSetFile = Set.fromList refsFile - return $ - if Set.isSubsetOf refSetFile refSetQuery - then Nothing - else Just $ show (Set.difference refSetFile refSetQuery) - - updateGolden :: (Show a) => a -> IO () - updateGolden = error . show - - goldenTestUtxos :: TestName -> IO (Api.UTxO ApiEra) -> IO (Api.UTxO ApiEra) -> TestTree - goldenTestUtxos name queryData getFileData = - goldenTest name queryData getFileData compareUTxOs updateGolden - - goldenTestRefs :: TestName -> IO [GYTxOutRef] -> IO [GYTxOutRef] -> TestTree - goldenTestRefs name queryData getFileData = - goldenTest name queryData getFileData compareRefs updateGolden + where + getQueryUtxo :: Text.Text -> IO GYQueryUTxO + getQueryUtxo pToken = maestroQueryUtxo <$> networkIdToMaestroEnv pToken netId + + getUTxOsAtAddress :: GYAddress -> Text.Text -> IO (Api.UTxO ApiEra) + getUTxOsAtAddress addr pToken = do + queryUtxo <- getQueryUtxo pToken + utxos <- gyQueryUtxosAtAddress' queryUtxo addr Nothing + return $ utxosToApi utxos + + getUTxOsAtAddresses :: [GYAddress] -> Text.Text -> IO (Api.UTxO ApiEra) + getUTxOsAtAddresses addrs pToken = do + queryUtxo <- getQueryUtxo pToken + utxos <- gyQueryUtxosAtAddresses' queryUtxo addrs + return $ utxosToApi utxos + + getUTxOAtRef :: GYTxOutRef -> Text.Text -> IO (Api.UTxO ApiEra) + getUTxOAtRef ref pToken = do + queryUtxo <- getQueryUtxo pToken + utxo <- gyQueryUtxoAtTxOutRef' queryUtxo ref + return $ utxosToApi $ utxosFromList [fromJust utxo] + + getUTxOsRefsAtAddress :: GYAddress -> Text.Text -> IO [GYTxOutRef] + getUTxOsRefsAtAddress addr pToken = do + queryUtxo <- getQueryUtxo pToken + gyQueryUtxoRefsAtAddress' queryUtxo addr + + getFileRefs :: String -> IO [GYTxOutRef] + getFileRefs fileName = do + json <- BS.readFile fileName + let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) + refs = utxosRefs $ utxosFromApi utxos + return refs + + getFileUTxOs :: String -> IO (Api.UTxO ApiEra) + getFileUTxOs fileName = do + json <- BS.readFile fileName + let utxos = fromMaybe (utxosToApi $ utxosFromList []) (Aeson.decodeStrict (toStrict json)) + return utxos + + compareUTxOs :: Api.UTxO ApiEra -> Api.UTxO ApiEra -> IO (Maybe String) + compareUTxOs utxosFile utxosQuery = do + let utxosFileMap = Api.unUTxO utxosFile + utxosQueryMap = Api.unUTxO utxosQuery + return $ + if Map.isSubmapOf utxosFileMap utxosQueryMap + then Nothing + else Just $ show (Map.difference utxosFileMap utxosQueryMap) + + compareRefs :: [GYTxOutRef] -> [GYTxOutRef] -> IO (Maybe String) + compareRefs refsFile refsQuery = do + let refSetQuery = Set.fromList refsQuery + refSetFile = Set.fromList refsFile + return $ + if Set.isSubsetOf refSetFile refSetQuery + then Nothing + else Just $ show (Set.difference refSetFile refSetQuery) + + updateGolden :: Show a => a -> IO () + updateGolden = error . show + + goldenTestUtxos :: TestName -> IO (Api.UTxO ApiEra) -> IO (Api.UTxO ApiEra) -> TestTree + goldenTestUtxos name queryData getFileData = + goldenTest name queryData getFileData compareUTxOs updateGolden + + goldenTestRefs :: TestName -> IO [GYTxOutRef] -> IO [GYTxOutRef] -> TestTree + goldenTestRefs name queryData getFileData = + goldenTest name queryData getFileData compareRefs updateGolden ------------------------------------------------------------------------------- -- Mock Values diff --git a/tests/GeniusYield/Test/Providers/Mashup.hs b/tests/GeniusYield/Test/Providers/Mashup.hs index 5c9cefa9..f7f24a03 100644 --- a/tests/GeniusYield/Test/Providers/Mashup.hs +++ b/tests/GeniusYield/Test/Providers/Mashup.hs @@ -159,9 +159,9 @@ providersMashupTests configs = gyAwaitTxConfirmed def {maxAttempts = 2, checkInterval = 1_000_000} "9b50152cc5cfca6a842f32b1e886a3ffdc1a1704fa87a15a88837996b6a9df36" -- <-- A non-existing transaction id. assertFailure "Exepected GYAwaitTxException to be raised" ] - where - delayBySecond = threadDelay 1_000_000 + where + delayBySecond = threadDelay 1_000_000 -allEqual :: (Eq a) => [a] -> Bool +allEqual :: Eq a => [a] -> Bool allEqual [] = True allEqual (x : xs) = all (== x) xs diff --git a/tests/GeniusYield/Test/RefInput.hs b/tests/GeniusYield/Test/RefInput.hs index 166c06aa..244ed563 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -43,7 +43,7 @@ refInputTests = . testWallets ] -guessRefInputRun :: (GYTxMonad m) => GYTxOutRef -> GYTxOutRef -> Integer -> m () +guessRefInputRun :: GYTxMonad m => GYTxOutRef -> GYTxOutRef -> Integer -> m () guessRefInputRun refInputORef consumeRef guess = do let redeemer = Guess guess skeleton :: GYTxSkeleton 'PlutusV2 = @@ -59,7 +59,7 @@ guessRefInputRun refInputORef consumeRef guess = do <> mustHaveRefInput refInputORef buildTxBody skeleton >>= signAndSubmitConfirmed_ -refInputTrace :: (GYTxGameMonad m) => Bool -> Integer -> Integer -> Wallets -> m () +refInputTrace :: GYTxGameMonad m => Bool -> Integer -> Integer -> Wallets -> m () refInputTrace toInline actual guess Wallets {..} = do let myGuess :: Integer = guess outValue :: GYValue = valueFromLovelace 20_000_000 @@ -78,7 +78,7 @@ refInputTrace toInline actual guess Wallets {..} = do gyLogInfo' "" $ printf "Locked ORef %s" oref guessRefInputRun refInputORef oref myGuess -tryRefInputConsume :: (GYTxGameMonad m) => Wallets -> m () +tryRefInputConsume :: GYTxGameMonad m => Wallets -> m () tryRefInputConsume Wallets {..} = do -- Approach: Create a new output with 60% of total ada. Mark this UTxO as reference input and try sending this same 60%, or any amount greater than 40% of this original balance. Since coin balancer can't consume this UTxO, it won't be able to build for it. asUser w1 $ do diff --git a/tests/GeniusYield/Test/SlotConfig.hs b/tests/GeniusYield/Test/SlotConfig.hs index 4ad8e652..5090291a 100644 --- a/tests/GeniusYield/Test/SlotConfig.hs +++ b/tests/GeniusYield/Test/SlotConfig.hs @@ -21,16 +21,16 @@ import GeniusYield.Types slotToTime :: forall xs. Ouroboros.SystemStart -> Ouroboros.Interpreter xs -> Api.SlotNo -> Either String UTCTime slotToTime systemStart eraHistory x = bimap show (Ouroboros.fromRelativeTime systemStart) res - where - res = Ouroboros.interpretQuery eraHistory $ fst <$> Ouroboros.slotToWallclock x + where + res = Ouroboros.interpretQuery eraHistory $ fst <$> Ouroboros.slotToWallclock x timeToSlot :: forall xs. Ouroboros.SystemStart -> Ouroboros.Interpreter xs -> UTCTime -> Either String Api.SlotNo timeToSlot systemStart eraHistory utc = first show res - where - res = - Ouroboros.interpretQuery eraHistory $ - (\(slot, _, _) -> slot) - <$> Ouroboros.wallclockToSlot (Ouroboros.toRelativeTime systemStart utc) + where + res = + Ouroboros.interpretQuery eraHistory $ + (\(slot, _, _) -> slot) + <$> Ouroboros.wallclockToSlot (Ouroboros.toRelativeTime systemStart utc) checkTimeToSlot :: Api.EraHistory -> Property checkTimeToSlot eraHistory = @@ -44,9 +44,9 @@ checkTimeToSlot eraHistory = let actualRes = enclosingSlotFromTimePure slotCfg $ timeFromPOSIX (utcTimeToPOSIXSeconds utc) pure $ Just expected == (slotToApi <$> actualRes) - where - summaries = extractEraSummaries eraHistory - (_, eraEnd) = Ouroboros.summaryBounds summaries + where + summaries = extractEraSummaries eraHistory + (_, eraEnd) = Ouroboros.summaryBounds summaries checkSlotToTime :: Api.EraHistory -> Property checkSlotToTime eraHistory = @@ -60,9 +60,9 @@ checkSlotToTime eraHistory = slotCfg <- makeSlotConfig systemStart eraHistory let actualRes = posixSecondsToUTCTime (timeToPOSIX $ slotToBeginTimePure slotCfg gslot) pure $ expectedRes === actualRes - where - summaries = extractEraSummaries eraHistory - (_, eraEnd) = Ouroboros.summaryBounds summaries + where + summaries = extractEraSummaries eraHistory + (_, eraEnd) = Ouroboros.summaryBounds summaries slotConversionTests :: TestTree slotConversionTests = @@ -87,11 +87,11 @@ slotConversionTests = -- | Greater than or equal to system start, less than or equal to final era bound. arbitraryTimeInRange :: Ouroboros.SystemStart -> Ouroboros.EraEnd -> Gen UTCTime arbitraryTimeInRange sysStart eraEnd = arbitrary `suchThat` (\x -> x >= absStart && ltEnd x) - where - absStart = Ouroboros.getSystemStart sysStart - ltEnd x = case eraEnd of - Ouroboros.EraEnd bo -> x < Ouroboros.fromRelativeTime sysStart (Ouroboros.boundTime bo) - Ouroboros.EraUnbounded -> True + where + absStart = Ouroboros.getSystemStart sysStart + ltEnd x = case eraEnd of + Ouroboros.EraEnd bo -> x < Ouroboros.fromRelativeTime sysStart (Ouroboros.boundTime bo) + Ouroboros.EraUnbounded -> True -- | Generate an arbitrary slot before given era end. arbitrarySlotBefore :: Ouroboros.EraEnd -> Gen Api.SlotNo