diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,33 @@ +0.1.1 +===== +* [!1094](https://gitlab.com/morley-framework/morley/-/merge_requests/1094) + Deprecate morley language extensions + + Morley language extensions now require `--deprecated-morley-extensions` flag to parse. +* [!1077](https://gitlab.com/morley-framework/morley/-/merge_requests/1077) + Ithaca changes: Use `head~2` block in the `branch` field of RPC operations. +* [!1034](https://gitlab.com/morley-framework/morley/-/merge_requests/1034) + Add key revealing that uses only RPC. +* [!965](https://gitlab.com/morley-framework/morley/-/merge_requests/965) + Use Morley's fixed-size lists + + Use `SizedList` for `feeOutputParser` +* [!1072](https://gitlab.com/morley-framework/morley/-/merge_requests/1072) + Add `runCode` to Cleveland + + `runContract` now supports parameter/storage values in their RPC + representation (i.e. with bigmap IDs). +* [!1070](https://gitlab.com/morley-framework/morley/-/merge_requests/1070) + Simplify cleveland's internals & public api + + Removed `runContractSimple`, added `runContractParameters` and lenses. +* [!1060](https://gitlab.com/morley-framework/morley/-/merge_requests/1060) + Move `AsRPC` type family to `morley` +* [!978](https://gitlab.com/morley-framework/morley/-/merge_requests/978) + Make it difficult to misuse 'Show' + + Use `Buildable` and `pretty` preferrentially. + + Add `Buildable` instances to that effect for `FeeParserException`, `SecretKeyEncryptionParserException`. + + Use `displayException` instead of `show` where appropriate. + 0.1.0 ===== Initial release. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,6 @@ -MIT License Copyright (c) 2020 Tocqueville Group +MIT License +Copyright (c) 2021-2022 Oxhead Alpha +Copyright (c) 2019-2021 Tocqueville Group Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,17 +1,19 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA +-- TODO [#712]: Remove this next major release +{-# OPTIONS_GHC -Wno-deprecations #-} + module Main ( main ) where import Control.Exception.Safe (throwString) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Default (def) import Fmt (pretty) import GHC.IO.Encoding (setFileSystemEncoding) -import qualified Options.Applicative as Opt +import Options.Applicative qualified as Opt import System.IO (utf8) import Morley.Client @@ -19,21 +21,21 @@ import Morley.Client.RPC (BlockOperation(..), OperationResp(..)) import Morley.Client.RPC.Getters import Morley.Client.Util (extractAddressesFromValue) -import Morley.Michelson.Runtime (prepareContract) +import Morley.Michelson.Runtime (prepareContract, prepareContractExt) import Morley.Michelson.TypeCheck (typeCheckContract, typeCheckingWith, typeVerifyParameter) import Morley.Michelson.Typed (Contract, Contract'(..), SomeContract(..)) import Morley.Michelson.Typed.Value (Value'(..)) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address(..), formatAddress) import Morley.Tezos.Core (prettyTez) import Morley.Util.Exception (throwLeft) import Morley.Util.Main (wrapMain) -mainImpl :: ClientArgsRaw -> MorleyClientM () -mainImpl cmd = +mainImpl :: Bool -> ClientArgsRaw -> MorleyClientM () +mainImpl exts cmd = case cmd of Originate OriginateArgs{..} -> do - contract <- liftIO $ prepareContract oaMbContractFile + contract <- liftIO $ (if exts then prepareContractExt else prepareContract) oaMbContractFile let originator = oaOriginateFrom (operationHash, contractAddr) <- originateUntypedContract True oaContractName originator oaInitialBalance @@ -95,6 +97,6 @@ setFileSystemEncoding utf8 disableAlphanetWarning - ClientArgs parsedConfig cmd <- Opt.execParser morleyClientInfo + ClientArgs parsedConfig exts cmd <- Opt.execParser morleyClientInfo env <- mkMorleyClientEnv parsedConfig - runMorleyClientM env (mainImpl cmd) + runMorleyClientM env (mainImpl exts cmd) diff --git a/morley-client.cabal b/morley-client.cabal --- a/morley-client.cabal +++ b/morley-client.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morley-client -version: 0.1.0 +version: 0.1.1 synopsis: Client to interact with the Tezos blockchain description: A client to interact with the Tezos blockchain, by use of the tezos-node RPC and/or of the tezos-client binary. category: Blockchain @@ -13,7 +13,7 @@ bug-reports: https://gitlab.com/morley-framework/morley/-/issues author: Serokell, Tocqueville Group maintainer: Serokell -copyright: 2020 Tocqueville Group +copyright: 2019-2021 Tocqueville Group, 2021-2022 Oxhead Alpha license: MIT license-file: LICENSE build-type: Simple @@ -34,6 +34,7 @@ Morley.Client.Action.Operation Morley.Client.Action.Origination Morley.Client.Action.Origination.Large + Morley.Client.Action.Reveal Morley.Client.Action.Transaction Morley.Client.App Morley.Client.Env @@ -45,7 +46,6 @@ Morley.Client.RPC Morley.Client.RPC.Aeson Morley.Client.RPC.API - Morley.Client.RPC.AsRPC Morley.Client.RPC.Class Morley.Client.RPC.Error Morley.Client.RPC.Getters @@ -57,6 +57,7 @@ Morley.Client.TezosClient.Impl Morley.Client.TezosClient.Parser Morley.Client.TezosClient.Types + Morley.Client.Types Morley.Client.Util Morley.Util.Batching other-modules: @@ -86,24 +87,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections @@ -151,13 +154,10 @@ , servant-client-core , singletons , syb - , template-haskell , text - , th-reify-many , time , universum , unliftio - , vector default-language: Haskell2010 executable morley-client @@ -187,24 +187,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections @@ -232,7 +234,6 @@ main-is: Main.hs other-modules: Ingredients - Test.AsRPC Test.BigMapGet Test.Fees Test.KeyRevealing @@ -268,24 +269,26 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals - NumericUnderscores NumDecimals + NumericUnderscores OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds - QuasiQuotes QuantifiedConstraints + QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures StrictData TemplateHaskell TupleSections @@ -320,10 +323,8 @@ , safe-exceptions , servant-client-core , singletons - , syb , tasty , tasty-ant-xml , tasty-hunit-compat - , template-haskell , time default-language: Haskell2010 diff --git a/src/Morley/Client.hs b/src/Morley/Client.hs --- a/src/Morley/Client.hs +++ b/src/Morley/Client.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Morley client that connects with real Tezos network through RPC and tezos-client binary. -- For more information please refer to README. @@ -34,6 +33,9 @@ -- * RPC , BlockId (..) , HasTezosRpc (..) + , OperationInfo (..) + , OperationInfoDescriptor (..) + , RPCInput , getContract , getImplicitContractCounter , getContractStorage @@ -64,12 +66,6 @@ , readContractBigMapValue , readBigMapValueMaybe , readBigMapValue - -- ** AsRPC - , AsRPC - , deriveRPC - , deriveRPCWithStrategy - , deriveManyRPC - , deriveManyRPCWithStrategy -- * @tezos-client@ , Alias @@ -90,7 +86,7 @@ , Opt.ParserInfo -- Needed for tests ) where -import qualified Options.Applicative as Opt +import Options.Applicative qualified as Opt import Morley.Client.Action import Morley.Client.Env @@ -99,6 +95,6 @@ import Morley.Client.OnlyRPC import Morley.Client.Parser import Morley.Client.RPC -import Morley.Client.RPC.AsRPC import Morley.Client.TezosClient +import Morley.Client.Types import Morley.Client.Util diff --git a/src/Morley/Client/Action.hs b/src/Morley/Client/Action.hs --- a/src/Morley/Client/Action.hs +++ b/src/Morley/Client/Action.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | High-level actions implemented in abstract monads that -- require both RPC and @tezos-client@ functionality. @@ -9,10 +8,11 @@ ( module Morley.Client.Action.Operation , module Morley.Client.Action.Origination , module Morley.Client.Action.Transaction + , ClientInput , revealKeyUnlessRevealed ) where -import Morley.Client.Action.Common (revealKeyUnlessRevealed) +import Morley.Client.Action.Common (ClientInput, revealKeyUnlessRevealed) import Morley.Client.Action.Operation import Morley.Client.Action.Origination import Morley.Client.Action.Transaction diff --git a/src/Morley/Client/Action/Batched.hs b/src/Morley/Client/Action/Batched.hs --- a/src/Morley/Client/Action/Batched.hs +++ b/src/Morley/Client/Action/Batched.hs @@ -1,15 +1,16 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Primitives for running batched operations with a neat interface. module Morley.Client.Action.Batched ( OperationsBatch (..) , originateContractM , runTransactionM + , revealKeyM , runOperationsBatch ) where +import Control.Lens (Prism') import Fmt (Buildable(..)) import Morley.Client.Action.Common @@ -18,6 +19,7 @@ import Morley.Client.RPC.Class import Morley.Client.RPC.Types import Morley.Client.TezosClient +import Morley.Client.Types import Morley.Tezos.Address import Morley.Util.Batching @@ -38,8 +40,8 @@ newtype OperationsBatch a = OperationsBatch { unOperationsBatch :: BatchingM - (Either TransactionData OriginationData) - (Either () Address) + (OperationInfo ClientInput) + (OperationInfo Result) BatchedOperationError a } deriving newtype (Functor, Applicative) @@ -52,19 +54,29 @@ UnexpectedOperationResult -> "Got unexpected operation type within result of batched operation" +-- | A helper to run some operation. +-- +-- It accepts +runOperationM + :: (inp -> OperationInfo ClientInput) + -> (Prism' (OperationInfo Result) out) + -> inp + -> OperationsBatch out +runOperationM wrapInp unwrapOut inp = OperationsBatch $ + wrapInp inp `submitThenParse` + maybeToRight UnexpectedOperationResult . (^? unwrapOut) + -- | Perform transaction within a batch. runTransactionM :: TransactionData -> OperationsBatch () -runTransactionM td = OperationsBatch $ - Left td `submitThenParse` \case - Left () -> pass - Right _ -> Left UnexpectedOperationResult +runTransactionM = runOperationM OpTransfer _OpTransfer -- | Perform origination within a batch. originateContractM :: OriginationData -> OperationsBatch Address -originateContractM od = OperationsBatch $ - Right od `submitThenParse` \case - Left _ -> Left UnexpectedOperationResult - Right addr -> return addr +originateContractM = runOperationM OpOriginate _OpOriginate + +-- | Perform key revealing within a batch. +revealKeyM :: RevealData -> OperationsBatch () +revealKeyM = runOperationM OpReveal _OpReveal -- | Execute a batch. runOperationsBatch diff --git a/src/Morley/Client/Action/Common.hs b/src/Morley/Client/Action/Common.hs --- a/src/Morley/Client/Action/Common.hs +++ b/src/Morley/Client/Action/Common.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Module with functions that used in both transaction sending and contract -- origination. @@ -9,6 +8,8 @@ , TD (..) , TransactionData(..) , OriginationData(..) + , RevealData(..) + , ClientInput , addOperationPrefix , buildTxDataWithAlias , getAppliedResults @@ -28,7 +29,7 @@ import Data.ByteArray (ScrubbedBytes) import Data.ByteString (cons) import Data.Default (def) -import Fmt (Buildable(..), Builder, pretty, (+|), (|+)) +import Fmt (Buildable(..), Builder, (+|), (|+)) import Morley.Client.Logging (WithClientLog, logDebug) import Morley.Client.RPC.Class @@ -36,10 +37,11 @@ import Morley.Client.RPC.Getters import Morley.Client.RPC.Types import Morley.Client.TezosClient +import Morley.Client.Types import Morley.Client.Util import Morley.Micheline (TezosInt64, TezosMutez(..), toExpression) import Morley.Micheline.Expression (Expression(ExpressionString)) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Scope import Morley.Michelson.Untyped.Entrypoints import Morley.Tezos.Address @@ -97,6 +99,20 @@ , odMbFee :: Maybe Mutez } +data RevealData = RevealData + { rdPublicKey :: PublicKey + -- TODO [#516]: extract mbFee out of 'TransactionData', 'OriginationData' + -- and here, try to delete 'RevealData' datatype and pass 'PublicKey' instead + , rdMbFee :: Maybe Mutez + } + +-- | Standard operation input in morley-client interface. +data ClientInput +instance OperationInfoDescriptor ClientInput where + type TransferInfo ClientInput = TransactionData + type OriginationInfo ClientInput = OriginationData + type RevealInfo ClientInput = RevealData + toParametersInternals :: ParameterScope t => EpName @@ -118,7 +134,19 @@ preProcessOperation :: (HasTezosRpc m) => Address -> m OperationConstants preProcessOperation sourceAddr = do - ocLastBlockHash <- getHeadBlock + -- NOTE: The block hash returned by this function will be used in the "branch" + -- field of other operations (e.g. `run_operation`, `forge` and `preapply`). + -- + -- As of the introduction of the `ithaca` protocol and + -- the Tenderbake consensus algorithm, it is no longer safe to use the `head` block + -- as the branch of those operations, because that block "is not necessarily final". + -- + -- Instead, we should use the `head~2` block. + -- + -- See: + -- * https://web.archive.org/web/20220305165609/https://tezos.gitlab.io/protocols/tenderbake.html + -- * https://web.archive.org/web/20220305165704/https://tezos.gitlab.io/protocols/012_ithaca.html + ocLastBlockHash <- getBlockHash FinalHeadId ocBlockConstants <- getBlockConstants (BlockHashId ocLastBlockHash) let ocFeeConstants = def ocCounter <- getImplicitContractCounter sourceAddr @@ -188,6 +216,8 @@ | Just address <- findError _RuntimeError , Just _ <- findError _GasExhaustedOperation = throwM $ GasExhaustion address + | Just address <- findError _PreviouslyRevealedKey + = throwM $ KeyAlreadyRevealed address | otherwise = throwM $ UnexpectedRunErrors errs where @@ -217,7 +247,7 @@ -- Here and further we mostly follow the Tezos implementation: -- https://gitlab.com/tezos/tezos/-/blob/14d6dafd23eeafe30d931a41d43c99b1ebed5373/src/proto_alpha/lib_client/injection.ml#L584 - unsafeMkMutez . ceiling . sum $ + unsafe . mkMutez @Word64 . ceiling . sum $ [ toRational $ unMutez fcBase , toRational fcMutezPerOpByte * toRational opSize , toRational fcMutezPerGas * toRational gasLimit @@ -277,11 +307,8 @@ } stubSignature :: Signature -stubSignature = unsafeParseSignature +stubSignature = unsafe $ parseSignature "edsigtXomBKi5CTRf5cjATJWSyaRvhfYNHqSUGrn4SdbYRcGwQrUGjzEfQDTuqHhuA8b2d8NarZjz8TRf65WkpQmo423BtomS8Q" - where - unsafeParseSignature :: HasCallStack => Text -> Signature - unsafeParseSignature = either (error . pretty) id . parseSignature addOperationPrefix :: ByteString -> ByteString addOperationPrefix = cons 0x03 diff --git a/src/Morley/Client/Action/Operation.hs b/src/Morley/Client/Action/Operation.hs --- a/src/Morley/Client/Action/Operation.hs +++ b/src/Morley/Client/Action/Operation.hs @@ -1,19 +1,20 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Implementation of generic operations submission. module Morley.Client.Action.Operation - ( runOperations + ( Result + , runOperations , runOperationsNonEmpty -- helpers , dryRunOperationsNonEmpty ) where +import Control.Lens (has, (%=), (&~)) import Data.List (zipWith4) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Singletons (Sing, SingI, sing) -import qualified Data.Text as T +import Data.Text qualified as T import Fmt (blockListF', listF, pretty, (+|), (|+)) import Morley.Client.Action.Common @@ -23,11 +24,19 @@ import Morley.Client.RPC.Getters import Morley.Client.RPC.Types import Morley.Client.TezosClient +import Morley.Client.Types import Morley.Micheline (StringEncode(..), TezosInt64, TezosMutez(..)) import Morley.Tezos.Address import Morley.Tezos.Crypto import Morley.Util.ByteString +-- | Designates output of an operation. +data Result +instance OperationInfoDescriptor Result where + type TransferInfo Result = () + type OriginationInfo Result = Address + type RevealInfo Result = () + logOperations :: forall (runMode :: RunMode) env m. ( WithClientLog env m @@ -35,21 +44,24 @@ , SingI runMode -- We don't ask aliases with 'tezos-client' in 'DryRun' mode ) => AddressOrAlias - -> NonEmpty (Either TransactionData OriginationData) + -> NonEmpty (OperationInfo ClientInput) -> m () logOperations sender ops = do let runMode = sing @runMode opName = - if | all isLeft ops -> "transactions" - | all isRight ops -> "originations" + if | all (has _OpTransfer) ops -> "transactions" + | all (has _OpOriginate) ops -> "originations" + | all (has _OpReveal) ops -> "reveals" | otherwise -> "operations" buildOp = \case - (Left tx, mbAlias) -> + (OpTransfer tx, mbAlias) -> buildTxDataWithAlias mbAlias tx - (Right orig, _) -> + (OpOriginate orig, _) -> odName orig |+ " (temporary alias)" + (OpReveal rv, mbAlias) -> + "Key " +| rdPublicKey rv |+ maybe "" (\a -> " (" +| a |+ ")") mbAlias sender' <- case sender of addr@AddressResolved{} -> case runMode of @@ -60,10 +72,12 @@ aliases <- case runMode of SRealRun -> forM ops $ \case - Left (TransactionData tx) -> + OpTransfer (TransactionData tx) -> Just <$> (getAlias . AddressResolved $ tdReceiver tx) - _ -> + OpOriginate _ -> pure Nothing + OpReveal r -> + Just <$> (getAlias . AddressResolved . mkKeyAddress $ rdPublicKey r) SDryRun -> pure $ ops $> Nothing logInfo $ T.strip $ -- strip trailing newline @@ -81,8 +95,8 @@ , WithClientLog env m ) => AddressOrAlias - -> [Either TransactionData OriginationData] - -> m (Maybe OperationHash, [Either () Address]) + -> [OperationInfo ClientInput] + -> m (Maybe OperationHash, [OperationInfo Result]) runOperations sender operations = case operations of [] -> return (Nothing, []) op : ops -> do @@ -100,8 +114,8 @@ , WithClientLog env m ) => AddressOrAlias - -> NonEmpty (Either TransactionData OriginationData) - -> m (OperationHash, NonEmpty (Either () Address)) + -> NonEmpty (OperationInfo ClientInput) + -> m (OperationHash, NonEmpty (OperationInfo Result)) runOperationsNonEmpty sender operations = runOperationsNonEmptyHelper @'RealRun sender operations @@ -117,7 +131,7 @@ -- @runOperationsNonEmptyHelper@. type family RunResult (a :: RunMode) where RunResult 'DryRun = NonEmpty (AppliedResult, TezosMutez) - RunResult 'RealRun = (OperationHash, NonEmpty (Either () Address)) + RunResult 'RealRun = (OperationHash, NonEmpty (OperationInfo Result)) data SingRunResult :: RunMode -> Type where SDryRun :: SingRunResult 'DryRun @@ -142,7 +156,7 @@ , WithClientLog env m ) => AddressOrAlias - -> NonEmpty (Either TransactionData OriginationData) + -> NonEmpty (OperationInfo ClientInput) -> m (NonEmpty (AppliedResult, TezosMutez)) dryRunOperationsNonEmpty sender operations = runOperationsNonEmptyHelper @'DryRun sender operations @@ -158,38 +172,43 @@ , SingI runMode ) => AddressOrAlias - -> NonEmpty (Either TransactionData OriginationData) + -> NonEmpty (OperationInfo ClientInput) -> m (RunResult runMode) runOperationsNonEmptyHelper sender operations = do logOperations @runMode sender operations senderAddress <- resolveAddress sender prohibitContractSender senderAddress $ head operations mbPassword <- getKeyPassword senderAddress - when (isRealRun @runMode) $ + when (isRealRun @runMode && mayNeedSenderRevealing (toList operations)) $ revealKeyUnlessRevealed senderAddress mbPassword pp <- getProtocolParameters OperationConstants{..} <- preProcessOperation senderAddress - let convertOps i = \case - Left (TransactionData TD {..}) -> - Left TransactionOperation + let convertOps i = OperationInput commonData . \case + OpTransfer (TransactionData TD {..}) -> + OpTransfer TransactionOperation { toDestination = tdReceiver - , toCommonData = commonData , toAmount = TezosMutez tdAmount , toParameters = toParametersInternals tdEpName tdParam } - Right OriginationData{..} -> - Right OriginationOperation - { ooCommonData = commonData - , ooBalance = TezosMutez odBalance + OpOriginate OriginationData{..} -> + OpOriginate OriginationOperation + { ooBalance = TezosMutez odBalance , ooScript = mkOriginationScript odContract odStorage } + OpReveal RevealData{..} -> + OpReveal RevealOperation + { roPublicKey = rdPublicKey + } where commonData = mkCommonOperationData senderAddress (ocCounter + i) pp let opsToRun = NE.zipWith convertOps (1 :| [(2 :: TezosInt64)..]) operations - mbFees = map (either (\(TransactionData TD {..}) -> tdMbFee) odMbFee) operations + mbFees = operations <&> \case + OpTransfer (TransactionData TD {..}) -> tdMbFee + OpOriginate OriginationData{..} -> odMbFee + OpReveal RevealData{..} -> rdMbFee -- Perform run_operation with dumb signature in order -- to estimate gas cost, storage size and paid storage diff @@ -204,7 +223,7 @@ results <- getAppliedResults (Left runOp) let -- Learn how to forge given operations - forgeOp :: NonEmpty (Either TransactionOperation OriginationOperation) -> m ByteString + forgeOp :: NonEmpty OperationInput -> m ByteString forgeOp ops = fmap unHexJSONByteString . forgeOperation $ ForgeOperation { foBranch = ocLastBlockHash @@ -226,13 +245,11 @@ updateCommonData gasLimit storageLimit (TezosMutez fee) (_fee, op, mReadySignedOp) <- convergingFee - @(Either TransactionOperation OriginationOperation) + @OperationInput @(Maybe (Signature, ByteString)) -- ready operation and its signature (\fee -> - return $ bimap - (toCommonDataL %~ updateCommonDataForFee fee) - (ooCommonDataL %~ updateCommonDataForFee fee) - opToRun + return $ opToRun &~ + oiCommonDataL %= updateCommonDataForFee fee ) (\op -> do forgedOp <- forgeOp $ one op @@ -287,35 +304,41 @@ ars2 <- getAppliedResults (Right preApplyOp) case sing @runMode of SDryRun -> do - let fees = flip map updOps $ \case - Left (TransactionOperation commonData _ _ _) -> codFee commonData - Right (OriginationOperation commonData _ _) -> codFee commonData + let fees = map (codFee . oiCommonData) updOps return $ NE.zip ars2 fees SRealRun -> do operationHash <- injectOperation (HexJSONByteString signedOp) waitForOperation operationHash let contractAddrs = arOriginatedContracts <$> ars2 opsRes <- forM (NE.zip operations contractAddrs) $ \case - (Left _, []) -> - return $ Left () - (Left _, addrs) -> do + (OpTransfer _, []) -> + return $ OpTransfer () + (OpTransfer _, addrs) -> do logInfo . T.strip $ "The following contracts were originated during transactions: " +| listF addrs |+ "" - return $ Left () - (Right _, []) -> + return $ OpTransfer () + (OpOriginate _, []) -> throwM RpcOriginatedNoContracts - (Right OriginationData{..}, [addr]) -> do + (OpOriginate OriginationData{..}, [addr]) -> do logDebug $ "Saving " +| addr |+ " for " +| odName |+ "\n" rememberContract odReplaceExisting addr (AnAliasHint odName) alias <- getAlias $ AddressResolved addr logInfo $ "Originated contract: " <> pretty alias - return $ Right addr - (Right _, addrs@(_ : _ : _)) -> + return $ OpOriginate addr + (OpOriginate _, addrs@(_ : _ : _)) -> throwM $ RpcOriginatedMoreContracts addrs + (OpReveal _, _) -> + return $ OpReveal () forM_ ars2 logStatistics return (operationHash, opsRes) where + mayNeedSenderRevealing :: [OperationInfo i] -> Bool + mayNeedSenderRevealing = any \case + OpTransfer{} -> True + OpOriginate{} -> True + OpReveal{} -> False + logStatistics :: AppliedResult -> m () logStatistics ar = do let showTezosInt64 = show . unStringEncode @@ -323,8 +346,12 @@ logInfo $ "Storage size: " <> showTezosInt64 (arStorageSize ar) logInfo $ "Paid storage size diff: " <> showTezosInt64 (arPaidStorageDiff ar) - prohibitContractSender :: Address -> Either TransactionData OriginationData -> m () + prohibitContractSender :: Address -> OperationInfo ClientInput -> m () prohibitContractSender addr op = case (addr, op) of (KeyAddress _, _) -> pass - (ContractAddress _, Left _) -> throwM $ ContractSender addr "transfer" - (ContractAddress _, Right _) -> throwM $ ContractSender addr "origination" + (ContractAddress _, op') -> throwM $ ContractSender addr (opName op') + + opName = \case + OpTransfer _ -> "transfer" + OpOriginate _ -> "origination" + OpReveal _ -> "reveal" diff --git a/src/Morley/Client/Action/Origination.hs b/src/Morley/Client/Action/Origination.hs --- a/src/Morley/Client/Action/Origination.hs +++ b/src/Morley/Client/Action/Origination.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Functions to originate smart contracts via @tezos-client@ and node RPC. module Morley.Client.Action.Origination @@ -25,7 +24,7 @@ ) where import Data.Default (def) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Constraints import Morley.Client.Action.Common import Morley.Client.Action.Operation @@ -36,10 +35,11 @@ import Morley.Client.RPC.Error import Morley.Client.RPC.Types import Morley.Client.TezosClient +import Morley.Client.Types import Morley.Michelson.TypeCheck (typeCheckContractAndStorage, typeCheckingWith) import Morley.Michelson.Typed (Contract, IsoValue(..), SomeContractAndStorage(..), Value) import Morley.Michelson.Typed.Scope -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Morley.Tezos.Core import Morley.Util.Exception @@ -57,10 +57,12 @@ -> [OriginationData] -> m (Maybe OperationHash, [Address]) originateContracts sender originations = do - (opHash, res) <- runOperations sender (Right <$> originations) + (opHash, res) <- runOperations sender (OpOriginate <$> originations) return (opHash, fromOrigination <$> res) where - fromOrigination = either (error "Unexpected transaction") id + fromOrigination = \case + OpOriginate r -> r + _ -> error "Unexpectedly not origination" -- | Originate single contract originateContract diff --git a/src/Morley/Client/Action/Origination/Large.hs b/src/Morley/Client/Action/Origination/Large.hs --- a/src/Morley/Client/Action/Origination/Large.hs +++ b/src/Morley/Client/Action/Origination/Large.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- TODO: ideally the "originator" contract would be the same for every large -- contract, but due to a bug (tezos/tezos/1154) we cannot push @big_map@s right @@ -40,7 +39,7 @@ import Prelude hiding (concat, drop, swap) -import qualified Data.ByteString.Lazy as LBS +import Data.ByteString.Lazy qualified as LBS import Lorentz import Morley.Client.Action.Common @@ -50,7 +49,8 @@ import Morley.Client.TezosClient import Morley.Micheline (fromExpression) import Morley.Michelson.Interpret.Pack (packValue) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Parser (notes) +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Instr import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.Util (PushableStorageSplit(..), splitPushableStorage) @@ -129,7 +129,7 @@ => T.Contract LargeOriginatorParam (LargeOriginatorStore heavy) largeContractOriginator = T.Contract{..} where - epsNotes = T.NTOr noAnn [annQ|load_lambda|] [annQ|run_lambda|] T.starNotes T.starNotes + epsNotes = [notes|or (bytes %load_lambda) (unit %run_lambda)|] cParamNotes = fromRight T.starParamNotes $ T.mkParamNotes epsNotes noAnn stateNotes = T.NTOr noAnn [annQ|originated|] [annQ|loading|] T.starNotes T.starNotes @@ -224,7 +224,7 @@ SomeLargeContractOriginator heavyVal origContract _origLambda -> OriginationData { odReplaceExisting = odReplaceExisting $ largeContractData , odName = "largeOriginator." <> odName largeContractData - , odBalance = toMutez 0 + , odBalance = zeroMutez -- Note ^ we don't transfer any balance here, we instead do it as part of the -- last transaction (where it will be transferred to the large contract) , odContract = origContract @@ -251,7 +251,7 @@ } mkLoadLambda bytes = TransactionData @'T.TBytes $ TD { tdReceiver = originatorAddr - , tdAmount = toMutez 0 + , tdAmount = zeroMutez , tdEpName = eprName $ Call @"load_lambda" , tdParam = VBytes bytes , tdMbFee = odMbFee diff --git a/src/Morley/Client/Action/Reveal.hs b/src/Morley/Client/Action/Reveal.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Client/Action/Reveal.hs @@ -0,0 +1,63 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Functions to reveal keys via node RPC. +module Morley.Client.Action.Reveal + ( RevealData (..) + , revealKey + , revealKeyUnlessRevealed + ) where + +import Fmt ((|+)) + +import Morley.Client.Action.Common hiding (revealKeyUnlessRevealed) +import Morley.Client.Action.Operation +import Morley.Client.Logging +import Morley.Client.RPC.Class +import Morley.Client.RPC.Error +import Morley.Client.RPC.Getters +import Morley.Client.RPC.Types +import Morley.Client.TezosClient (AddressOrAlias(..), HasTezosClient) +import Morley.Client.Types +import Morley.Tezos.Address + +-- | Reveal given key. +-- +-- This is a variation of key revealing method that tries to use solely RPC. +revealKey + :: forall m env. + ( HasTezosRpc m + , HasTezosClient m + , WithClientLog env m + ) + => Address + -> RevealData + -> m OperationHash +revealKey sender revealing = do + (mOpHash, _) <- runOperations (AddressResolved sender) [OpReveal revealing] + case mOpHash of + Just hash -> return hash + _ -> throwM RpcNoOperationsRun + +-- | Reveal given key. +revealKeyUnlessRevealed + :: forall m env. + ( HasTezosRpc m + , HasTezosClient m + , WithClientLog env m + ) + => Address + -> RevealData + -> m () +revealKeyUnlessRevealed sender param = do + -- An optimization for the average case, but we can't rely on it in + -- distributed environment + mManagerKey <- getManagerKey sender + case mManagerKey of + Just _ -> logDebug $ sender |+ " address has already revealed key" + Nothing -> ignoreAlreadyRevealedError $ void (revealKey sender param) + where + ignoreAlreadyRevealedError action = + action `catch` \case + RunCodeErrors [PreviouslyRevealedKey _] -> pass + e -> throwM e diff --git a/src/Morley/Client/Action/Transaction.hs b/src/Morley/Client/Action/Transaction.hs --- a/src/Morley/Client/Action/Transaction.hs +++ b/src/Morley/Client/Action/Transaction.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Functions to submit transactions via @tezos-client@ and node RPC. module Morley.Client.Action.Transaction @@ -26,7 +25,8 @@ import Morley.Client.RPC.Types import Morley.Client.TezosClient.Class import Morley.Client.TezosClient.Types -import qualified Morley.Michelson.Typed as T +import Morley.Client.Types +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Scope import Morley.Michelson.Untyped.Entrypoints import Morley.Tezos.Address @@ -44,7 +44,7 @@ => Address -> [TransactionData] -> m (Maybe OperationHash) runTransactions sender transactions = do - (opHash, _) <- runOperations (AddressResolved sender) (Left <$> transactions) + (opHash, _) <- runOperations (AddressResolved sender) (OpTransfer <$> transactions) return opHash -- | Lorentz version of 'TransactionData'. diff --git a/src/Morley/Client/App.hs b/src/Morley/Client/App.hs --- a/src/Morley/Client/App.hs +++ b/src/Morley/Client/App.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Functions useful for implementing instances of type classes from this package. -- Monads and actual instances are defined in separate modules. @@ -40,10 +39,11 @@ , handleInvalidCounterRpc ) where +import Unsafe qualified (fromIntegral, (!!)) + import Control.Concurrent (threadDelay) -import qualified Data.Aeson as Aeson -import qualified Data.Binary.Builder as Binary -import Data.List ((!!)) +import Data.Aeson qualified as Aeson +import Data.Binary.Builder qualified as Binary import Data.Text (isInfixOf) import Fmt (Buildable(..), Builder, build, pretty, (+|), (|+)) import Network.HTTP.Types (Status(..), renderQuery) @@ -54,11 +54,10 @@ import System.Random (randomRIO) import UnliftIO (MonadUnliftIO) import UnliftIO.Timeout (timeout) -import qualified Unsafe (fromIntegral) import Morley.Client.Logging (WithClientLog, logDebug) import Morley.Client.RPC -import qualified Morley.Client.RPC.API as API +import Morley.Client.RPC.API qualified as API import Morley.Micheline (Expression, TezosInt64, TezosNat, unTezosMutez) import Morley.Tezos.Address (Address) import Morley.Tezos.Core (ChainId, Mutez, parseChainId) @@ -286,7 +285,7 @@ waitBeforeRetry :: (MonadIO m, HasTezosRpc m, WithClientLog env m) => m () waitBeforeRetry = do i <- liftIO $ - (blockAwaitAmounts !!) <$> randomRIO (0, length blockAwaitAmounts - 1) + (blockAwaitAmounts Unsafe.!!) <$> randomRIO (0, length blockAwaitAmounts - 1) logDebug $ "Invalid counter error occurred, retrying the request after " <> show i <> " blocks" ProtocolParameters {..} <- getProtocolParameters -- Invalid counter error may occur in case we try to perform multiple operations diff --git a/src/Morley/Client/Env.hs b/src/Morley/Client/Env.hs --- a/src/Morley/Client/Env.hs +++ b/src/Morley/Client/Env.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Runtime environment for @morley-client@. @@ -18,7 +17,7 @@ import Morley.Util.Lens (makeLensesWith, postfixLFields) import Servant.Client (ClientEnv) -import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519 +import Morley.Tezos.Crypto.Ed25519 qualified as Ed25519 import Morley.Client.Logging (ClientLogAction) import Morley.Client.TezosClient.Types diff --git a/src/Morley/Client/Full.hs b/src/Morley/Client/Full.hs --- a/src/Morley/Client/Full.hs +++ b/src/Morley/Client/Full.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# LANGUAGE InstanceSigs #-} @@ -21,11 +20,10 @@ import Morley.Client.Env (MorleyClientEnv'(..)) import Morley.Client.RPC.Class import Morley.Client.TezosClient.Class -import Morley.Client.TezosClient.Impl (TezosClientError(..)) -import qualified Morley.Client.TezosClient.Impl as TezosClient +import Morley.Client.TezosClient.Impl qualified as TezosClient import Morley.Client.TezosClient.Types import Morley.Tezos.Crypto (Signature(..)) -import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519 +import Morley.Tezos.Crypto.Ed25519 qualified as Ed25519 type MorleyClientEnv = MorleyClientEnv' MorleyClientM @@ -40,7 +38,7 @@ -- in case of invalid counter error. runMorleyClientM :: MorleyClientEnv -> MorleyClientM a -> IO a runMorleyClientM env client = - runReaderT (unMorleyClientM (retryInvalidCounter client)) env + runReaderT (unMorleyClientM client) env instance HasLog MorleyClientEnv Message MorleyClientM where getLogAction = mceLogAction @@ -102,16 +100,3 @@ runCodeAtBlock = runCodeImpl getChainId = getChainIdImpl getManagerKeyAtBlock = getManagerKeyImpl - --- | Helper function that retries 'MorleyClientM' action in case of counter error. -retryInvalidCounter :: forall a. MorleyClientM a -> MorleyClientM a -retryInvalidCounter action = do - action `catch` handleInvalidCounterRpc retryAction - `catch` handleTezosClientError - where - handleTezosClientError :: TezosClientError -> MorleyClientM a - handleTezosClientError = \case - CounterIsAlreadyUsed _ _ -> retryAction - anotherErr -> throwM anotherErr - - retryAction = waitBeforeRetry >> retryInvalidCounter action diff --git a/src/Morley/Client/Init.hs b/src/Morley/Client/Init.hs --- a/src/Morley/Client/Init.hs +++ b/src/Morley/Client/Init.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Morley client initialization. module Morley.Client.Init @@ -28,7 +27,7 @@ import Morley.Client.RPC.HttpClient import Morley.Client.TezosClient.Impl (getTezosClientConfig) import Morley.Client.TezosClient.Types -import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519 +import Morley.Tezos.Crypto.Ed25519 qualified as Ed25519 -- | Data necessary for morley client initialization. data MorleyClientConfig = MorleyClientConfig diff --git a/src/Morley/Client/Logging.hs b/src/Morley/Client/Logging.hs --- a/src/Morley/Client/Logging.hs +++ b/src/Morley/Client/Logging.hs @@ -20,8 +20,8 @@ , logFlush ) where --- Implicit import should be fine because it's a tiny re-export module. import Colog + (LogAction(..), Message, WithLog, logDebug, logError, logException, logInfo, logWarning) import System.IO (hFlush) -- | 'LogAction' with fixed message parameter. diff --git a/src/Morley/Client/OnlyRPC.hs b/src/Morley/Client/OnlyRPC.hs --- a/src/Morley/Client/OnlyRPC.hs +++ b/src/Morley/Client/OnlyRPC.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | An alternative implementation of @morley-client@ that does not require -- @tezos-client@ and has some limitations because of that (not all methods @@ -16,7 +15,7 @@ import Colog (HasLog(..), Message) import Control.Lens (at) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Fmt ((+|), (|+)) import Servant.Client (BaseUrl, ClientEnv) import Servant.Client.Core (RunClient(..)) @@ -133,7 +132,6 @@ -- Stateful actions that simply do nothing because there is no persistent state. rememberContract = \_ _ _ -> pass - importKey = \_ _ _ -> pass -- We return a dummy value here, because this function is used in a lot of -- places and with an exception here it's not possible to send transactions. @@ -144,6 +142,7 @@ -- Actions that are not supported and simply throw exceptions. genKey _ = throwM $ UnsupportedByOnlyRPC "genKey" genFreshKey _ = throwM $ UnsupportedByOnlyRPC "genFreshKey" + importKey _ _ _ = throwM $ UnsupportedByOnlyRPC "importKey" revealKey _ _ = throwM $ UnsupportedByOnlyRPC "revealKey" resolveAddressMaybe _ = throwM $ UnsupportedByOnlyRPC "resolveAddressMaybe" getPublicKey _ = throwM $ UnsupportedByOnlyRPC "getPublicKey" diff --git a/src/Morley/Client/Parser.hs b/src/Morley/Client/Parser.hs --- a/src/Morley/Client/Parser.hs +++ b/src/Morley/Client/Parser.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Morley.Client.Parser ( ClientArgs (..) @@ -22,7 +21,7 @@ import Options.Applicative (ReadM, eitherReader, help, long, metavar, option, short, strOption, subparser, value) -import qualified Options.Applicative as Opt +import Options.Applicative qualified as Opt import Options.Applicative.Help.Pretty (Doc, linebreak) import Servant.Client (BaseUrl(..), parseBaseUrl) @@ -30,13 +29,13 @@ import Morley.Client.Init import Morley.Client.RPC.Types (BlockId(HeadId)) import Morley.Client.TezosClient.Types (AddressOrAlias, AliasHint) -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Core import Morley.Util.CLI (mkCLOptionParser, mkCommandParser) import Morley.Util.Named data ClientArgs - = ClientArgs MorleyClientConfig ClientArgsRaw + = ClientArgs MorleyClientConfig Bool ClientArgsRaw data ClientArgsRaw = Originate OriginateArgs @@ -72,7 +71,11 @@ -- | Parser for the @morley-client@ executable. clientParser :: Opt.Parser ClientArgs -clientParser = ClientArgs <$> clientConfigParser (pure Nothing) <*> argsRawParser +clientParser = ClientArgs <$> clientConfigParser (pure Nothing) <*> enableExtsOption <*> argsRawParser + where + enableExtsOption = Opt.switch $ + long "deprecated-morley-extensions" <> + help "Enable parsing deprecated Morley extensions" clientConfigParser :: Opt.Parser (Maybe Text) -> Opt.Parser MorleyClientConfig clientConfigParser prefixParser = do @@ -184,7 +187,7 @@ oaContractName <- contractNameOption oaInitialBalance <- mutezOption - (Just (toMutez 0)) + (Just zeroMutez) (#name :! "initial-balance") (#help :! "Inital balance of the contract") oaInitialStorage <- @@ -227,7 +230,7 @@ (#help :! "Address or alias of the contract that receives transfer") taAmount <- mutezOption - (Just (toMutez 0)) + (Just zeroMutez) (#name :! "amount") (#help :! "Transfer amount") taParameter <- @@ -267,4 +270,4 @@ -- | Utility reader to use in parsing 'BaseUrl'. baseUrlReader :: ReadM BaseUrl -baseUrlReader = eitherReader $ first show . parseBaseUrl +baseUrlReader = eitherReader $ first displayException . parseBaseUrl diff --git a/src/Morley/Client/RPC/API.hs b/src/Morley/Client/RPC/API.hs --- a/src/Morley/Client/RPC/API.hs +++ b/src/Morley/Client/RPC/API.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | This module contains servant types for tezos-node -- RPC API. diff --git a/src/Morley/Client/RPC/AsRPC.hs b/src/Morley/Client/RPC/AsRPC.hs deleted file mode 100644 --- a/src/Morley/Client/RPC/AsRPC.hs +++ /dev/null @@ -1,745 +0,0 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ - --- TODO [#549]: remove this pragma -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | This module contains a type family for converting a type to its RPC representation, --- and TemplateHaskell functions for deriving RPC representations for custom types. -module Morley.Client.RPC.AsRPC - ( AsRPC - , deriveRPC - , deriveRPCWithStrategy - , deriveManyRPC - , deriveManyRPCWithStrategy - -- * Conversions - , valueAsRPC - , notesAsRPC - -- * Entailments - , rpcSingIEvi - , rpcHasNoOpEvi - , rpcHasNoBigMapEvi - , rpcHasNoNestedBigMapsEvi - , rpcHasNoContractEvi - , rpcStorageScopeEvi - ) where - -import Prelude hiding (Type) - -import Control.Lens.Plated (universe) -import Data.Constraint (Dict(..), (***), (:-)(Sub), (\\)) -import qualified Data.List as List ((\\)) -import Data.Singletons (Sing, withSingI) -import qualified GHC.Generics as G -import Language.Haskell.TH - (Con(InfixC, NormalC, RecC), Cxt, Dec(DataD, NewtypeD, TySynD, TySynInstD), - DerivStrategy(AnyclassStrategy), Info(TyConI), Kind, Loc(loc_module), Name, Q, TyLit(StrTyLit), - TySynEqn(..), TyVarBndr, Type(..), cxt, location, mkName, nameBase, reify, reifyInstances, - standaloneDerivWithStrategyD) -import Language.Haskell.TH.ReifyMany (reifyManyTyCons) -import Language.Haskell.TH.ReifyMany.Internal (decConcreteNames) - -import Lorentz hiding (TAddress, TSignature, drop, not) -import qualified Lorentz as L -import Lorentz.Extensible (Extensible) -import Morley.Michelson.Typed - (ContractPresence(ContractAbsent), HasNoBigMap, HasNoContract, HasNoNestedBigMaps, HasNoOp, - Notes(..), OpPresence(..), SingI(sing), SingT(..), StorageScope, T(..), Value'(..), - checkContractTypePresence, checkOpPresence) -import Morley.Util.Named hiding (Name(..)) -import Morley.Util.TH (isTypeAlias, lookupTypeNameOrFail) - -{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-} - ----------------------------------------------------------------------------- --- AsRPC ----------------------------------------------------------------------------- - --- | A type-level function that maps a type to its Tezos RPC representation. --- --- For example, when we retrieve a contract's storage using the Tezos RPC, all its 'BigMap's will be replaced --- by 'BigMapId's. --- --- So if a contract has a storage of type @T@, when we call the Tezos RPC --- to retrieve it, we must deserialize the micheline expression to the type @AsRPC T@. --- --- > AsRPC (BigMap Integer MText) ~ BigMapId Integer MText --- > AsRPC [BigMap Integer MText] ~ [BigMapId Integer MText] --- > AsRPC (MText, (Address, BigMap Integer MText)) ~ (MText, (Address, BigMapId Integer MText)) --- --- The following law holds IFF a type @t@ has an IsoValue instance: --- --- > ToT (AsRPC t) ~ AsRPC (ToT t) --- -type family AsRPC (a :: k) :: k - --- Value -type instance AsRPC (Value' instr t) = Value' instr (AsRPC t) -type instance AsRPC 'TKey = 'TKey -type instance AsRPC 'TUnit = 'TUnit -type instance AsRPC 'TSignature = 'TSignature -type instance AsRPC 'TChainId = 'TChainId -type instance AsRPC ('TOption t) = 'TOption (AsRPC t) -type instance AsRPC ('TList t) = 'TList (AsRPC t) -type instance AsRPC ('TSet t) = 'TSet t -type instance AsRPC 'TOperation = 'TOperation -type instance AsRPC ('TContract t) = 'TContract t -type instance AsRPC ('TTicket t) = 'TTicket t -type instance AsRPC ('TPair t1 t2) = 'TPair (AsRPC t1) (AsRPC t2) -type instance AsRPC ('TOr t1 t2) = 'TOr (AsRPC t1) (AsRPC t2) -type instance AsRPC ('TLambda t1 t2) = 'TLambda t1 t2 -type instance AsRPC ('TMap k v) = 'TMap k (AsRPC v) -type instance AsRPC ('TBigMap _ _) = 'TNat -type instance AsRPC 'TInt = 'TInt -type instance AsRPC 'TNat = 'TNat -type instance AsRPC 'TString = 'TString -type instance AsRPC 'TBytes = 'TBytes -type instance AsRPC 'TMutez = 'TMutez -type instance AsRPC 'TBool = 'TBool -type instance AsRPC 'TKeyHash = 'TKeyHash -type instance AsRPC 'TTimestamp = 'TTimestamp -type instance AsRPC 'TAddress = 'TAddress -type instance AsRPC 'TNever = 'TNever -type instance AsRPC 'TBls12381Fr = 'TBls12381Fr -type instance AsRPC 'TBls12381G1 = 'TBls12381G1 -type instance AsRPC 'TBls12381G2 = 'TBls12381G2 -type instance AsRPC 'TChest = 'TChest -type instance AsRPC 'TChestKey = 'TChestKey - --- Morley types - --- Note: We don't recursively apply @AsRPC@ to @k@ or @v@ because --- bigmaps cannot contain nested bigmaps. --- If this constraint is ever lifted, we'll have to change this instance --- to @BigMapId k (AsRPC v)@ -type instance AsRPC (BigMap k v) = BigMapId k v -type instance AsRPC Integer = Integer -type instance AsRPC Natural = Natural -type instance AsRPC MText = MText -type instance AsRPC Bool = Bool -type instance AsRPC ByteString = ByteString -type instance AsRPC Mutez = Mutez -type instance AsRPC KeyHash = KeyHash -type instance AsRPC Timestamp = Timestamp -type instance AsRPC Address = Address -type instance AsRPC EpAddress = EpAddress -type instance AsRPC (L.TAddress p vd) = L.TAddress p vd -type instance AsRPC (FutureContract p) = FutureContract p -type instance AsRPC PublicKey = PublicKey -type instance AsRPC Signature = Signature -type instance AsRPC ChainId = ChainId -type instance AsRPC Never = Never -type instance AsRPC Bls12381Fr = Bls12381Fr -type instance AsRPC Bls12381G1 = Bls12381G1 -type instance AsRPC Bls12381G2 = Bls12381G2 -type instance AsRPC () = () -type instance AsRPC [a] = [AsRPC a] -type instance AsRPC (Maybe a) = Maybe (AsRPC a) -type instance AsRPC (Either l r) = Either (AsRPC l) (AsRPC r) -type instance AsRPC (a, b) = (AsRPC a, AsRPC b) -type instance AsRPC (Set a) = Set a -type instance AsRPC (Map k v) = Map k (AsRPC v) -type instance AsRPC Operation = Operation -type instance AsRPC (Identity a) = Identity (AsRPC a) -type instance AsRPC (NamedF Identity a name) = NamedF Identity (AsRPC a) name -type instance AsRPC (NamedF Maybe a name) = NamedF Maybe (AsRPC a) name -type instance AsRPC (a, b, c) = (AsRPC a, AsRPC b, AsRPC c) -type instance AsRPC (a, b, c, d) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d) -type instance AsRPC (a, b, c, d, e) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d, AsRPC e) -type instance AsRPC (a, b, c, d, e, f) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d, AsRPC e, AsRPC f) -type instance AsRPC (a, b, c, d, e, f, g) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d, AsRPC e, AsRPC f, AsRPC g) -type instance AsRPC (ContractRef arg) = ContractRef arg -type instance AsRPC Chest = Chest -type instance AsRPC ChestKey = ChestKey - --- Lorentz types -type instance AsRPC (Packed a) = Packed a -type instance AsRPC (L.TSignature a) = L.TSignature a -type instance AsRPC (Hash alg a) = Hash alg a -type instance AsRPC (L.TAddress cp) = L.TAddress cp -type instance AsRPC Empty = Empty -type instance AsRPC (Extensible x) = Extensible x -type instance AsRPC (View_ a r) = View_ a r -type instance AsRPC (Void_ a r) = Void_ a r -type instance AsRPC (UParam entries) = UParam entries -type instance AsRPC (inp :-> out) = inp :-> out -type instance AsRPC (ShouldHaveEntrypoints a) = ShouldHaveEntrypoints a -type instance AsRPC (ParameterWrapper deriv cp) = ParameterWrapper deriv (AsRPC cp) -type instance AsRPC L.OpenChest = L.OpenChest -type instance AsRPC (L.ChestT a) = L.ChestT a -type instance AsRPC (L.OpenChestT a) = L.OpenChestT a - ----------------------------------------------------------------------------- --- Derive RPC repr ----------------------------------------------------------------------------- - --- | Derive an RPC representation for a type, as well as instances for 'Generic', 'IsoValue' and 'AsRPC'. --- --- > data ExampleStorage a b = ExampleStorage --- > { esField1 :: Integer --- > , esField2 :: [BigMap Integer MText] --- > , esField3 :: a --- > } --- > deriving stock Generic --- > deriving anyclass IsoValue --- > --- > deriveRPC "ExampleStorage" --- --- Will generate: --- --- > data ExampleStorageRPC a b = ExampleStorageRPC --- > { esField1RPC :: AsRPC Integer --- > , esField2RPC :: AsRPC [BigMap Integer MText] --- > , esField3RPC :: AsRPC a --- > } --- > --- > type instance AsRPC (ExampleStorage a b) = ExampleStorageRPC a b --- > deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (ExampleStorageRPC a b) --- > instance Generic (ExampleStorageRPC a b) where --- > ... -deriveRPC :: String -> Q [Dec] -deriveRPC typeStr = deriveRPCWithStrategy typeStr haskellBalanced - --- | Recursively enumerate @data@, @newtype@ and @type@ declarations, --- and derives an RPC representation for each type that doesn't yet have one. --- --- You can also pass in a list of types for which you _don't_ want --- an RPC representation to be derived. --- --- In this example, 'deriveManyRPC' will generate an RPC --- representation for @A@ and @B@, --- but not for @C@ (because we explicitly said we don't want one) --- or @D@ (because it already has one). --- --- > data B = B --- > data C = C --- > data D = D --- > deriveRPC "D" --- > --- > data A = A B C D --- > deriveManyRPC "A" ["C"] -deriveManyRPC :: String -> [String] -> Q [Dec] -deriveManyRPC typeStr skipTypes = - deriveManyRPCWithStrategy typeStr skipTypes haskellBalanced - --- | Same as 'deriveManyRPC', but uses a custom strategy for deriving a 'Generic' instance. -deriveManyRPCWithStrategy :: String -> [String] -> GenericStrategy -> Q [Dec] -deriveManyRPCWithStrategy typeStr skipTypes gs = do - skipTypeNames <- traverse lookupTypeNameOrFail skipTypes - typeName <- lookupTypeNameOrFail typeStr - whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'." - allTypeNames <- findWithoutInstance typeName - join <$> forM (allTypeNames List.\\ skipTypeNames) \name -> deriveRPCWithStrategy' name gs - where - - -- | Recursively enumerate @data@, @newtype@ and @type@ declarations, - -- and returns the names of only @data@ and @newtype@ of those that - -- don't yet have an 'AsRPC' instance. Type aliases don't need instances - -- and respectively there is no need to derive 'AsRPC' for them. - findWithoutInstance :: Name -> Q [Name] - findWithoutInstance typeName = - fmap fst <$> - reifyManyTyCons - (\(name, dec) -> - ifM (isTypeAlias name) - (pure (False, decConcreteNames dec)) - (ifM (hasRPCInstance name) - (pure (False, [])) - (pure (True, decConcreteNames dec))) - ) - [typeName] - - hasRPCInstance :: Name -> Q Bool - hasRPCInstance typeName = do - deriveFullTypeFromName typeName >>= \case - Nothing -> - fail $ "Found a field with a type that is neither a 'data' nor a 'newtype' nor a 'type': " - <> show typeName - Just typ -> - not . null <$> reifyInstances ''AsRPC [typ] - - -- | Given a type name, return the corresponding type expression - -- (applied to any type variables, if necessary). - -- - -- For example, assuming a data type like @data F a b = ...@ exists in the type environment, - -- then @deriveFullTypeFromName ''F@ will return the type expression @[t|F a b|]@. - -- - -- Note that only @data@, @newtype@ and @type@ declarations are supported at the moment. - deriveFullTypeFromName :: Name -> Q (Maybe Type) - deriveFullTypeFromName typeName = do - typeInfo <- reify typeName - case typeInfo of - TyConI (DataD _ _ vars mKind _ _) -> Just <$> deriveFullType typeName mKind vars - TyConI (NewtypeD _ _ vars mKind _ _) -> Just <$> deriveFullType typeName mKind vars - TyConI (TySynD _ vars _) -> Just <$> deriveFullType typeName Nothing vars - _ -> pure Nothing - --- | Same as 'deriveRPC', but uses a custom strategy for deriving a 'Generic' instance. -deriveRPCWithStrategy :: String -> GenericStrategy -> Q [Dec] -deriveRPCWithStrategy typeStr gs = do - typeName <- lookupTypeNameOrFail typeStr - whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'." - deriveRPCWithStrategy' typeName gs - -deriveRPCWithStrategy' :: Name -> GenericStrategy -> Q [Dec] -deriveRPCWithStrategy' typeName gs = do - (_, decCxt, mKind, tyVars, constructors) <- reifyDataType typeName - - -- TODO: use `reifyInstances` to check that 'AsRPC' exists for `fieldType` - -- Print user-friendly error msg if it doesn't. - let typeNameRPC = convertName typeName - constructorsRPC <- traverse convertConstructor constructors - fieldTypesRPC <- getFieldTypes constructorsRPC - - derivedType <- deriveFullType typeName mKind tyVars - derivedTypeRPC <- deriveFullType typeNameRPC mKind tyVars - - -- Note: we can't use `makeRep0Inline` to derive a `Rep` instance for `derivedTypeRPC` - -- It internally uses `reify` to lookup info about `derivedTypeRPC`, and because `derivedTypeRPC` hasn't - -- been spliced *yet*, the lookup fails. - -- So, instead, we fetch the `Rep` instance for `derivedType`, and - -- append "RPC" to the type/constructor/field names in its metadata. - -- - -- If, for some reason, we find out that this approach doesn't work for some edge cases, - -- we should get rid of it and patch the @generic-deriving@ package to export a version of `makeRep0Inline` - -- that doesn't use `reify` (it should be easy enough). - repInstance <- reifyRepInstance typeName derivedType - currentModuleName <- loc_module <$> location - let repTypeRPC = convertRep currentModuleName repInstance - typeDecOfRPC <- mkTypeDeclaration typeName decCxt typeNameRPC tyVars mKind constructorsRPC - - mconcat <$> sequence - [ pure . one $ typeDecOfRPC - , mkAsRPCInstance derivedType derivedTypeRPC - , mkIsoValueInstance fieldTypesRPC derivedTypeRPC - , customGeneric' (Just repTypeRPC) typeNameRPC derivedTypeRPC constructorsRPC gs - ] - - where - -- | Given the field type @FieldType a b@, returns @AsRPC (FieldType a b)@. - convertFieldType :: Type -> Type - convertFieldType tp = ConT ''AsRPC `AppT` tp - - convertNameStr :: String -> String - convertNameStr s = s <> "RPC" - - convertName :: Name -> Name - convertName = mkName . convertNameStr . nameBase - - -- | Given the constructor - -- @C { f :: Int }@, - -- returns the constructor - -- @CRPC { fRPC :: AsRPC Int }@. - convertConstructor :: Con -> Q Con - convertConstructor = \case - RecC conName fields -> pure $ - RecC - (convertName conName) - (fields <&> \(fieldName, fieldBang, fieldType) -> - (convertName fieldName, fieldBang, convertFieldType fieldType) - ) - NormalC conName fields -> pure $ - NormalC (convertName conName) (second convertFieldType <$> fields) - InfixC fieldType1 conName fieldType2 -> pure $ - InfixC (second convertFieldType fieldType1) (convertName conName) (second convertFieldType fieldType2) - constr -> fail $ "Unsupported constructor for '" <> show typeName <> "': " <> show constr - - -- | Get a list of all the unique types of all the fields of all the given constructors. - getFieldTypes :: [Con] -> Q [Type] - getFieldTypes constrs = ordNub . join <$> forM constrs \case - RecC _ fields -> pure $ fields <&> \(_, _, fieldType) -> fieldType - NormalC _ fields -> pure $ snd <$> fields - InfixC field1 _ field2 -> pure [snd field1, snd field2] - constr -> fail $ "Unsupported constructor for '" <> show typeName <> "': " <> show constr - - mkTypeDeclaration :: Name -> Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> [Con] -> Q Dec - mkTypeDeclaration tyName decCxt typeNameRPC tyVars mKind constructorsRPC = do - typeInfo <- reify tyName - case typeInfo of - TyConI DataD {} -> pure $ DataD decCxt typeNameRPC tyVars mKind constructorsRPC [] - TyConI NewtypeD {} -> (case constructorsRPC of - [con] -> pure $ NewtypeD decCxt typeNameRPC tyVars mKind con [] - _ -> fail "Newtype has only one constructor") - _ -> fail $ "Only newtypes and data types are supported, but '" <> - show tyName <> "' is:\n" <> show typeInfo - - -- | Traverse a 'Rep' type and: - -- - -- 1. Inspect its metadata and append @RPC@ to the type/constructor/field names. - -- 2. Convert field types (e.g. @T@ becomes @AsRPC T@). - -- 3. Replace the Rep's module name with the name of the module of where this Q is being spliced. - convertRep :: String -> TySynEqn -> Type - convertRep currentModuleName (TySynEqn _tyVars _lhs rhs) = go rhs - where - go :: Type -> Type - go = \case - -- Rename type name and module name - PromotedT t `AppT` LitT (StrTyLit tyName) `AppT` LitT (StrTyLit _moduleName) - | t == 'G.MetaData - -> PromotedT t `AppT` LitT (StrTyLit (convertNameStr tyName)) `AppT` LitT (StrTyLit currentModuleName) - -- Rename constructor names - PromotedT t `AppT` LitT (StrTyLit conName) - | t == 'G.MetaCons - -> PromotedT t `AppT` LitT (StrTyLit (convertNameStr conName)) - -- Rename field names - PromotedT t `AppT` (PromotedT just `AppT` LitT (StrTyLit fieldName)) - | t == 'G.MetaSel - -> PromotedT t `AppT` (PromotedT just `AppT` LitT (StrTyLit (convertNameStr fieldName))) - -- Replace field type @T@ with @AsRPC T@ - ConT x `AppT` fieldType - | x == ''G.Rec0 - -> ConT x `AppT` convertFieldType fieldType - x `AppT` y -> go x `AppT` go y - x -> x - - -- | Lookup the generic 'Rep' type instance for the given type. - reifyRepInstance :: Name -> Type -> Q TySynEqn - reifyRepInstance name tp = - reifyInstances ''G.Rep [tp] >>= \case - [TySynInstD repInstance] -> pure repInstance - (_:_) -> fail $ "Found multiple instances of 'Generic' for '" <> show name <> "'." - [] -> fail $ "Type '" <> show name <> "' must implement 'Generic'." - - -- | Given the type @Foo a b = Foo a@, generate an 'IsoValue' instance like: - -- - -- > deriving anyclass instance IsoValue (AsRPC a) => IsoValue (FooRPC a b) - -- - -- Note that if a type variable @t@ is a phantom type variable, then no @IsoValue (AsRPC t)@ - -- constraint is generated for it. - mkIsoValueInstance :: [Type] -> Type -> Q [Dec] - mkIsoValueInstance fieldTypes tp = - one <$> standaloneDerivWithStrategyD (Just AnyclassStrategy) constraints [t|IsoValue $(pure tp)|] - where - constraints :: Q Cxt - constraints = - cxt $ filter hasTyVar fieldTypes <&> \fieldType -> - [t|IsoValue $(pure fieldType)|] - - hasTyVar :: Type -> Bool - hasTyVar ty = - flip any (universe ty) \case - VarT _ -> True - _ -> False - - mkAsRPCInstance :: Type -> Type -> Q [Dec] - mkAsRPCInstance tp tpRPC = - [d| - type instance AsRPC $(pure tp) = $(pure tpRPC) - |] - ----------------------------------------------------------------------------- --- Conversions ----------------------------------------------------------------------------- - --- | Replace all big_maps in a value with the respective big_map IDs. --- --- Throws an error if it finds a big_map without an ID. -valueAsRPC :: HasCallStack => Value t -> Value (AsRPC t) -valueAsRPC v = - case v of - VKey {} -> v - VUnit {} -> v - VSignature {} -> v - VChainId {} -> v - VChest {} -> v - VChestKey {} -> v - VOption (vMaybe :: Maybe (Value elem)) -> - withDict (rpcSingIEvi @elem) $ - VOption $ valueAsRPC <$> vMaybe - VList (vList :: [Value elem]) -> - withDict (rpcSingIEvi @elem) $ - VList $ valueAsRPC <$> vList - VSet {} -> v - VOp {} -> v - VContract {} -> v - VTicket {} -> v - VPair (x, y) -> VPair (valueAsRPC x, valueAsRPC y) - VOr (vEither :: Either (Value l) (Value r)) -> - withDict (rpcSingIEvi @l *** rpcSingIEvi @r) $ - case vEither of - Right r -> VOr (Right (valueAsRPC r)) - Left l -> VOr (Left (valueAsRPC l)) - VLam {} -> v - VMap (vMap :: Map (Value k) (Value v)) -> - withDict (rpcSingIEvi @v) $ - VMap $ valueAsRPC <$> vMap - VBigMap (Just bmId) _ -> VNat bmId - VBigMap Nothing _ -> - error $ unlines - [ "Expected all big_maps to have an ID, but at least one big_map didn't." - , "This is most likely a bug." - ] - VInt {} -> v - VNat {} -> v - VString {} -> v - VBytes {} -> v - VMutez {} -> v - VBool {} -> v - VKeyHash {} -> v - VTimestamp {} -> v - VAddress {} -> v - VBls12381Fr {} -> v - VBls12381G1 {} -> v - VBls12381G2 {} -> v - --- | Replace all @big_map@ annotations in a value with @nat@ annotations. -notesAsRPC :: Notes t -> Notes (AsRPC t) -notesAsRPC notes = - case notes of - NTKey {} -> notes - NTUnit {} -> notes - NTSignature {} -> notes - NTChainId {} -> notes - NTChest {} -> notes - NTChestKey {} -> notes - NTOption typeAnn elemNotes -> NTOption typeAnn $ notesAsRPC elemNotes - NTList typeAnn elemNotes -> NTList typeAnn $ notesAsRPC elemNotes - NTSet {} -> notes - NTOperation {} -> notes - NTContract {} -> notes - NTTicket {} -> notes - NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 notes1 notes2 -> - NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 (notesAsRPC notes1) (notesAsRPC notes2) - NTOr typeAnn fieldAnn1 fieldAnn2 notes1 notes2 -> - NTOr typeAnn fieldAnn1 fieldAnn2 (notesAsRPC notes1) (notesAsRPC notes2) - NTLambda {} -> notes - NTMap typeAnn keyAnns valueNotes -> NTMap typeAnn keyAnns (notesAsRPC valueNotes) - NTBigMap typeAnn _ _ -> NTNat typeAnn - NTInt {} -> notes - NTNat {} -> notes - NTString {} -> notes - NTBytes {} -> notes - NTMutez {} -> notes - NTBool {} -> notes - NTKeyHash {} -> notes - NTTimestamp {} -> notes - NTAddress {} -> notes - NTBls12381Fr {} -> notes - NTBls12381G1 {} -> notes - NTBls12381G2 {} -> notes - NTNever {} -> notes - ----------------------------------------------------------------------------- --- Entailments ----------------------------------------------------------------------------- - --- | A proof that if a singleton exists for @t@, --- then so it does for @AsRPC t@. -rpcSingIEvi :: forall (t :: T). SingI t :- SingI (AsRPC t) -rpcSingIEvi = - Sub $ - case sing @t of - STKey -> Dict - STUnit {} -> Dict - STSignature {} -> Dict - STChainId {} -> Dict - STChest {} -> Dict - STChestKey {} -> Dict - STOption (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem - STList (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem - STSet (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem - STOperation {} -> Dict - STContract {} -> Dict - STTicket {} -> Dict - STPair (sa :: Sing a) (sb :: Sing b) -> - withSingI sa $ withSingI sb $ - Dict \\ rpcSingIEvi @a \\ rpcSingIEvi @b - STOr (sl :: Sing l) (sr :: Sing r) -> - withSingI sl $ withSingI sr $ - Dict \\ rpcSingIEvi @l \\ rpcSingIEvi @r - STLambda {} -> Dict - STMap (sk :: Sing k) (sv :: Sing v) -> - withSingI sk $ withSingI sv $ - Dict \\ rpcSingIEvi @k \\ rpcSingIEvi @v - STBigMap {} -> Dict - STInt {} -> Dict - STNat {} -> Dict - STString {} -> Dict - STBytes {} -> Dict - STMutez {} -> Dict - STBool {} -> Dict - STKeyHash {} -> Dict - STBls12381Fr {} -> Dict - STBls12381G1 {} -> Dict - STBls12381G2 {} -> Dict - STTimestamp {} -> Dict - STAddress {} -> Dict - STNever {} -> Dict - --- | A proof that if @t@ does not contain any operations, then neither does @AsRPC t@. -rpcHasNoOpEvi :: forall (t :: T). (SingI t, HasNoOp t) => HasNoOp t :- HasNoOp (AsRPC t) -rpcHasNoOpEvi = rpcHasNoOpEvi' sing - -rpcHasNoOpEvi' - :: HasNoOp t - => Sing t - -> HasNoOp t :- HasNoOp (AsRPC t) -rpcHasNoOpEvi' sng = Sub $ case sng of - STKey -> Dict - STUnit {} -> Dict - STSignature {} -> Dict - STChainId {} -> Dict - STChest {} -> Dict - STChestKey {} -> Dict - STOption s -> Dict \\ rpcHasNoOpEvi' s - STList s -> Dict \\ rpcHasNoOpEvi' s - STSet s -> Dict \\ rpcHasNoOpEvi' s - STContract {} -> Dict - STTicket {} -> Dict - STPair sa sb -> case checkOpPresence sa of - OpAbsent -> Dict \\ rpcHasNoOpEvi' sa \\ rpcHasNoOpEvi' sb - STOr sl sr -> case checkOpPresence sl of - OpAbsent -> Dict \\ rpcHasNoOpEvi' sl \\ rpcHasNoOpEvi' sr - STLambda {} -> Dict - STMap _ sv -> case checkOpPresence sv of - OpAbsent -> Dict \\ rpcHasNoOpEvi' sv - STBigMap {} -> Dict - STInt {} -> Dict - STNat {} -> Dict - STString {} -> Dict - STBytes {} -> Dict - STMutez {} -> Dict - STBool {} -> Dict - STKeyHash {} -> Dict - STBls12381Fr {} -> Dict - STBls12381G1 {} -> Dict - STBls12381G2 {} -> Dict - STTimestamp {} -> Dict - STAddress {} -> Dict - STNever {} -> Dict - --- | A proof that @AsRPC (Value t)@ does not contain big_maps. -rpcHasNoBigMapEvi :: forall (t :: T). SingI t => Dict (HasNoBigMap (AsRPC t)) -rpcHasNoBigMapEvi = rpcHasNoBigMapEvi' (sing @t) - -rpcHasNoBigMapEvi' :: Sing t -> Dict (HasNoBigMap (AsRPC t)) -rpcHasNoBigMapEvi' = \case - STKey -> Dict - STUnit {} -> Dict - STSignature {} -> Dict - STChainId {} -> Dict - STChest {} -> Dict - STChestKey {} -> Dict - STOption s -> Dict \\ rpcHasNoBigMapEvi' s - STList s -> Dict \\ rpcHasNoBigMapEvi' s - STSet s -> Dict \\ rpcHasNoBigMapEvi' s - STOperation {} -> Dict - STContract {} -> Dict - STTicket {} -> Dict - STPair sa sb -> Dict \\ rpcHasNoBigMapEvi' sa \\ rpcHasNoBigMapEvi' sb - STOr sl sr -> Dict \\ rpcHasNoBigMapEvi' sl \\ rpcHasNoBigMapEvi' sr - STLambda {} -> Dict - STMap sk sv -> Dict \\ rpcHasNoBigMapEvi' sk \\ rpcHasNoBigMapEvi' sv - STBigMap {} -> Dict - STInt {} -> Dict - STNat {} -> Dict - STString {} -> Dict - STBytes {} -> Dict - STMutez {} -> Dict - STBool {} -> Dict - STKeyHash {} -> Dict - STBls12381Fr {} -> Dict - STBls12381G1 {} -> Dict - STBls12381G2 {} -> Dict - STTimestamp {} -> Dict - STAddress {} -> Dict - STNever {} -> Dict - --- | A proof that @AsRPC (Value t)@ does not contain big_maps. -rpcHasNoNestedBigMapsEvi - :: forall (t :: T). - SingI t - => Dict (HasNoNestedBigMaps (AsRPC t)) -rpcHasNoNestedBigMapsEvi = rpcHasNoNestedBigMapsEvi' (sing @t) - -rpcHasNoNestedBigMapsEvi' :: Sing t -> Dict (HasNoNestedBigMaps (AsRPC t)) -rpcHasNoNestedBigMapsEvi' = \case - STKey -> Dict - STUnit {} -> Dict - STSignature {} -> Dict - STChainId {} -> Dict - STChest {} -> Dict - STChestKey {} -> Dict - STOption s -> Dict \\ rpcHasNoNestedBigMapsEvi' s - STList s -> Dict \\ rpcHasNoNestedBigMapsEvi' s - STSet s -> Dict \\ rpcHasNoNestedBigMapsEvi' s - STOperation {} -> Dict - STContract {} -> Dict - STTicket {} -> Dict - STPair sa sb -> - Dict \\ rpcHasNoNestedBigMapsEvi' sa \\ rpcHasNoNestedBigMapsEvi' sb - STOr sl sr -> - Dict \\ rpcHasNoNestedBigMapsEvi' sl \\ rpcHasNoNestedBigMapsEvi' sr - STLambda {} -> Dict - STMap sk sv -> - Dict \\ rpcHasNoNestedBigMapsEvi' sk \\ rpcHasNoNestedBigMapsEvi' sv - STBigMap {} -> Dict - STInt {} -> Dict - STNat {} -> Dict - STString {} -> Dict - STBytes {} -> Dict - STMutez {} -> Dict - STBool {} -> Dict - STKeyHash {} -> Dict - STBls12381Fr {} -> Dict - STBls12381G1 {} -> Dict - STBls12381G2 {} -> Dict - STTimestamp {} -> Dict - STAddress {} -> Dict - STNever {} -> Dict - --- | A proof that if @t@ does not contain any contract values, then neither does @AsRPC t@. -rpcHasNoContractEvi - :: forall (t :: T). - (SingI t, HasNoContract t) - => HasNoContract t :- HasNoContract (AsRPC t) -rpcHasNoContractEvi = rpcHasNoContractEvi' sing - -rpcHasNoContractEvi' - :: HasNoContract t - => Sing t - -> HasNoContract t :- HasNoContract (AsRPC t) -rpcHasNoContractEvi' sng = Sub $ case sng of - STKey -> Dict - STUnit {} -> Dict - STSignature {} -> Dict - STChainId {} -> Dict - STChest {} -> Dict - STChestKey {} -> Dict - STOption s -> Dict \\ rpcHasNoContractEvi' s - STList s -> Dict \\ rpcHasNoContractEvi' s - STSet _ -> Dict - STOperation {} -> Dict - STTicket {} -> Dict - STPair sa sb -> case checkContractTypePresence sa of - ContractAbsent -> - Dict \\ rpcHasNoContractEvi' sa \\ rpcHasNoContractEvi' sb - STOr sl sr -> case checkContractTypePresence sl of - ContractAbsent -> - Dict \\ rpcHasNoContractEvi' sl \\ rpcHasNoContractEvi' sr - STLambda {} -> Dict - STMap _ sv -> Dict \\ rpcHasNoContractEvi' sv - STBigMap {} -> Dict - STInt {} -> Dict - STNat {} -> Dict - STString {} -> Dict - STBytes {} -> Dict - STMutez {} -> Dict - STBool {} -> Dict - STKeyHash {} -> Dict - STBls12381Fr {} -> Dict - STBls12381G1 {} -> Dict - STBls12381G2 {} -> Dict - STTimestamp {} -> Dict - STAddress {} -> Dict - STNever {} -> Dict - --- | A proof that if @t@ is a valid storage type, then so is @AsRPC t@. -rpcStorageScopeEvi :: forall (t :: T). StorageScope t :- StorageScope (AsRPC t) -rpcStorageScopeEvi = - Sub $ Dict - \\ rpcSingIEvi @t - \\ rpcHasNoOpEvi @t - \\ rpcHasNoNestedBigMapsEvi @t - \\ rpcHasNoContractEvi @t diff --git a/src/Morley/Client/RPC/Class.hs b/src/Morley/Client/RPC/Class.hs --- a/src/Morley/Client/RPC/Class.hs +++ b/src/Morley/Client/RPC/Class.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | An abstraction layer over RPC implementation. -- The primary reason it exists is to make it possible to mock diff --git a/src/Morley/Client/RPC/Error.hs b/src/Morley/Client/RPC/Error.hs --- a/src/Morley/Client/RPC/Error.hs +++ b/src/Morley/Client/RPC/Error.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Various errors that can happen in the RPC part of @morley-client@. module Morley.Client.RPC.Error @@ -11,7 +10,7 @@ ) where import Fmt (Buildable(..), blockListF, pretty, (+|), (|+)) -import qualified Text.Show (show) +import Text.Show qualified (show) import Morley.Micheline (Expression) import Morley.Tezos.Address @@ -45,6 +44,10 @@ -- ^ A smart contract execution failed due gas exhaustion. Address -- ^ Smart contract address. + | KeyAlreadyRevealed + -- ^ A key has already been revealed. + Address + -- ^ The address corresponding to the key. | ClientInternalError -- ^ An error that RPC considers internal occurred. These errors -- are considered internal by mistake, they are actually quite @@ -67,6 +70,7 @@ EmptyTransaction addr -> build (REEmptyTransaction addr) ShiftOverflow addr -> addr |+ " failed due to shift overflow" GasExhaustion addr -> addr |+ " failed due to gas exhaustion" + KeyAlreadyRevealed addr -> "Key for " +| addr |+ " has already been revealed" ClientInternalError err -> build err instance Exception ClientRpcError where diff --git a/src/Morley/Client/RPC/Getters.hs b/src/Morley/Client/RPC/Getters.hs --- a/src/Morley/Client/RPC/Getters.hs +++ b/src/Morley/Client/RPC/Getters.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Some read-only actions (wrappers over RPC calls). @@ -38,7 +37,7 @@ import Fmt (Buildable(..), pretty, (+|), (|+)) import Network.HTTP.Types.Status (statusCode) import Servant.Client (ClientError(..), responseStatusCode) -import qualified Text.Show +import Text.Show qualified import Lorentz (NicePackedValue, NiceUnpackedValue, niceUnpackedValueEvi, valueToScriptExpr) import Lorentz.Value @@ -46,7 +45,7 @@ import Morley.Michelson.TypeCheck.TypeCheck (SomeParamType(..), TcOriginatedContracts, mkSomeParamType) import Morley.Michelson.Typed -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Morley.Tezos.Crypto (encodeBase58Check) import Morley.Util.ByteString diff --git a/src/Morley/Client/RPC/QueryFixedParam.hs b/src/Morley/Client/RPC/QueryFixedParam.hs --- a/src/Morley/Client/RPC/QueryFixedParam.hs +++ b/src/Morley/Client/RPC/QueryFixedParam.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Morley.Client.RPC.QueryFixedParam ( QueryFixedParam diff --git a/src/Morley/Client/RPC/Types.hs b/src/Morley/Client/RPC/Types.hs --- a/src/Morley/Client/RPC/Types.hs +++ b/src/Morley/Client/RPC/Types.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | This module contains various types which are used in -- tezos-node RPC API. @@ -30,6 +29,7 @@ , InternalOperation (..) , OperationContent (..) , OperationHash (..) + , OperationInput (..) , OperationResp (..) , OperationResult (..) , OriginationOperation (..) @@ -37,12 +37,14 @@ , ParametersInternal (..) , PreApplyOperation (..) , ProtocolParameters (..) + , RevealOperation (..) , RunCode (..) , RunCodeResult (..) , RunMetadata (..) , RunOperation (..) , RunOperationInternal (..) , RunOperationResult (..) + , RPCInput , TransactionOperation (..) , combineResults , mkCommonOperationData @@ -66,11 +68,11 @@ , _UnexpectedOperation , _REEmptyTransaction , _ScriptOverflow + , _PreviouslyRevealedKey , _GasExhaustedOperation -- * Lenses - , toCommonDataL - , ooCommonDataL + , oiCommonDataL ) where import Control.Lens (makeLensesFor, makePrisms) @@ -81,53 +83,73 @@ import Data.Default (Default(..)) import Data.Fixed (Milli) import Data.List (isSuffixOf) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Time (UTCTime) -import Data.Vector (fromList) -import Fmt (Buildable(..), pretty, (+|), (|+)) +import Fmt (Buildable(..), pretty, unwordsF, (+|), (|+)) import Servant.API (ToHttpApiData(..)) import Data.Aeson.Types (Parser) import Morley.Client.RPC.Aeson (morleyClientAesonOptions) +import Morley.Client.Types import Morley.Micheline (Expression(..), MichelinePrimAp(..), MichelinePrimitive(..), StringEncode(..), TezosInt64, TezosMutez(..), TezosNat) import Morley.Tezos.Address (Address) -import Morley.Tezos.Core (Mutez, toMutez, zeroMutez) -import Morley.Tezos.Crypto (Signature, decodeBase58CheckWithPrefix, formatSignature) +import Morley.Tezos.Core (Mutez, tz, zeroMutez) +import Morley.Tezos.Crypto (PublicKey, Signature, decodeBase58CheckWithPrefix, formatSignature) import Morley.Util.CLI (HasCLReader(..), eitherReader) -import Morley.Util.Named (pattern (:!), pattern N, (:!), (<:!>)) +import Morley.Util.Named (arg, pattern (:!), (:!), (<:!>)) import Morley.Util.Text (dquotes) +mergeObjects :: HasCallStack => Value -> Value -> Value +mergeObjects (Object a) (Object b) = Object (a <> b) +mergeObjects (Object _) _ = error "Right part is not an Object" +mergeObjects _ _ = error "Left part is not an Object" + +-- | Designates an input RPC data that we supply to perform an operation. +data RPCInput +instance OperationInfoDescriptor RPCInput where + type TransferInfo RPCInput = TransactionOperation + type OriginationInfo RPCInput = OriginationOperation + type RevealInfo RPCInput = RevealOperation + +instance ToJSON (OperationInfo RPCInput) where + toJSON = \case + OpTransfer op -> toJSON op + OpOriginate op -> toJSON op + OpReveal op -> toJSON op + +data OperationInput = OperationInput + { oiCommonData :: CommonOperationData + , oiCustom :: OperationInfo RPCInput + } + +instance ToJSON OperationInput where + toJSON OperationInput{..} = + toJSON oiCommonData `mergeObjects` toJSON oiCustom + data ForgeOperation = ForgeOperation { foBranch :: Text - , foContents :: NonEmpty (Either TransactionOperation OriginationOperation) + , foContents :: NonEmpty OperationInput } -contentsToJSON :: NonEmpty (Either TransactionOperation OriginationOperation) -> Value -contentsToJSON = Array . fromList . toList . - map (\case - Right transOp -> toJSON transOp - Left origOp -> toJSON origOp - ) - instance ToJSON ForgeOperation where toJSON ForgeOperation{..} = object [ "branch" .= toString foBranch - , ("contents", contentsToJSON foContents) + , "contents" .= foContents ] data RunOperationInternal = RunOperationInternal { roiBranch :: Text - , roiContents :: NonEmpty (Either TransactionOperation OriginationOperation) + , roiContents :: NonEmpty OperationInput , roiSignature :: Signature } instance ToJSON RunOperationInternal where toJSON RunOperationInternal{..} = object [ "branch" .= toString roiBranch - , ("contents", contentsToJSON roiContents) - , "signature" .= toJSON roiSignature + , "contents" .= roiContents + , "signature" .= roiSignature ] data RunOperation = RunOperation @@ -138,14 +160,14 @@ data PreApplyOperation = PreApplyOperation { paoProtocol :: Text , paoBranch :: Text - , paoContents :: NonEmpty (Either TransactionOperation OriginationOperation) + , paoContents :: NonEmpty OperationInput , paoSignature :: Signature } instance ToJSON PreApplyOperation where toJSON PreApplyOperation{..} = object [ "branch" .= toString paoBranch - , ("contents", contentsToJSON paoContents) + , "contents" .= paoContents , "protocol" .= toString paoProtocol , "signature" .= formatSignature paoSignature ] @@ -222,7 +244,7 @@ -- | At the moment of writing, Tezos always uses these constants. instance Default FeeConstants where def = FeeConstants - { fcBase = toMutez 100 + { fcBase = [tz|100u|] , fcMutezPerGas = 0.1 , fcMutezPerOpByte = 1 } @@ -233,6 +255,9 @@ data BlockId = HeadId -- ^ Identifier referring to the head block. + | FinalHeadId + -- ^ Identifier of the most recent block guaranteed to have been finalized. + -- See: https://web.archive.org/web/20220305165609/https://tezos.gitlab.io/protocols/tenderbake.html#operations | GenesisId -- ^ Identifier referring to the genesis block. | LevelId Natural @@ -246,6 +271,7 @@ instance ToHttpApiData BlockId where toUrlPiece = \case HeadId -> "head" + FinalHeadId -> "head~2" GenesisId -> "genesis" LevelId x -> toUrlPiece x BlockHashId hash -> toUrlPiece hash @@ -254,6 +280,7 @@ instance Buildable BlockId where build = \case HeadId -> "head" + FinalHeadId -> "head~2" GenesisId -> "genesis" LevelId x -> "block at level " <> build x BlockHashId hash -> "block with hash " <> build hash @@ -264,6 +291,7 @@ parseBlockId :: Text -> Maybe BlockId parseBlockId t | t == "head" = Just HeadId + | t == "head~2" = Just FinalHeadId | t == "genesis" = Just GenesisId | Right lvl <- readEither t = Just (LevelId lvl) | Just depthTxt <- "head~" `T.stripPrefix` t @@ -333,6 +361,7 @@ | MutezMultiplicationOverflow TezosInt64 TezosInt64 | CantPayStorageFee | BalanceTooLow ("balance" :! Mutez) ("required" :! Mutez) + | PreviouslyRevealedKey Address | NonExistingContract Address deriving stock Show @@ -384,6 +413,8 @@ balance <- unTezosMutez <$> o .: "balance" amount <- unTezosMutez <$> o .: "amount" return $ BalanceTooLow (#balance :! balance) (#required :! amount) + x | "previously_revealed_key" `isSuffixOf` x -> + PreviouslyRevealedKey <$> o .: "contract" x | "non_existing_contract" `isSuffixOf` x -> NonExistingContract <$> o .: "contract" _ -> fail ("unknown id: " <> id') @@ -427,18 +458,20 @@ "Contract failed due to gas exhaustion" MutezAdditionOverflow amounts -> "A contract failed due to mutez addition overflow when adding following values:\n" +| - mconcat (intersperse (" " :: Text) $ map show amounts) |+ "" + unwordsF amounts |+ "" MutezSubtractionUnderflow amounts -> "A contract failed due to mutez subtraction underflow when subtracting following values:\n" +| - mconcat (intersperse (" " :: Text) $ map show amounts) |+ "" + unwordsF amounts |+ "" MutezMultiplicationOverflow amount multiplicator -> "A contract failed due to mutez multiplication overflow when multiplying" +| amount |+ " by " +| multiplicator |+ "" CantPayStorageFee -> "Balance is too low to pay storage fee" - BalanceTooLow (N balance) (N required) -> + BalanceTooLow (arg #balance -> balance) (arg #required -> required) -> "Balance is too low, \ \current balance: " +| balance |+ ", but required: " +| required |+ "" + PreviouslyRevealedKey addr -> + "Key for " +| addr |+ " has already been revealed" NonExistingContract addr -> "Contract is not registered: " +| addr |+ "" @@ -464,7 +497,7 @@ instance Buildable InternalError where build = \case - CounterInThePast addr (N expected) (N found) -> + CounterInThePast addr (arg #expected -> expected) (arg #found -> found) -> "Expected counter " +| expected |+ " for " +| addr |+ "but got: " +| found |+ "" UnrevealedKey addr -> @@ -598,31 +631,30 @@ , codStorageLimit = ppHardStorageLimitPerOperation } -commonDataToValueList :: CommonOperationData -> [(Text, Value)] -commonDataToValueList CommonOperationData{..} = - [ "source" .= codSource - , "fee" .= codFee - , "counter" .= codCounter - , "gas_limit" .= codGasLimit - , "storage_limit" .= codStorageLimit - ] +instance ToJSON CommonOperationData where + toJSON CommonOperationData{..} = object + [ "source" .= codSource + , "fee" .= codFee + , "counter" .= codCounter + , "gas_limit" .= codGasLimit + , "storage_limit" .= codStorageLimit + ] -parseCommonOperationData :: Object -> Parser CommonOperationData -parseCommonOperationData obj = do - codSource <- obj .: "source" - codFee <- obj .: "fee" - codCounter <- obj .: "counter" - codGasLimit <- obj .: "gas_limit" - codStorageLimit <- obj .: "storage_limit" - pure CommonOperationData {..} +instance FromJSON CommonOperationData where + parseJSON = withObject "common operation data" $ \o -> do + codSource <- o .: "source" + codFee <- o .: "fee" + codCounter <- o .: "counter" + codGasLimit <- o .: "gas_limit" + codStorageLimit <- o .: "storage_limit" + pure CommonOperationData {..} -- | All the data needed to perform a transaction through -- Tezos RPC interface. -- For additional information, please refer to RPC documentation -- http://tezos.gitlab.io/api/rpc.html data TransactionOperation = TransactionOperation - { toCommonData :: CommonOperationData - , toAmount :: TezosMutez + { toAmount :: TezosMutez , toDestination :: Address , toParameters :: ParametersInternal } @@ -630,14 +662,13 @@ instance ToJSON TransactionOperation where toJSON TransactionOperation{..} = object $ [ "kind" .= String "transaction" - , "amount" .= toJSON toAmount - , "destination" .= toJSON toDestination - , "parameters" .= toJSON toParameters - ] <> commonDataToValueList toCommonData + , "amount" .= toAmount + , "destination" .= toDestination + , "parameters" .= toParameters + ] instance FromJSON TransactionOperation where parseJSON = withObject "TransactionOperation" $ \obj -> do - toCommonData <- parseCommonOperationData obj toAmount <- obj .: "amount" toDestination <- obj .: "destination" toParameters <- fromMaybe defaultParametersInternal <$> obj .:? "parameters" @@ -651,18 +682,29 @@ -- | All the data needed to perform contract origination -- through Tezos RPC interface data OriginationOperation = OriginationOperation - { ooCommonData :: CommonOperationData - , ooBalance :: TezosMutez + { ooBalance :: TezosMutez , ooScript :: OriginationScript } instance ToJSON OriginationOperation where toJSON OriginationOperation{..} = object $ [ "kind" .= String "origination" - , "balance" .= toJSON ooBalance - , "script" .= toJSON ooScript - ] <> commonDataToValueList ooCommonData + , "balance" .= ooBalance + , "script" .= ooScript + ] +-- | All the data needed to perform key revealing +-- through Tezos RPC interface +data RevealOperation = RevealOperation + { roPublicKey :: PublicKey + } + +instance ToJSON RevealOperation where + toJSON RevealOperation{..} = object $ + [ "kind" .= String "reveal" + , "public_key" .= roPublicKey + ] + -- | @$operation@ in Tezos docs. data BlockOperation = BlockOperation { boHash :: Text @@ -729,5 +771,4 @@ parseJSON v = maybe GetBigMapNotFound GetBigMapResult <$> parseJSON v makePrisms ''RunError -makeLensesFor [("toCommonData", "toCommonDataL")] ''TransactionOperation -makeLensesFor [("ooCommonData", "ooCommonDataL")] ''OriginationOperation +makeLensesFor [("oiCommonData", "oiCommonDataL")] ''OperationInput diff --git a/src/Morley/Client/TezosClient/Class.hs b/src/Morley/Client/TezosClient/Class.hs --- a/src/Morley/Client/TezosClient/Class.hs +++ b/src/Morley/Client/TezosClient/Class.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Abstraction layer for @tezos-client@ functionality. -- We use it to mock @tezos-client@ in tests. @@ -38,10 +37,11 @@ -- ^ Associate the given contract with alias. -- The 'Bool' variable indicates whether or not we should replace already -- existing contract alias or not. - importKey :: Bool -> AliasOrAliasHint -> SecretKey -> m () - -- ^ Saves 'SecretKey' via @tezos-client@ with given alias associated. + importKey :: Bool -> AliasOrAliasHint -> SecretKey -> m Alias + -- ^ Saves 'SecretKey' via @tezos-client@ with given alias or hint associated. -- The 'Bool' variable indicates whether or not we should replace already -- existing alias key or not. + -- The returned 'Alias' is the alias under which the key will be accessible. resolveAddressMaybe :: AddressOrAlias -> m (Maybe Address) -- ^ Retrieve an address from given address or alias. If address or alias does not exist -- returns `Nothing` diff --git a/src/Morley/Client/TezosClient/Impl.hs b/src/Morley/Client/TezosClient/Impl.hs --- a/src/Morley/Client/TezosClient/Impl.hs +++ b/src/Morley/Client/TezosClient/Impl.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Interface to the @tezos-client@ executable expressed in Haskell types. @@ -22,6 +21,7 @@ , getTezosClientConfig , calcTransferFee , calcOriginationFee + , calcRevealFee , getKeyPassword , registerDelegate @@ -32,13 +32,14 @@ , prefixNameM ) where +import Unsafe qualified ((!!)) + import Colourista (formatWith, red) import Control.Exception (IOException, throwIO) import Data.Aeson (eitherDecodeStrict, encode) import Data.ByteArray (ScrubbedBytes) -import qualified Data.ByteString.Lazy.Char8 as C (unpack) -import Data.List ((!!)) -import qualified Data.Text as T +import Data.ByteString.Lazy.Char8 qualified as C (unpack) +import Data.Text qualified as T import Fmt (Buildable(..), pretty, (+|), (|+)) import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode) @@ -48,7 +49,7 @@ import Lorentz.Value import Morley.Client.Logging import Morley.Client.RPC.Types -import qualified Morley.Client.TezosClient.Class as Class (HasTezosClient(resolveAddressMaybe)) +import Morley.Client.TezosClient.Class qualified as Class (HasTezosClient(resolveAddressMaybe)) import Morley.Client.TezosClient.Parser import Morley.Client.TezosClient.Types import Morley.Client.Util (readScrubbedBytes, scrubbedBytesToString) @@ -56,6 +57,8 @@ import Morley.Michelson.Typed.Scope import Morley.Tezos.Address import Morley.Tezos.Crypto +import Morley.Util.Peano +import Morley.Util.SizedList.Types ---------------------------------------------------------------------------- -- Errors @@ -385,7 +388,7 @@ => Bool -> AliasOrAliasHint -> SecretKey - -> m () + -> m Alias importKey replaceExisting alias key = do name <- prefixNameM alias let @@ -396,7 +399,7 @@ callTezosClient errHandler (if replaceExisting then args <> ["--force"] else args) MockupMode Nothing - pure () + pure name -- | Read @tezos-client@ configuration. getTezosClientConfig :: FilePath -> Maybe FilePath -> IO TezosClientConfig @@ -421,7 +424,8 @@ [ "multiple", "transfers", "from", pretty from, "using" , C.unpack $ encode transferFeeDatas, "--burn-cap", showBurnCap burnCap, "--dry-run" ] ClientMode mbPassword - feeOutputParser output $ length transferFeeDatas + withSomePeano (fromIntegralOverflowing $ length transferFeeDatas) $ + \(_ :: Proxy n) -> toList <$> feeOutputParser @n output -- | Calc baker fee for origination using @tezos-client@. calcOriginationFee @@ -438,16 +442,34 @@ , toCmdArg cofdStorage, "--burn-cap" , showBurnCap cofdBurnCap, "--dry-run" ] ClientMode cofdMbFromPassword - fees <- feeOutputParser output 1 + fees <- feeOutputParser @1 output case fees of - [singleFee] -> return singleFee - _ -> error "Expecting to parse single fee, parsed more" + singleFee :< Nil -> return singleFee -feeOutputParser :: (MonadIO m, MonadThrow m) => Text -> Int -> m [TezosMutez] -feeOutputParser output n = - case parseBakerFeeFromOutput output n of +-- | Calc baker fee for revealing using @tezos-client@. +-- +-- Note that @tezos-client@ does not support passing an address here, +-- at least at the moment of writing. +calcRevealFee + :: ( WithClientLog env m, HasTezosClientEnv env + , MonadIO m, MonadCatch m + ) + => Alias -> Maybe ScrubbedBytes -> TezosInt64 -> m TezosMutez +calcRevealFee alias mbPassword burnCap = do + output <- callTezosClientStrict + [ "reveal", "key", "for", toCmdArg alias + , "--burn-cap", showBurnCap burnCap + , "--dry-run" + ] ClientMode mbPassword + fees <- feeOutputParser @1 output + case fees of + singleFee :< Nil -> return singleFee + +feeOutputParser :: forall n m. (SingIPeano n, MonadIO m, MonadThrow m) => Text -> m (SizedList n TezosMutez) +feeOutputParser output = + case parseBakerFeeFromOutput @n output of Right fee -> return fee - Left err -> throwM $ TezosClientParseFeeError output $ show err + Left err -> throwM $ TezosClientParseFeeError output $ pretty err showBurnCap :: TezosInt64 -> String showBurnCap x = printf "%.6f" $ (fromIntegralToRealFrac @TezosInt64 @Float x) / 1000 @@ -472,7 +494,7 @@ encryptionType <- case parseSecretKeyEncryption output of Right t -> return t - Left err -> throwM $ TezosClientParseEncryptionTypeError output $ show err + Left err -> throwM $ TezosClientParseEncryptionTypeError output $ pretty err case encryptionType of EncryptedKey -> do putTextLn $ "Please enter password for '" <> pretty alias <> "':" @@ -558,7 +580,7 @@ "Counter" `T.isPrefixOf` errOutput && "already used for contract" `T.isInfixOf` errOutput = do let splittedErrOutput = words errOutput liftIO $ throwM $ - CounterIsAlreadyUsed (splittedErrOutput !! 1) (splittedErrOutput !! 5) + CounterIsAlreadyUsed (splittedErrOutput Unsafe.!! 1) (splittedErrOutput Unsafe.!! 5) checkCounterError _ = pass checkEConnreset :: Text -> m () checkEConnreset errOutput @@ -606,7 +628,7 @@ throwIO e errorMsg = - "ERROR!! There was an error in executing `" <> (show fp) <> "` program. Is the \ + "ERROR!! There was an error in executing `" <> toText fp <> "` program. Is the \ \ executable available in PATH ?" prefixName :: Maybe Text -> AliasOrAliasHint -> Alias diff --git a/src/Morley/Client/TezosClient/Parser.hs b/src/Morley/Client/TezosClient/Parser.hs --- a/src/Morley/Client/TezosClient/Parser.hs +++ b/src/Morley/Client/TezosClient/Parser.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Parsers that are used in "Morley.Client.TezosClient.Impl" module Morley.Client.TezosClient.Parser @@ -9,34 +8,39 @@ ) where import Data.Scientific (Scientific) -import Text.Megaparsec (choice, count, customFailure) -import qualified Text.Megaparsec as P (Parsec, parse, skipManyTill) +import Fmt (Buildable(..)) +import Text.Megaparsec (choice, customFailure) +import Text.Megaparsec qualified as P (Parsec, parse, skipManyTill) import Text.Megaparsec.Char (newline, printChar, space) import Text.Megaparsec.Char.Lexer (lexeme, scientific, symbol) import Text.Megaparsec.Error (ParseErrorBundle, ShowErrorComponent(..), errorBundlePretty) -import qualified Text.Show (show) import Morley.Client.TezosClient.Types (SecretKeyEncryption(..)) import Morley.Micheline +import Morley.Michelson.Parser.Helpers (count) import Morley.Tezos.Core +import Morley.Util.SizedList.Types +import Unsafe qualified (unsafeM) type Parser = P.Parsec Void Text data FeeParserException = FeeParserException (ParseErrorBundle Text Void) - deriving stock Eq - -instance Show FeeParserException where - show (FeeParserException bundle) = errorBundlePretty bundle + deriving stock (Eq, Show) instance Exception FeeParserException where - displayException = show + displayException (FeeParserException bundle) = errorBundlePretty bundle +instance Buildable FeeParserException where + build = build . displayException + -- this might seem backwards, but it's more efficient than converting to then from text + -- which would have to happen in displayException if we define it in terms of build. + data SecretKeyEncryptionParserException = SecretKeyEncryptionParserException (ParseErrorBundle Text UnexpectedEncryptionType) - deriving stock Eq + deriving stock (Eq, Show) -instance Show SecretKeyEncryptionParserException where - show (SecretKeyEncryptionParserException bundle) = errorBundlePretty bundle +instance Buildable SecretKeyEncryptionParserException where + build (SecretKeyEncryptionParserException bundle) = build $ errorBundlePretty bundle data UnexpectedEncryptionType = UnexpectedEncryptionType deriving stock (Eq, Ord, Show) @@ -47,18 +51,18 @@ -- | Function to parse baker fee from given @tezos-client@ output. parseBakerFeeFromOutput - :: Text -> Int -> Either FeeParserException [TezosMutez] -parseBakerFeeFromOutput output n = first FeeParserException $ - P.parse (count n bakerFeeParser) "" output + :: forall n. (SingIPeano n) => Text -> Either FeeParserException (SizedList n TezosMutez) +parseBakerFeeFromOutput output = first FeeParserException $ + P.parse (count @n bakerFeeParser) "" output where bakerFeeParser :: Parser TezosMutez bakerFeeParser = do num <- P.skipManyTill (printChar <|> newline) $ do void $ symbol space "Fee to the baker: " P.skipManyTill printChar $ lexeme (newline >> pass) scientific - either (fail . toString) pure $ scientificToMutez num + Unsafe.unsafeM $ scientificToMutez num scientificToMutez :: Scientific -> Either Text TezosMutez - scientificToMutez x = fmap TezosMutez . mkMutez @Word64 $ floor $ x * 1e6 + scientificToMutez x = fmap TezosMutez $ mkMutez @Word64 $ floor $ x * 1e6 parseSecretKeyEncryption :: Text -> Either SecretKeyEncryptionParserException SecretKeyEncryption diff --git a/src/Morley/Client/TezosClient/Types.hs b/src/Morley/Client/TezosClient/Types.hs --- a/src/Morley/Client/TezosClient/Types.hs +++ b/src/Morley/Client/TezosClient/Types.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Types used for interaction with @tezos-client@. @@ -39,7 +38,7 @@ import Data.Fixed (E6, Fixed(..)) import Fmt (Buildable(..), pretty) import Morley.Util.Lens (makeLensesWith, postfixLFields) -import qualified Options.Applicative as Opt +import Options.Applicative qualified as Opt import Servant.Client (BaseUrl(..), showBaseUrl) import Text.Hex (encodeHex) @@ -49,7 +48,7 @@ import Morley.Micheline import Morley.Michelson.Printer import Morley.Michelson.Typed (Contract, EpName, Value) -import qualified Morley.Michelson.Typed as T +import Morley.Michelson.Typed qualified as T import Morley.Tezos.Address (Address, parseAddress) import Morley.Tezos.Core import Morley.Tezos.Crypto diff --git a/src/Morley/Client/Types.hs b/src/Morley/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Client/Types.hs @@ -0,0 +1,24 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module Morley.Client.Types + ( OperationInfoDescriptor (..) + , OperationInfo (..) + , _OpTransfer + , _OpOriginate + , _OpReveal + ) where + +import Control.Lens (makePrisms) + +class OperationInfoDescriptor (i :: Type) where + type family TransferInfo i :: Type + type family OriginationInfo i :: Type + type family RevealInfo i :: Type + +data OperationInfo i + = OpTransfer (TransferInfo i) + | OpOriginate (OriginationInfo i) + | OpReveal (RevealInfo i) + +makePrisms ''OperationInfo diff --git a/src/Morley/Client/Util.hs b/src/Morley/Client/Util.hs --- a/src/Morley/Client/Util.hs +++ b/src/Morley/Client/Util.hs @@ -1,33 +1,38 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Morley.Client.Util ( epNameToTezosEp , extractAddressesFromValue , disableAlphanetWarning + -- * @runContract@ , runContract - , runContractSimple , RunContractParameters(..) + , runContractParameters + , withBalance + , withAmount + , withSender + , withSource - -- tezos-client password-related helpers + -- * @tezos-client@ password-related helpers , scrubbedBytesToString , readScrubbedBytes ) where +import Control.Lens (makeLensesFor) import Data.ByteArray (ScrubbedBytes, convert) -import qualified Data.ByteString as BS (getLine) +import Data.ByteString qualified as BS (getLine) import Data.Constraint ((\\)) import Generics.SYB (everything, mkQ) import System.Environment (setEnv) -import Morley.Client.RPC.AsRPC (AsRPC, rpcHasNoBigMapEvi, rpcStorageScopeEvi) +import Morley.AsRPC (AsRPC, MaybeRPC, rpcStorageScopeEvi) import Morley.Client.RPC.Class import Morley.Client.RPC.Getters import Morley.Client.RPC.Types import Morley.Micheline import Morley.Michelson.Text -import qualified Morley.Michelson.Typed as T (Contract, ParameterScope, StorageScope, Value) +import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Entrypoints (EpAddress(..), parseEpAddress) import Morley.Michelson.Untyped (InternalByteString(..), Value, Value'(..)) import Morley.Michelson.Untyped.Entrypoints (EpName(..), pattern DefEpName) @@ -64,39 +69,44 @@ Left _ -> [] _ -> [] --- | Simplified version of 'runContract' for convenience --- --- Sets transfer amount to 0 and sender and source are both unspecified. -runContractSimple - :: forall cp st m. (HasTezosRpc m, T.ParameterScope cp, T.StorageScope st) - => T.Contract cp st -- ^ Contract - -> T.Value cp -- ^ Parameter passed to the contract - -> T.Value st -- ^ Initial storage - -> Mutez -- ^ Initial balance - -> m (AsRPC (T.Value st)) -runContractSimple rcpContract rcpParameter rcpStorage rcpBalance = - let rcpSender = Nothing - rcpSource = Nothing - rcpAmount = zeroMutez - in runContract RunContractParameters {..} - -- | A structure with all the parameters for 'runContract' data RunContractParameters cp st = RunContractParameters { rcpContract :: T.Contract cp st - , rcpParameter :: T.Value cp - , rcpStorage :: T.Value st + , rcpParameter :: MaybeRPC (T.Value cp) + , rcpStorage :: MaybeRPC (T.Value st) , rcpBalance :: Mutez , rcpAmount :: Mutez , rcpSender :: Maybe Address , rcpSource :: Maybe Address } +-- | Initializes the parameters for `runContract` with sensible defaults. +-- +-- Use the @with*@ lenses to set any optional parameters. +runContractParameters + :: T.Contract cp st -> MaybeRPC (T.Value cp) -> MaybeRPC (T.Value st) + -> RunContractParameters cp st +runContractParameters contract cp st = + RunContractParameters + { rcpContract = contract + , rcpParameter = cp + , rcpStorage = st + , rcpBalance = zeroMutez + , rcpAmount = zeroMutez + , rcpSender = Nothing + , rcpSource = Nothing + } + +makeLensesFor + [ ("rcpBalance", "withBalance") + , ("rcpAmount", "withAmount") + , ("rcpSender", "withSender") + , ("rcpSource", "withSource") + ] + ''RunContractParameters + -- | Run contract with given parameter and storage and get new storage without -- injecting anything to the chain. --- --- Storage type is limited to not have any bigmaps because their updates are treated differently --- in node RPC and its quite nontrivial to properly support storage update when storage type --- contains bigmaps. runContract :: forall cp st m. (HasTezosRpc m, T.ParameterScope cp, T.StorageScope st) => RunContractParameters cp st -> m (AsRPC (T.Value st)) @@ -109,6 +119,10 @@ , rcAmount = TezosMutez rcpAmount , rcBalance = TezosMutez rcpBalance , rcChainId = bcChainId headConstants + -- Note: assigning source=sender and payer=source may seem like a bug, but it's not. + -- For some reason, the /run_code uses a different naming scheme. + -- What this endpoint calls 'source' is actually the address that will be returned by the `SENDER` instruction. + -- See details here: https://gitlab.com/tezos/tezos/-/issues/710 , rcSource = rcpSender , rcPayer = rcpSource } @@ -116,7 +130,6 @@ throwLeft @_ @FromExpressionError $ pure $ fromExpression @(AsRPC (T.Value st)) (rcrStorage res) \\ rpcStorageScopeEvi @st - \\ rpcHasNoBigMapEvi @st -- | Function for relatively safe getting password from stdin. -- After reading bytes are converted to @ScrubbedBytes@, thus it's harder diff --git a/src/Morley/Util/Batching.hs b/src/Morley/Util/Batching.hs --- a/src/Morley/Util/Batching.hs +++ b/src/Morley/Util/Batching.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Morley.Util.Batching ( BatchingM @@ -12,7 +11,7 @@ ) where import Control.Monad.Except (Except, runExcept, throwError) -import Fmt (Buildable(..), pretty) +import Fmt (Buildable(..)) -- | Errors that can occur during batching, usually because the -- underlying function that performs batch operation returns output @@ -88,7 +87,7 @@ -> BatchingM i o e a -> m (r, a) unsafeRunBatching = - fmap (second $ either (error . pretty) id) ... runBatching + fmap (second unsafe) ... runBatching -- | This is the basic primitive for all actions in 'BatchingM'. -- diff --git a/test/Test/AsRPC.hs b/test/Test/AsRPC.hs deleted file mode 100644 --- a/test/Test/AsRPC.hs +++ /dev/null @@ -1,658 +0,0 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ - -{-# OPTIONS_GHC -Wno-star-is-type #-} - -module Test.AsRPC - ( unit_Renames_constructors_fields_and_generic_metadata - , unit_Can_derive_many_instances_at_once - , unit_Supports_higher_kinded_types - , unit_Can_derive_instances_with_newtype - , unit_Can_derive_many_instances_with_newtypes - , unit_Can_derive_many_instances_with_type_aliases - ) where - -import Data.Typeable ((:~:)(Refl)) -import GHC.Generics -import qualified Language.Haskell.TH.Syntax as TH -import Test.Tasty.HUnit (Assertion) - -import Lorentz (BigMap, BigMapId, IsoValue(ToT), MText, customGeneric, leftBalanced, ligoLayout) -import Morley.Client.RPC.AsRPC - -import Test.Util (shouldCompileIgnoringInstance, shouldCompileTo) - -data ExampleStorage a b = ExampleStorage - { _esField1 :: Integer - , _esField2 :: [BigMap Integer MText] - , _esField3 :: a - } - deriving stock Generic - deriving anyclass IsoValue -deriveRPC "ExampleStorage" - -unit_Renames_constructors_fields_and_generic_metadata :: Assertion -unit_Renames_constructors_fields_and_generic_metadata = do - $(deriveRPC "ExampleStorage" >>= TH.lift) `shouldCompileTo` - [d| - data ExampleStorageRPC a (b :: k) = ExampleStorageRPC - { _esField1RPC :: AsRPC Integer - , _esField2RPC :: AsRPC [BigMap Integer MText] - , _esField3RPC :: AsRPC a - } - - type instance AsRPC (ExampleStorage a (b :: k)) = ExampleStorageRPC a (b :: k) - deriving anyclass instance IsoValue (AsRPC a) => IsoValue (ExampleStorageRPC a (b :: k)) - - instance Generic (ExampleStorageRPC a (b :: k)) - where type Rep (ExampleStorageRPC a - (b :: k)) = D1 ('MetaData "ExampleStorageRPC" "Test.AsRPC" "main" 'False) - (C1 ('MetaCons "ExampleStorageRPC" 'PrefixI 'True) - ((:*:) (S1 ('MetaSel ('Just "_esField1RPC") - 'NoSourceUnpackedness - 'NoSourceStrictness - 'DecidedStrict) - (Rec0 (AsRPC Integer))) - ((:*:) (S1 ('MetaSel ('Just "_esField2RPC") - 'NoSourceUnpackedness - 'NoSourceStrictness - 'DecidedStrict) - (Rec0 (AsRPC ([BigMap Integer - MText])))) - (S1 ('MetaSel ('Just "_esField3RPC") - 'NoSourceUnpackedness - 'NoSourceStrictness - 'DecidedStrict) - (Rec0 (AsRPC a)))))) - from (ExampleStorageRPC v0 - v1 - v2) = M1 (M1 ((:*:) (M1 (K1 v0)) ((:*:) (M1 (K1 v1)) (M1 (K1 v2))))) - to (M1 (M1 ((:*:) (M1 (K1 v0)) - ((:*:) (M1 (K1 v1)) (M1 (K1 v2)))))) = ExampleStorageRPC v0 v1 v2 - |] - -data Ex1 = Ex1 Integer Ex1Inner - deriving stock Generic - deriving anyclass IsoValue -data Ex1Inner = Ex1Inner Integer - deriving stock Generic - deriving anyclass IsoValue - -data Ex2 = Ex2 Integer - deriving stock Generic - deriving anyclass IsoValue -deriveRPC "Ex2" - -data Ex3 = Ex3 Integer - deriving stock (Generic, Eq, Ord) - deriving anyclass IsoValue - -data Ex4 a = Ex4 a - deriving stock Generic - deriving anyclass IsoValue - -data ExampleMany = ExampleMany - { _emField1 :: Integer - , _emField2 :: Ex1 - , _emField3 :: Ex2 - , _emField4 :: [BigMap Ex3 (Ex4 MText)] - } - deriving stock Generic - deriving anyclass IsoValue - --- Check that the declarations generated by `deriveManyRPC` actually compile. -deriveManyRPC "ExampleMany" [] - -unit_Can_derive_many_instances_at_once :: Assertion -unit_Can_derive_many_instances_at_once = do - shouldCompileIgnoringInstance ''Generic - $(deriveManyRPC "ExampleMany" ["Ex3"] >>= TH.lift) - [d| - data ExampleManyRPC = ExampleManyRPC - {_emField1RPC :: AsRPC Integer - , _emField2RPC :: AsRPC Ex1 - , _emField3RPC :: AsRPC Ex2 - , _emField4RPC :: AsRPC [BigMap Ex3 (Ex4 MText)] - } - type instance AsRPC ExampleMany = ExampleManyRPC - deriving anyclass instance IsoValue ExampleManyRPC - - -- An instance is generated for Ex1 - data Ex1RPC = Ex1RPC (AsRPC Integer) (AsRPC Ex1Inner) - type instance AsRPC Ex1 = Ex1RPC - deriving anyclass instance IsoValue Ex1RPC - - -- An instance is generated for Ex1's fields' types - data Ex1InnerRPC = Ex1InnerRPC (AsRPC Integer) - type instance AsRPC Ex1Inner = Ex1InnerRPC - deriving anyclass instance IsoValue Ex1InnerRPC - - -- No instance is generated for Ex2, because one already exists - - -- No instance is generated for Ex3, because we explicitly said we don't want one - - -- An instance is generated for BigMap's concrete type arguments - data Ex4RPC a = Ex4RPC (AsRPC a) - type instance AsRPC (Ex4 a) = Ex4RPC a - deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Ex4RPC a) - |] - ----------------------------------------------------------------------------- --- AsRPC type family ----------------------------------------------------------------------------- - -checkLaws :: ToT (AsRPC t) :~: AsRPC (ToT t) -> () -checkLaws Refl = () - ----------------------------------------------------------------------------- --- Examples data types: --- --- Simple data type ----------------------------------------------------------------------------- - -data Simple = Simple Integer Integer [Integer] - deriving stock Generic - deriving anyclass IsoValue -deriveRPC "Simple" - -data ExpectedSimpleRPC = ExpectedSimpleRPC Integer Integer [Integer] - deriving stock Generic - deriving anyclass IsoValue - -_checkSimple :: ToT SimpleRPC :~: ToT ExpectedSimpleRPC -_checkSimple = Refl - -_checkSimpleLaws :: () -_checkSimpleLaws = checkLaws @Simple Refl - ----------------------------------------------------------------------------- --- Simple record data type ----------------------------------------------------------------------------- - -data SimpleRecord = SimpleRecord - { _simpleRecordField1 :: Integer - , _simpleRecordField2 :: Integer - , _simpleRecordField3 :: [Integer] - } - deriving stock Generic - deriving anyclass IsoValue -deriveRPC "SimpleRecord" - -data ExpectedSimpleRecordRPC = ExpectedSimpleRecordRPC - { eSimpleRecordField1 :: Integer - , eSimpleRecordField2 :: Integer - , eSimpleRecordField3 :: [Integer] - } - deriving stock Generic - deriving anyclass IsoValue - -_checkSimpleRecord :: ToT SimpleRecordRPC :~: ToT ExpectedSimpleRecordRPC -_checkSimpleRecord = Refl - -_checkSimpleRecordLaws :: () -_checkSimpleRecordLaws = checkLaws @SimpleRecord Refl - ----------------------------------------------------------------------------- --- Data type with bigmap fields ----------------------------------------------------------------------------- - -data WithBigMap = WithBigMap - { _wbmField1 :: Integer - , _wbmField2 :: BigMap Integer Integer - , _wbmField3 :: [BigMap Integer Integer] - } - deriving stock Generic - deriving anyclass IsoValue -deriveRPC "WithBigMap" - -data ExpectedWithBigMapRPC = ExpectedWithBigMapRPC - { expectedWbmField1 :: Integer - , expectedWbmField2 :: BigMapId Integer Integer - , expectedWbmField3 :: [BigMapId Integer Integer] - } - deriving stock Generic - deriving anyclass IsoValue - -_checkWithBigMap :: ToT WithBigMapRPC :~: ToT ExpectedWithBigMapRPC -_checkWithBigMap = Refl - -_checkWithBigMapLaws :: () -_checkWithBigMapLaws = checkLaws @WithBigMap Refl - ----------------------------------------------------------------------------- --- Data type with custom generic strategy ----------------------------------------------------------------------------- - -data WithGenericStrategy - = WithGenericStrategy_1 Integer Integer Integer - | WithGenericStrategy_2 Integer Integer Integer - | WithGenericStrategy_3 Integer Integer Integer - | WithGenericStrategy_4 Integer Integer Integer - -deriving anyclass instance IsoValue WithGenericStrategy -customGeneric "WithGenericStrategy" leftBalanced -deriveRPCWithStrategy "WithGenericStrategy" leftBalanced - -_checkWithGenericStrategy :: ToT WithGenericStrategyRPC :~: ToT WithGenericStrategy -_checkWithGenericStrategy = Refl - -_checkWithGenericStrategyLaws :: () -_checkWithGenericStrategyLaws = checkLaws @WithGenericStrategy Refl - ----------------------------------------------------------------------------- --- Data type with reordered fields ----------------------------------------------------------------------------- - -data WithReordered = WithRedordered - { _wrField1 :: Integer - , _wrField3 :: MText - , _wrField2 :: [Integer] - } - -deriving anyclass instance IsoValue WithReordered -customGeneric "WithReordered" ligoLayout -deriveRPCWithStrategy "WithReordered" ligoLayout - -_checkWithReordered :: ToT WithReorderedRPC :~: ToT WithReordered -_checkWithReordered = Refl - -_checkWithReorderedLaws :: () -_checkWithReorderedLaws = checkLaws @WithReordered Refl - ----------------------------------------------------------------------------- --- Data type with type variables ----------------------------------------------------------------------------- - -data WithTypeVariables a = WithTypeVariables - { _wtvField1 :: a - } - deriving stock Generic - deriving anyclass IsoValue -deriveRPC "WithTypeVariables" - -data ExpectedWithTypeVariablesRPC = ExpectedWithTypeVariablesRPC - { expectedWtvField1 :: BigMapId Integer MText - } - deriving stock Generic - deriving anyclass IsoValue - -_checkWithTypeVariables :: ToT (WithTypeVariablesRPC (BigMap Integer MText)) :~: ToT ExpectedWithTypeVariablesRPC -_checkWithTypeVariables = Refl - -_checkWithTypeVariablesLaws :: () -_checkWithTypeVariablesLaws = checkLaws @(WithTypeVariables (BigMap Integer MText)) Refl - ----------------------------------------------------------------------------- --- Data type with nested data types and type variables ----------------------------------------------------------------------------- - -data WithNested a = WithNested - { _wnField1 :: WithNested2 a - , _wnField2 :: [WithNested2 a] - , _wnField3 :: WithNested2 [a] - } - deriving stock Generic -deriving anyclass instance IsoValue a => IsoValue (WithNested a) - -data WithNested2 a = WithNested2 - { _wn2Field1 :: a - , _wn2Field2 :: [a] - } - deriving stock Generic - deriving anyclass IsoValue - -deriveManyRPC "WithNested" [] - -data ExpectedWithNestedRPC = ExpectedWithNestedRPC - { expectedWnField1 :: ExpectedWithNested2RPC - , expectedWnField2 :: [ExpectedWithNested2RPC] - , expectedWnField3 :: ExpectedWithNested2RPC' - } - deriving stock Generic - deriving anyclass IsoValue - -data ExpectedWithNested2RPC = ExpectedWithNested2RPC - { expectedWn2Field1 :: BigMapId Integer MText - , expectedWn2Field2 :: [BigMapId Integer MText] - } - deriving stock Generic - deriving anyclass IsoValue - -data ExpectedWithNested2RPC' = ExpectedWithNested2RPC' - { expectedWn2Field1' :: [BigMapId Integer MText] - , expectedWn2Field2' :: [[BigMapId Integer MText]] - } - deriving stock Generic - deriving anyclass IsoValue - -_checkWithNested2 :: ToT (WithNested2RPC (BigMap Integer MText)) :~: ToT ExpectedWithNested2RPC -_checkWithNested2 = Refl - -_checkWithNested :: ToT (WithNestedRPC (BigMap Integer MText)) :~: ToT ExpectedWithNestedRPC -_checkWithNested = Refl - -_checkWithNestedLaws :: () -_checkWithNestedLaws = checkLaws @(WithNested (BigMap Integer MText)) Refl - -_checkWithNested2Laws :: () -_checkWithNested2Laws = checkLaws @(WithNested2 (BigMap Integer MText)) Refl - ----------------------------------------------------------------------------- --- Data type with phantom type variables ----------------------------------------------------------------------------- - -data WithPhantom a b c = WithPhantom - { _wpField1 :: Integer - , _wpField2 :: b - } - deriving stock Generic - deriving anyclass IsoValue -deriveRPC "WithPhantom" - -data ExpectedWithPhantomRPC = ExpectedWithPhantomRPC - { expectedWpField1 :: Integer - , expectedWpField2 :: MText - } - deriving stock Generic - deriving anyclass IsoValue - -_checkWithPhantom :: ToT (WithPhantomRPC Integer MText (BigMap Integer Integer)) :~: ToT ExpectedWithPhantomRPC -_checkWithPhantom = Refl - -_checkWithPhantomLaws :: () -_checkWithPhantomLaws = checkLaws @(WithPhantom Integer MText (BigMap Integer Integer)) Refl - ----------------------------------------------------------------------------- --- Data type with higher-kinded type variables ----------------------------------------------------------------------------- - -data WithHigherKind f = WithHigherKind - { _whkField1 :: WithHigherKindNested f - } - deriving stock Generic -deriving anyclass instance (IsoValue (f Integer MText)) => IsoValue (WithHigherKind f) - -data WithHigherKindNested f = WithHigherKindNested - { _whknField1 :: f Integer MText - } - deriving stock Generic -deriving anyclass instance (IsoValue (f Integer MText)) => IsoValue (WithHigherKindNested f) - -deriveManyRPC "WithHigherKind" [] - -unit_Supports_higher_kinded_types :: Assertion -unit_Supports_higher_kinded_types = do - shouldCompileIgnoringInstance ''Generic - $(deriveManyRPC "WithHigherKind" [] >>= TH.lift) - [d| - data WithHigherKindRPC (f :: * -> * -> *) = WithHigherKindRPC - { _whkField1RPC :: AsRPC (WithHigherKindNested f) - } - type instance AsRPC (WithHigherKind (f :: * -> * -> *)) - = WithHigherKindRPC (f :: * -> * -> *) - deriving anyclass instance IsoValue (AsRPC (WithHigherKindNested f)) - => IsoValue (WithHigherKindRPC (f :: * -> * -> *)) - - data WithHigherKindNestedRPC (f :: * -> * -> *) = WithHigherKindNestedRPC - { _whknField1RPC :: AsRPC (f Integer MText) - } - type instance AsRPC (WithHigherKindNested (f :: * -> * -> *)) - = WithHigherKindNestedRPC (f :: * -> * -> *) - deriving anyclass instance IsoValue (AsRPC (f Integer MText)) - => IsoValue (WithHigherKindNestedRPC (f :: * -> * -> *)) - |] - -data ExpectedWithHigherKindRPC = ExpectedWithHigherKindRPC - { expectedWhkField1 :: ExpectedWithHigherKindNestedRPC - } - deriving stock Generic - deriving anyclass IsoValue - -data ExpectedWithHigherKindNestedRPC = ExpectedWithHigherKindNestedRPC - { expectedWhknField1 :: Map Integer MText - } - deriving stock Generic - deriving anyclass IsoValue - -_checkWithHigherKindNested :: ToT (WithHigherKindNestedRPC Map) :~: ToT ExpectedWithHigherKindNestedRPC -_checkWithHigherKindNested = Refl - -_checkWithHigherKind :: ToT (WithHigherKindRPC Map) :~: ToT ExpectedWithHigherKindRPC -_checkWithHigherKind = Refl - -_checkWithHigherKindLaws :: () -_checkWithHigherKindLaws = checkLaws @(WithHigherKind Map) Refl - -_checkWithHigherKindNestedLaws :: () -_checkWithHigherKindNestedLaws = checkLaws @(WithHigherKindNested Map) Refl - ----------------------------------------------------------------------------- --- Newtypes allowed with deriveRPC and in deriveManyRPC ----------------------------------------------------------------------------- - -data Data1 b = Data1 b - deriving stock (Generic, Eq, Ord) - deriving anyclass IsoValue - -deriveRPC "Data1" - -newtype Nt1 a b = Nt1 [Data1 a] - deriving stock (Generic, Eq, Ord) -deriving anyclass instance IsoValue a => IsoValue (Nt1 a b) - -deriveRPC "Nt1" - -unit_Can_derive_instances_with_newtype :: Assertion -unit_Can_derive_instances_with_newtype = do - shouldCompileIgnoringInstance ''Generic - $(deriveRPC "Nt1" >>= TH.lift) - [d| - newtype Nt1RPC a (b :: k) = Nt1RPC (AsRPC ([Data1 a])) - type instance AsRPC (Nt1 a (b :: k)) = Nt1RPC a (b :: k) - deriving anyclass instance IsoValue (AsRPC ([Data1 a])) => IsoValue (Nt1RPC a (b :: k)) - |] - -newtype Nt2 = Nt2 { _nt2field :: Integer } - deriving stock Generic - deriving anyclass IsoValue - -newtype Nt3 a = Nt3 a - deriving stock Generic - deriving anyclass IsoValue - -newtype Nt4 a b = Nt4 (BigMap Integer MText) - deriving stock Generic - deriving anyclass IsoValue - -newtype Nt5 a = Nt5 a - deriving stock Generic - deriving anyclass IsoValue - -newtype Nt6 a = Nt6 (Nt5 a) - deriving stock Generic -deriving anyclass instance IsoValue a => IsoValue (Nt6 a) - -data Data2 a = Data2 (Nt6 a) - deriving stock Generic -deriving anyclass instance IsoValue a => IsoValue (Data2 a) - -data ExampleWithNewtypes = ExampleWithNewtypes - { _ewnField1 :: Nt3 Nt2 - , _ewnField2 :: Nt4 MText Integer - , _ewnField3 :: Data2 Integer - } - deriving stock Generic - deriving anyclass IsoValue - -deriveManyRPC "ExampleWithNewtypes" [] - -unit_Can_derive_many_instances_with_newtypes :: Assertion -unit_Can_derive_many_instances_with_newtypes = do - shouldCompileIgnoringInstance ''Generic - $(deriveManyRPC "ExampleWithNewtypes" [] >>= TH.lift) - [d| - data ExampleWithNewtypesRPC = ExampleWithNewtypesRPC - {_ewnField1RPC :: (AsRPC (Nt3 Nt2)) - , _ewnField2RPC :: (AsRPC (Nt4 MText Integer)) - , _ewnField3RPC :: (AsRPC (Data2 Integer)) - } - - type instance AsRPC ExampleWithNewtypes = ExampleWithNewtypesRPC - deriving anyclass instance IsoValue ExampleWithNewtypesRPC - - newtype Nt3RPC a = Nt3RPC (AsRPC a) - type instance AsRPC (Nt3 a) = Nt3RPC a - deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Nt3RPC a) - - newtype Nt2RPC = Nt2RPC {_nt2fieldRPC :: (AsRPC Integer)} - type instance AsRPC Nt2 = Nt2RPC - deriving anyclass instance IsoValue Nt2RPC - - newtype Nt4RPC (a :: k) (b :: k) = Nt4RPC (AsRPC (BigMap Integer MText)) - type instance AsRPC (Nt4 (a :: k) (b :: k)) = Nt4RPC (a :: k) (b :: k) - deriving anyclass instance IsoValue (Nt4RPC (a :: k) (b :: k)) - - data Data2RPC a = Data2RPC (AsRPC (Nt6 a)) - type instance AsRPC (Data2 a) = Data2RPC a - deriving anyclass instance IsoValue (AsRPC (Nt6 a)) => IsoValue (Data2RPC a) - - newtype Nt6RPC a = Nt6RPC (AsRPC (Nt5 a)) - type instance AsRPC (Nt6 a) = Nt6RPC a - deriving anyclass instance IsoValue (AsRPC (Nt5 a)) => IsoValue (Nt6RPC a) - - newtype Nt5RPC a = Nt5RPC (AsRPC a) - type instance AsRPC (Nt5 a) = Nt5RPC a - deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Nt5RPC a) - |] - ----------------------------------------------------------------------------- --- Type aliases allowed with deriveManyRPC ----------------------------------------------------------------------------- - -type Ty1 = Integer - -type Ty2 k v = BigMap k v - -type Ty3 phantom = Ty1 - -data Dt1 = Dt1 Integer - deriving stock (Generic, Eq, Ord) - deriving anyclass IsoValue - -data Dt2 a = Dt2 a - deriving stock Generic - deriving anyclass IsoValue - -type Ty4 = Dt1 - -type Ty5 a = Dt2 a - -data Dt3 k v = Dt3 k v - deriving stock (Generic, Eq, Ord) - deriving anyclass IsoValue - -type Ty6 v = Dt3 Integer v - -data Dt4 v = Dt4 (Ty6 v) - deriving stock (Generic, Eq, Ord) -deriving anyclass instance IsoValue v => IsoValue (Dt4 v) - -data Dt5 a = Dt5 a - deriving stock Generic - deriving anyclass IsoValue - -type Ty7 (f :: Type -> Type) = (f Integer) - -data Dt6 = Dt6 Integer - deriving stock (Generic, Eq, Ord) - deriving anyclass IsoValue - -data Dt7 a b = Dt7 a b - deriving stock Generic - deriving anyclass IsoValue - -data Dt8 = Dt8 [BigMap Integer MText] - deriving stock Generic - deriving anyclass IsoValue - -type Ty8 (f :: Type -> Type -> Type) a = f a Dt6 -type Ty9 (f :: Type -> Type -> Type) a = Ty8 f a -type Ty10 (f :: Type -> Type -> Type) a = Ty9 f a - -data ExampleTypeAliasMany = ExampleTypeAliasMany - { _etamField1 :: Ty1 - , _etamField2 :: Ty2 Integer MText - , _etamField3 :: Ty3 Integer - , _etamField4 :: Ty4 - , _etamField5 :: Ty5 Integer - , _etamField6 :: Ty6 MText - , _etamField7 :: Ty7 Dt5 - , _etamField8 :: Ty10 Dt7 Dt8 - , _etamField9 :: Dt4 Integer - } - deriving stock Generic - deriving anyclass IsoValue - --- Check that the declarations generated by `deriveManyRPC` actually compile. -deriveManyRPC "ExampleTypeAliasMany" [] - -unit_Can_derive_many_instances_with_type_aliases :: Assertion -unit_Can_derive_many_instances_with_type_aliases = do - shouldCompileIgnoringInstance ''Generic - $(deriveManyRPC "ExampleTypeAliasMany" [] >>= TH.lift) - [d| - data ExampleTypeAliasManyRPC = ExampleTypeAliasManyRPC - { _etamField1RPC :: AsRPC Ty1 - , _etamField2RPC :: AsRPC (Ty2 Integer MText) - , _etamField3RPC :: AsRPC (Ty3 Integer) - , _etamField4RPC :: AsRPC Ty4 - , _etamField5RPC :: AsRPC (Ty5 Integer) - , _etamField6RPC :: AsRPC (Ty6 MText) - , _etamField7RPC :: AsRPC (Ty7 Dt5) - , _etamField8RPC :: AsRPC (Ty10 Dt7 Dt8) - , _etamField9RPC :: AsRPC (Dt4 Integer) - } - type instance AsRPC ExampleTypeAliasMany = ExampleTypeAliasManyRPC - deriving anyclass instance IsoValue ExampleTypeAliasManyRPC - - -- An instance is generated for Dt1 - data Dt1RPC = Dt1RPC (AsRPC Integer) - type instance AsRPC Dt1 = Dt1RPC - deriving anyclass instance IsoValue Dt1RPC - - -- An instance is generated for Dt2 - data Dt2RPC a = Dt2RPC (AsRPC a) - type instance AsRPC (Dt2 a) = Dt2RPC a - deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Dt2RPC a) - - -- An instance is generated for Dt3 - data Dt3RPC k v = Dt3RPC (AsRPC k) (AsRPC v) - type instance AsRPC (Dt3 k v) = Dt3RPC k v - deriving anyclass instance (IsoValue (AsRPC k), IsoValue (AsRPC v)) => IsoValue (Dt3RPC k v) - - -- An instance is generated for Dt5 - data Dt5RPC a = Dt5RPC (AsRPC a) - type instance AsRPC (Dt5 a) = Dt5RPC a - deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Dt5RPC a) - - -- An instance is generated for Dt6 - data Dt6RPC = Dt6RPC (AsRPC Integer) - type instance AsRPC Dt6 = Dt6RPC - deriving anyclass instance IsoValue Dt6RPC - - -- An instance is generated for Dt7 - data Dt7RPC a b = Dt7RPC (AsRPC a) (AsRPC b) - type instance AsRPC (Dt7 a b) = Dt7RPC a b - deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (Dt7RPC a b) - - -- An instance is generated for Dt8 - data Dt8RPC = Dt8RPC (AsRPC ([BigMap Integer MText])) - type instance AsRPC Dt8 = Dt8RPC - deriving anyclass instance IsoValue Dt8RPC - - -- An instance is generated for Dt4 - data Dt4RPC v = Dt4RPC (AsRPC (Ty6 v)) - type instance AsRPC (Dt4 v) = Dt4RPC v - deriving anyclass instance IsoValue (AsRPC (Ty6 v)) => IsoValue (Dt4RPC v) - |] diff --git a/test/Test/BigMapGet.hs b/test/Test/BigMapGet.hs --- a/test/Test/BigMapGet.hs +++ b/test/Test/BigMapGet.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.BigMapGet ( test_BigMapGetUnit @@ -12,7 +11,7 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L +import Lorentz qualified as L import Lorentz.Pack (expressionToScriptExpr) import Morley.Micheline (decodeExpression) import Morley.Tezos.Crypto (encodeBase58Check) diff --git a/test/Test/Fees.hs b/test/Test/Fees.hs --- a/test/Test/Fees.hs +++ b/test/Test/Fees.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Fees ( test_Fees_comp_iterations @@ -11,14 +10,14 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L +import Lorentz qualified as L import Morley.Client.Action.Origination import Morley.Client.Action.Transaction import Morley.Client.RPC.Types import Morley.Client.TezosClient import Morley.Michelson.Runtime.GState (genesisAddress1, genesisAddress2) import Morley.Michelson.Untyped.Entrypoints -import Morley.Tezos.Core (toMutez) +import Morley.Tezos.Core (tz) import Test.Util import TestM @@ -85,7 +84,7 @@ let forgeCalls = runForgesCountingTest $ lTransfer genesisAddress1 genesisAddress2 - (toMutez 10) DefEpName () Nothing + [tz|10u|] DefEpName () Nothing in forgeCalls @?= sum [ 2 -- for fees adjustment , 1 -- check on fees being on par @@ -96,7 +95,7 @@ let forgeCalls = runForgesCountingTest $ lOriginateContract True "c" - (AddressResolved genesisAddress1) (toMutez 10) + (AddressResolved genesisAddress1) [tz|10u|] averageContract () Nothing in forgeCalls @?= sum [ 2 -- for fees adjustment diff --git a/test/Test/KeyRevealing.hs b/test/Test/KeyRevealing.hs --- a/test/Test/KeyRevealing.hs +++ b/test/Test/KeyRevealing.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2021 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.KeyRevealing ( test_keyRevealing @@ -10,11 +9,11 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L +import Lorentz qualified as L import Morley.Client import Morley.Michelson.Runtime.GState (genesisAddress1) import Morley.Michelson.Typed -import Morley.Tezos.Core (toMutez) +import Morley.Tezos.Core (tz) import Test.Util import TestM @@ -81,10 +80,10 @@ ] where dummyTransfer from to = - void $ transfer from to (toMutez 10) DefEpName (toVal ()) Nothing + void $ transfer from to [tz|10u|] DefEpName (toVal ()) Nothing originateDummy addr = - lOriginateContract True "dummy" (AddressResolved addr) (toMutez 10) + lOriginateContract True "dummy" (AddressResolved addr) [tz|10u|] dumbLorentzContract () Nothing -- | Handlers which don't allow to reveal key. diff --git a/test/Test/Origination.hs b/test/Test/Origination.hs --- a/test/Test/Origination.hs +++ b/test/Test/Origination.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Origination ( test_lRunTransactionsUnit @@ -12,7 +11,7 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L +import Lorentz qualified as L import Morley.Client import Morley.Michelson.Runtime.GState (genesisAddress1, genesisAddress2, genesisAddress3) import Morley.Tezos.Core @@ -36,11 +35,11 @@ test_lRunTransactionsUnit = testGroup "Mock test transaction sending" [ testCase "Successful origination" $ handleSuccess $ runMockTest chainOperationHandlers mockState $ - lOriginateContract True "dummy" (AddressResolved genesisAddress1) (toMutez 100500) + lOriginateContract True "dummy" (AddressResolved genesisAddress1) [tz|100500u|] dumbLorentzContract () Nothing , testCase "Originator doesn't exist" $ handleUnknownContract $ runMockTest chainOperationHandlers mockState $ - lOriginateContract True "dummy" (AddressResolved genesisAddress3) (toMutez 100500) + lOriginateContract True "dummy" (AddressResolved genesisAddress3) [tz|100500u|] dumbLorentzContract () Nothing ] where diff --git a/test/Test/ParameterTypeGet.hs b/test/Test/ParameterTypeGet.hs --- a/test/Test/ParameterTypeGet.hs +++ b/test/Test/ParameterTypeGet.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.ParameterTypeGet ( test_parameterTypeGetUnit @@ -11,16 +10,16 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) -import qualified Lorentz as L +import Lorentz qualified as L import Morley.Client import Morley.Client.RPC.Getters import Morley.Client.RPC.Types import Morley.Micheline import Morley.Michelson.Runtime.GState (genesisAddress1) -import Morley.Michelson.TypeCheck.TypeCheck (SomeParamType, unsafeMkSomeParamType) +import Morley.Michelson.TypeCheck.TypeCheck (SomeParamType, mkSomeParamType) import Morley.Michelson.Typed -import qualified Morley.Michelson.Untyped as U +import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Test.Util import TestM @@ -66,8 +65,8 @@ getContractsParameterTypes [genesisAddress1, smartContractAddr1, smartContractAddr2] ) $ fromList - [ (contractHash1, unsafeMkSomeParamType $ U.ParameterType (U.Ty U.TNat U.noAnn) U.noAnn) - , (contractHash2, unsafeMkSomeParamType $ U.ParameterType (U.Ty U.TBool U.noAnn) U.noAnn) + [ (contractHash1, unsafe . mkSomeParamType $ U.ParameterType (U.Ty U.TNat U.noAnn) U.noAnn) + , (contractHash2, unsafe . mkSomeParamType $ U.ParameterType (U.Ty U.TBool U.noAnn) U.noAnn) ] , testCase "Parameter type for nonexistent smart contract is not extracted" $ expectContractMap diff --git a/test/Test/Parser.hs b/test/Test/Parser.hs --- a/test/Test/Parser.hs +++ b/test/Test/Parser.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Parser ( test_bakerFeeParser @@ -15,18 +14,19 @@ import Morley.Client.TezosClient.Types (SecretKeyEncryption(..)) import Morley.Micheline import Morley.Tezos.Core +import Morley.Util.SizedList qualified as SL test_bakerFeeParser :: TestTree test_bakerFeeParser = testGroup "tezos-client baker fee parser" [ testCase "resulted fee is multiplied by 1e6" $ - parseBakerFeeFromOutput "Fee to the baker: ꜩ0.056008\n" 1 `shouldBe` - Right [TezosMutez $ toMutez 56008] + parseBakerFeeFromOutput @1 "Fee to the baker: ꜩ0.056008\n" + `shouldBe` Right (one $ TezosMutez [tz|56008u|]) , testCase "multiples fees can be parsed" $ - parseBakerFeeFromOutput "Fee to the baker: ꜩ0.056008\n Fee to the baker: ꜩ0.056008\n" 2 `shouldBe` - Right (replicate 2 $ TezosMutez $ toMutez 56008) + parseBakerFeeFromOutput @2 "Fee to the baker: ꜩ0.056008\n Fee to the baker: ꜩ0.056008\n" + `shouldBe` Right (SL.replicateT @2 $ TezosMutez [tz|56008u|]) , testCase "no valid baker fee in the output" $ - parseBakerFeeFromOutput "Notfee to the baker: ꜩ0.056008\n" 1 `shouldSatisfy` - isLeft + parseBakerFeeFromOutput @1 "Notfee to the baker: ꜩ0.056008\n" + `shouldSatisfy` isLeft ] test_secretKeyEncriptionParser :: TestTree diff --git a/test/Test/ReadBigMapValue.hs b/test/Test/ReadBigMapValue.hs --- a/test/Test/ReadBigMapValue.hs +++ b/test/Test/ReadBigMapValue.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.ReadBigMapValue ( test_ReadBigMapValueUnit diff --git a/test/Test/Transaction.hs b/test/Test/Transaction.hs --- a/test/Test/Transaction.hs +++ b/test/Test/Transaction.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Transaction ( test_lRunTransactionsUnit @@ -15,7 +14,7 @@ import Morley.Client.Action.Transaction import Morley.Michelson.Runtime.GState (genesisAddress1, genesisAddress2, genesisAddress3) import Morley.Michelson.Untyped.Entrypoints -import Morley.Tezos.Core (toMutez) +import Morley.Tezos.Core (tz) import Test.Util import TestM @@ -33,15 +32,15 @@ [ testCase "Successful transaction" $ handleSuccess $ runMockTest chainOperationHandlers mockState $ lTransfer genesisAddress1 genesisAddress2 - (toMutez 10) DefEpName () Nothing + [tz|10u|] DefEpName () Nothing , testCase "Sender doesn't exist" $ handleUnknownContract $ runMockTest chainOperationHandlers mockState $ lTransfer genesisAddress3 genesisAddress2 - (toMutez 10) DefEpName () Nothing + [tz|10u|] DefEpName () Nothing , testCase "Destination doesn't exist" $ handleUnknownContract $ runMockTest chainOperationHandlers mockState $ lTransfer genesisAddress1 genesisAddress3 - (toMutez 10) DefEpName () Nothing + [tz|10u|] DefEpName () Nothing ] where handleSuccess :: Either SomeException a -> Assertion diff --git a/test/Test/Util.hs b/test/Test/Util.hs --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA -- | Module with various helpers that are used in morley-client mock tests. module Test.Util @@ -11,47 +10,37 @@ , mapToContractStateBigMap , handleGetBigMapValue - -- * TemplateHaskell test helpers - , shouldCompileTo - , shouldCompileIgnoringInstance -- * Internals , handleRunOperationInternal , assertHeadBlockId ) where -import Prelude hiding (Type) - import Control.Exception.Safe (throwString) import Control.Lens (at, (?~)) import Data.Aeson (encode) import Data.ByteArray (ScrubbedBytes) -import qualified Data.ByteString.Lazy as LBS (toStrict) -import qualified Data.Generics as SYB +import Data.ByteString.Lazy qualified as LBS (toStrict) import Data.Map as Map (elems, fromList, insert, lookup, toList) import Data.Singletons (demote) import Fmt ((+|), (|+)) -import Language.Haskell.TH (pprint) -import Language.Haskell.TH.Syntax - (Dec(..), Name, Q, TyVarBndr(..), Type(..), mkName, nameBase, runQ) import Network.HTTP.Types.Status (status404) import Network.HTTP.Types.Version (http20) import Servant.Client.Core (BaseUrl(..), ClientError(..), RequestF(..), ResponseF(..), Scheme(..), defaultRequest) -import Test.Tasty.HUnit (Assertion, (@?=)) import Text.Hex (encodeHex) -import qualified Text.Show (show) import Lorentz as L (compileLorentz, drop) import Lorentz.Constraints import Lorentz.Pack import Morley.Client.RPC.Types import Morley.Client.TezosClient.Types +import Morley.Client.Types import Morley.Micheline import Morley.Michelson.Typed import Morley.Tezos.Address import Morley.Tezos.Core import Morley.Tezos.Crypto -import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519 +import Morley.Tezos.Crypto.Ed25519 qualified as Ed25519 import Morley.Util.ByteString import TestM @@ -98,9 +87,7 @@ , hGetProtocolParameters = handleGetProtocolParameters , hRunOperation = handleRunOperation , hPreApplyOperations = mapM . handlePreApplyOperation - , hForgeOperation = \blkId arg -> do - assertHeadBlockId blkId - pure . HexJSONByteString . LBS.toStrict . encode $ arg + , hForgeOperation = handleForgeOperation , hInjectOperation = pure . OperationHash . (<> "_injected") . encodeHex . unHexJSONByteString , hGetContractScript = handleGetContractScript , hSignBytes = @@ -109,8 +96,8 @@ , hGetAlias = handleGetAlias , hResolveAddressMaybe = handleResolveAddressMaybe , hRememberContract = handleRememberContract - , hCalcTransferFee = \_ _ _ _ -> pure $ [TezosMutez $ toMutez 100500] - , hCalcOriginationFee = \_ -> pure $ TezosMutez $ toMutez 100500 + , hCalcTransferFee = \_ _ _ _ -> pure $ [TezosMutez [tz|100500u|]] + , hCalcOriginationFee = \_ -> pure $ TezosMutez [tz|100500u|] , hGetKeyPassword = \_ -> pure Nothing , hGenKey = handleGenKey , hGetManagerKey = handleGetManagerKey @@ -132,9 +119,11 @@ handleGetBlockHash :: Monad m => BlockId -> TestT m Text handleGetBlockHash blkId = do - assertHeadBlockId blkId + unless (blkId == FinalHeadId) do + throwString "Expected `getBlockHash` to be called with `head~2`." + MockState{..} <- get - pure $ msHeadBlock + pure msFinalHeadBlock handleGetCounter :: ( MonadState MockState m @@ -150,10 +139,10 @@ handleGetBlockConstants :: MonadState MockState m - => anything -> m BlockConstants -handleGetBlockConstants _ = do + => BlockId -> m BlockConstants +handleGetBlockConstants blkId = do MockState{..} <- get - pure $ msBlockConstants + pure $ msBlockConstants blkId handleGetProtocolParameters :: (MonadState MockState m, MonadThrow m) @@ -168,7 +157,11 @@ assertHeadBlockId blk MockState{..} <- get -- Ensure that passed chain id matches with one that mock state has - unless (roChainId == bcChainId msBlockConstants) (throwM $ InvalidChainId) + unless (roChainId == bcChainId (msBlockConstants blk)) (throwM $ InvalidChainId) + -- As of release of the ithaca protocol, the "branch" field should be "head~2". + -- https://web.archive.org/web/20220305165609/https://tezos.gitlab.io/protocols/tenderbake.html + unless (roiBranch roOperation == msFinalHeadBlock) do + throwM $ InvalidBranch $ roiBranch roOperation originatedContracts <- handleRunOperationInternal roOperation pure $ mkRunOperationResult originatedContracts @@ -177,21 +170,36 @@ assertHeadBlockId blk MockState{..} <- get -- Ensure that passed protocol matches with one that mock state has - unless (paoProtocol == bcProtocol msBlockConstants) (throwM $ InvalidProtocol) + unless (paoProtocol == bcProtocol (msBlockConstants blk)) $ + throwM InvalidProtocol + -- As of release of the ithaca protocol, the "branch" field should be "head~2". + -- https://web.archive.org/web/20220305165609/https://tezos.gitlab.io/protocols/tenderbake.html + unless (paoBranch == msFinalHeadBlock) do + throwM $ InvalidBranch paoBranch originatedContracts <- concatMapM handleTransactionOrOrigination paoContents pure $ mkRunOperationResult originatedContracts +handleForgeOperation :: Monad m => BlockId -> ForgeOperation -> TestT m HexJSONByteString +handleForgeOperation blkId op = do + assertHeadBlockId blkId + ms <- get + -- As of release of the ithaca protocol, the "branch" field should be "head~2". + -- https://web.archive.org/web/20220305165609/https://tezos.gitlab.io/protocols/tenderbake.html + unless (foBranch op == msFinalHeadBlock ms) do + throwM $ InvalidBranch $ foBranch op + pure . HexJSONByteString . LBS.toStrict . encode $ op + handleRunOperationInternal :: Monad m => RunOperationInternal -> TestT m [Address] handleRunOperationInternal RunOperationInternal{..} = do concatMapM handleTransactionOrOrigination roiContents handleTransactionOrOrigination - :: Monad m => Either TransactionOperation OriginationOperation -> TestT m [Address] + :: Monad m => OperationInput -> TestT m [Address] handleTransactionOrOrigination op = do MockState{..} <- get - case op of + case oiCustom op of -- Ensure that transaction sender exists - Left TransactionOperation{..} -> case lookup codSource msContracts of + OpTransfer TransactionOperation{..} -> case lookup codSource msContracts of Nothing -> throwM $ UnknownContract $ AddressResolved codSource Just ContractState{..} -> do -- Ensure that sender counter matches @@ -199,22 +207,23 @@ case lookup toDestination msContracts of Nothing -> throwM $ UnknownContract $ AddressResolved toDestination Just _ -> pure [] - where - CommonOperationData{..} = toCommonData -- Ensure that originator exists - Right OriginationOperation{..} -> case lookup codSource msContracts of + OpOriginate _ -> case lookup codSource msContracts of Nothing -> throwM $ UnknownContract $ AddressResolved codSource Just ContractState{..} -> do -- Ensure that originator counter matches unless (csCounter + 1 == codCounter) (throwM CounterMismatch) pure [dummyContractAddr] where - CommonOperationData{..} = ooCommonData - dummyContractAddr = unsafeParseAddress "KT1LZwEZqbqtLYhwzaidBp6So9LgYDpkpEv7" + dummyContractAddr = unsafe $ parseAddress "KT1LZwEZqbqtLYhwzaidBp6So9LgYDpkpEv7" + OpReveal _ -> + -- We do not care about reveals at the moment + return [] + where + CommonOperationData{..} = oiCommonData op --- We don't pass non-head block anywhere in @morley-client@, this feature --- exists only for external users. -assertHeadBlockId :: MonadThrow m => BlockId -> m () +-- | In most places, @morley-client@ executes operations against the @head@ block. +assertHeadBlockId :: (HasCallStack, MonadThrow m) => BlockId -> m () assertHeadBlockId blockId = unless (blockId == HeadId) $ throwString "Accessing non-head block is not supported in tests" @@ -362,65 +371,3 @@ dumbManagerKey :: PublicKey dumbManagerKey = fromRight (error "impossible") $ parsePublicKey "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V" - ----------------------------------------------------------------------------- --- TemplateHaskell test helpers ----------------------------------------------------------------------------- - -shouldCompileTo :: HasCallStack => [Dec] -> Q [Dec] -> Assertion -shouldCompileTo actualDecs expectedQ = do - expectedDecs <- runQ expectedQ - PrettyDecs (normalizeDecs actualDecs) @?= PrettyDecs (normalizeDecs expectedDecs) - --- | Same as 'shouldCompileTo', but ignores instance declarations of the given class. -shouldCompileIgnoringInstance :: HasCallStack => Name -> [Dec] -> Q [Dec] -> Assertion -shouldCompileIgnoringInstance className actualDecs expectedQ = do - expectedDecs <- runQ expectedQ - let actualDecs' = filter (not . isInstance) actualDecs - PrettyDecs (normalizeDecs actualDecs') @?= PrettyDecs (normalizeDecs expectedDecs) - - where - isInstance :: Dec -> Bool - isInstance = \case - InstanceD _ _ (ConT t `AppT` _) _ | t == className -> True - _ -> False - --- | Normalize ASTs to make them comparable. --- --- By default, quoted ASTs and ASTs with names created using 'newName' will have --- names with unique IDs. --- For example: --- --- > decs <- runQ [d|data D = D { f :: Int } |] --- > putStrLn $ pprint decs --- > --- > -- Will generate this AST: --- > data D_0 = D_1 { f_2 :: Int } --- --- To be able to check if two ASTs are equivalent, we have to scrub the unique IDs off all names. --- --- For convenience, to make the output easier to read, we also erase kind annotations when the kind is '*'. -normalizeDecs :: [Dec] -> [Dec] -normalizeDecs decs = - SYB.everywhere - (SYB.mkT fixName . SYB.mkT simplifyType . SYB.mkT simplifyTyVar) - decs - where - fixName :: Name -> Name - fixName = mkName . nameBase - - simplifyType :: Type -> Type - simplifyType = \case - SigT t StarT -> t - t -> t - - simplifyTyVar :: TyVarBndr -> TyVarBndr - simplifyTyVar = \case - KindedTV name StarT -> PlainTV name - tv -> tv - -newtype PrettyDecs = PrettyDecs [Dec] - deriving newtype Eq - -instance Show PrettyDecs where - show (PrettyDecs decs) = pprint decs diff --git a/test/TestM.hs b/test/TestM.hs --- a/test/TestM.hs +++ b/test/TestM.hs @@ -1,6 +1,5 @@ --- SPDX-FileCopyrightText: 2020 Tocqueville Group --- --- SPDX-License-Identifier: LicenseRef-MIT-TQ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} @@ -33,6 +32,7 @@ import Data.ByteArray (ScrubbedBytes) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Fmt import Morley.Client import Morley.Client.Logging (ClientLogAction) import Morley.Client.RPC @@ -78,7 +78,7 @@ , hRevealKey :: Alias -> Maybe ScrubbedBytes -> m () , hWaitForOperation :: OperationHash -> m () , hRememberContract :: Bool -> Address -> AliasOrAliasHint -> m () - , hImportKey :: Bool -> AliasOrAliasHint -> SecretKey -> m () + , hImportKey :: Bool -> AliasOrAliasHint -> SecretKey -> m Alias , hResolveAddressMaybe :: AddressOrAlias -> m (Maybe Address) , hGetAlias :: AddressOrAlias -> m Alias , hGetPublicKey :: AddressOrAlias -> m PublicKey @@ -163,7 +163,10 @@ data MockState = MockState { msContracts :: Map Address ContractState , msHeadBlock :: Text - , msBlockConstants :: BlockConstants + -- ^ Hash of the `head` block + , msFinalHeadBlock :: Text + -- ^ Hash of the `head~2` block + , msBlockConstants :: BlockId -> BlockConstants , msProtocolParameters :: ProtocolParameters } @@ -171,7 +174,8 @@ defaultMockState = MockState { msContracts = mempty , msHeadBlock = "HEAD" - , msBlockConstants = BlockConstants + , msFinalHeadBlock = "HEAD~2" + , msBlockConstants = \blkId -> BlockConstants { bcProtocol = "PROTOCOL" , bcChainId = "CHAIN_ID" , bcHeader = BlockHeaderNoHash @@ -179,10 +183,10 @@ , bhnhLevel = 0 , bhnhPredecessor = BlockHash "PREV_HASH" } - , bcHash = BlockHash "HASH" + , bcHash = BlockHash $ pretty blkId } , msProtocolParameters = ProtocolParameters 257 1040000 60000 15 - (TezosMutez $ unsafeMkMutez 250) + (TezosMutez [tz|250u|]) } type TestT m = StateT MockState (ReaderT (TestHandlers m) (CatchT m)) @@ -217,6 +221,7 @@ | CantRevealContract Address | InvalidChainId | InvalidProtocol + | InvalidBranch Text | CounterMismatch deriving stock Show