diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,35 @@ +0.2.0 +===== +* [!1161](https://gitlab.com/morley-framework/morley/-/merge_requests/1161) + Remove support for `AliasHint` +* [!1164](https://gitlab.com/morley-framework/morley/-/merge_requests/1164) + Add `now` and `level` params to the `/run_code` +* [!1150](https://gitlab.com/morley-framework/morley/-/merge_requests/1150) + Implement wait-for-operation via RPC + + Block injection is now checked for errors and injection is retried. +* [!1159](https://gitlab.com/morley-framework/morley/-/merge_requests/1159) + Add script size calculation to morley-client +* [!1088](https://gitlab.com/morley-framework/morley/-/merge_requests/1088) + Move data types related to address aliases to `morley`. +* [!1155](https://gitlab.com/morley-framework/morley/-/merge_requests/1155) + Update operations limits estimation to match the v13.0 `tezos-client` implementation. +* [!1147](https://gitlab.com/morley-framework/morley/-/merge_requests/1147) + Fix error handling in morley-client + + `handleOperationResult` is now exported from `Morley.Client.Action.Common` +* [!1114](https://gitlab.com/morley-framework/morley/-/merge_requests/1114) + Update to ghc-9.0.2 +* [!1108](https://gitlab.com/morley-framework/morley/-/merge_requests/1108) + Remove support for the deprecated morley extensions +* [!1133](https://gitlab.com/morley-framework/morley/-/merge_requests/1133) + Add missing fields to `TransactionOpResp` constructor. +* [!1127](https://gitlab.com/morley-framework/morley/-/merge_requests/1127) + Add method to get secret key from tezos-client +* [!1140](https://gitlab.com/morley-framework/morley/-/merge_requests/1140) + Derive `newtype` `Eq`, `Ord`, `Show`, `Buildable` instances for `BlockHash` + 0.1.2 ===== * [!1017](https://gitlab.com/morley-framework/morley/-/merge_requests/1017) @@ -31,7 +60,7 @@ 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. + + Use `Buildable` and `pretty` preferentially. + Add `Buildable` instances to that effect for `FeeParserException`, `SecretKeyEncryptionParserException`. + Use `displayException` instead of `show` where appropriate. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,9 +1,6 @@ -- 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 @@ -18,11 +15,12 @@ import Morley.Client import Morley.Client.Parser -import Morley.Client.RPC (BlockOperation(..), OperationResp(..)) +import Morley.Client.RPC (BlockOperation(..), OperationResp(..), OperationRespWithMeta(..)) import Morley.Client.RPC.Getters import Morley.Client.Util (extractAddressesFromValue) -import Morley.Michelson.Runtime (prepareContract, prepareContractExt) -import Morley.Michelson.TypeCheck (typeCheckContract, typeCheckingWith, typeVerifyParameter) +import Morley.Michelson.Runtime (prepareContract) +import Morley.Michelson.TypeCheck + (typeCheckContract, typeCheckContractAndStorage, typeCheckingWith, typeVerifyParameter) import Morley.Michelson.Typed (Contract, Contract'(..), SomeContract(..)) import Morley.Michelson.Typed.Value (Value'(..)) import Morley.Michelson.Untyped qualified as U @@ -31,11 +29,11 @@ import Morley.Util.Exception (throwLeft) import Morley.Util.Main (wrapMain) -mainImpl :: Bool -> ClientArgsRaw -> MorleyClientM () -mainImpl exts cmd = +mainImpl :: ClientArgsRaw -> MorleyClientM () +mainImpl cmd = case cmd of Originate OriginateArgs{..} -> do - contract <- liftIO $ (if exts then prepareContractExt else prepareContract) oaMbContractFile + contract <- liftIO $ prepareContract oaMbContractFile let originator = oaOriginateFrom (operationHash, contractAddr) <- originateUntypedContract True oaContractName originator oaInitialBalance @@ -64,6 +62,7 @@ U.ValueUnit -> transfer sendAddress destAddress taAmount U.DefEpName VUnit Nothing _ -> throwString ("The transaction parameter must be 'Unit' " <> "when transferring to an implicit account") + TransactionRollupAddress _ -> throwString "Only smart contracts can call txr1 addresses" putTextLn $ "Transaction was successfully sent.\nOperation hash " <> pretty operationHash <> "." @@ -75,13 +74,20 @@ blockHeader <- getBlockHeader blockId putStrLn $ Aeson.encode blockHeader + GetScriptSize GetScriptSizeArgs{..} -> do + contract <- liftIO $ prepareContract (Just ssScriptFile) + void . throwLeft . pure . typeCheckingWith def $ + typeCheckContractAndStorage contract ssStorage + size <- computeUntypedContractSize contract ssStorage + print size + GetBlockOperations blockId -> do operationLists <- getBlockOperations blockId forM_ operationLists $ \operations -> do forM_ operations $ \BlockOperation {..} -> do putTextLn $ "Hash: " <> boHash putTextLn $ "Contents: " - forM_ boContents $ \case + forM_ (orwmResponse <$> boContents) \case TransactionOpResp to -> putStrLn $ Aeson.encode to OtherOpResp -> putTextLn "Non-transaction operation" putTextLn "" @@ -97,6 +103,6 @@ setFileSystemEncoding utf8 disableAlphanetWarning - ClientArgs parsedConfig exts cmd <- Opt.execParser morleyClientInfo + ClientArgs parsedConfig cmd <- Opt.execParser morleyClientInfo env <- mkMorleyClientEnv parsedConfig - runMorleyClientM env (mainImpl exts cmd) + runMorleyClientM env (mainImpl 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.2 +version: 0.2.0 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 @@ -35,6 +35,7 @@ Morley.Client.Action.Origination Morley.Client.Action.Origination.Large Morley.Client.Action.Reveal + Morley.Client.Action.SizeCalculation Morley.Client.Action.Transaction Morley.Client.App Morley.Client.Env @@ -235,6 +236,7 @@ other-modules: Ingredients Test.BigMapGet + Test.Errors Test.Fees Test.KeyRevealing Test.Origination diff --git a/src/Morley/Client.hs b/src/Morley/Client.hs --- a/src/Morley/Client.hs +++ b/src/Morley/Client.hs @@ -68,12 +68,6 @@ , readBigMapValue -- * @tezos-client@ - , Alias - , mkAlias - , AliasHint - , mkAliasHint - , AliasOrAliasHint (..) - , AddressOrAlias (..) , addressResolved , HasTezosClient (..) , resolveAddress 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 @@ -8,6 +8,7 @@ ( module Morley.Client.Action.Operation , module Morley.Client.Action.Origination , module Morley.Client.Action.Transaction + , module Morley.Client.Action.SizeCalculation , ClientInput , revealKeyUnlessRevealed ) where @@ -15,4 +16,5 @@ import Morley.Client.Action.Common (ClientInput, revealKeyUnlessRevealed) import Morley.Client.Action.Operation import Morley.Client.Action.Origination +import Morley.Client.Action.SizeCalculation 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 @@ -21,6 +21,7 @@ import Morley.Client.TezosClient import Morley.Client.Types import Morley.Tezos.Address +import Morley.Tezos.Address.Alias (AddressOrAlias) import Morley.Util.Batching {- | Where the batched operations occur. 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 @@ -23,6 +23,7 @@ , toParametersInternals , mkOriginationScript , revealKeyUnlessRevealed + , handleOperationResult ) where import Control.Lens (Prism') @@ -40,18 +41,19 @@ import Morley.Client.Types import Morley.Client.Util import Morley.Micheline (TezosInt64, TezosMutez(..), toExpression) -import Morley.Micheline.Expression (Expression(ExpressionString)) +import Morley.Micheline.Expression (expressionString) import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Scope import Morley.Michelson.Untyped.Entrypoints import Morley.Tezos.Address +import Morley.Tezos.Address.Alias (AddressOrAlias(..), Alias) import Morley.Tezos.Core import Morley.Tezos.Crypto -- | Datatype that contains various values required for -- chain operations. data OperationConstants = OperationConstants - { ocLastBlockHash :: Text + { ocLastBlockHash :: BlockHash -- ^ Block in which operations is going to be injected , ocBlockConstants :: BlockConstants -- ^ Information about block: chain_id and protocol @@ -92,7 +94,7 @@ data OriginationData = forall cp st. (ParameterScope cp, StorageScope st) => OriginationData { odReplaceExisting :: Bool - , odName :: AliasHint + , odName :: Alias , odBalance :: Mutez , odContract :: T.Contract cp st , odStorage :: T.Value st @@ -173,20 +175,30 @@ _ -> throwM $ RpcUnexpectedSize 1 (length results) handleOperationResult runResult expectedContentsSize - where - handleOperationResult :: - MonadThrow m => RunOperationResult -> Int -> m (NonEmpty AppliedResult) - handleOperationResult RunOperationResult{..} expectedContentsSize = do - when (length rrOperationContents /= expectedContentsSize) $ - throwM $ RpcUnexpectedSize expectedContentsSize (length rrOperationContents) - mapM (\(OperationContent (RunMetadata res internalOps)) -> - let internalResults = map unInternalOperation internalOps in - case foldr combineResults res internalResults of - OperationApplied appliedRes -> pure appliedRes - OperationFailed errors -> handleErrors errors - ) rrOperationContents +-- | Handle a result of an operation: throw errors if there was an error, +-- return a nonempty list of applied results if there weren't. +handleOperationResult :: + MonadThrow m => RunOperationResult -> Int -> m (NonEmpty AppliedResult) +handleOperationResult RunOperationResult{..} expectedContentsSize = do + when (length rrOperationContents /= expectedContentsSize) $ + throwM $ RpcUnexpectedSize expectedContentsSize (length rrOperationContents) + let (appliedResults, runErrors) = + sconcat $ first pure . collectResults <$> rrOperationContents + + whenJust runErrors handleErrors + + pure appliedResults + + where + collectResults :: OperationContent -> (AppliedResult, Maybe [RunError]) + collectResults (OperationContent (RunMetadata res internalOps)) = + res : map unInternalOperation internalOps + & flip foldr (mempty, Nothing) \case + OperationApplied result -> first (result <>) + OperationFailed errors -> second (Just errors <>) + -- When an error happens, we will get a list of 'RunError' in response. -- This list often contains more than one item. -- We tested which errors are returned in certain scenarios and added @@ -207,7 +219,7 @@ = throwM $ BadParameter address expr | Just address <- findError _BadContractParameter , Just notation <- findError _InvalidContractNotation - = throwM $ BadParameter address (ExpressionString notation) + = throwM $ BadParameter address (expressionString notation) | Just address <- findError _REEmptyTransaction = throwM $ EmptyTransaction address | Just address <- findError _RuntimeError 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 @@ -15,7 +15,7 @@ import Data.List.NonEmpty qualified as NE import Data.Singletons (Sing, SingI, sing) import Data.Text qualified as T -import Fmt (blockListF', listF, pretty, (+|), (|+)) +import Fmt (blockListF, blockListF', listF, nameF, pretty, (+|), (|+)) import Morley.Client.Action.Common import Morley.Client.Logging @@ -27,6 +27,8 @@ import Morley.Client.Types import Morley.Micheline (StringEncode(..), TezosInt64, TezosMutez(..)) import Morley.Tezos.Address +import Morley.Tezos.Address.Alias (AddressOrAlias(..)) +import Morley.Tezos.Core import Morley.Tezos.Crypto import Morley.Util.ByteString @@ -103,6 +105,10 @@ (opHash, res) <- runOperationsNonEmpty sender $ op :| ops return $ (Just opHash, toList res) +-- | How many times to retry if an operation fails after injection +injectionRetryCount :: Natural +injectionRetryCount = 2 + -- | Perform non-empty sequence of operations. -- -- Returns operation hash and result of each operation @@ -117,7 +123,7 @@ -> NonEmpty (OperationInfo ClientInput) -> m (OperationHash, NonEmpty (OperationInfo Result)) runOperationsNonEmpty sender operations = - runOperationsNonEmptyHelper @'RealRun sender operations + runOperationsNonEmptyHelper @'RealRun injectionRetryCount sender operations -- | Flag that is used to determine @runOperationsNonEmptyHelper@ behaviour. data RunMode = DryRun | RealRun @@ -159,7 +165,7 @@ -> NonEmpty (OperationInfo ClientInput) -> m (NonEmpty (AppliedResult, TezosMutez)) dryRunOperationsNonEmpty sender operations = - runOperationsNonEmptyHelper @'DryRun sender operations + runOperationsNonEmptyHelper @'DryRun 0 sender operations -- | Perform non-empty sequence of operations and either dry-run -- and return estimated limits and fees or perform operation injection. @@ -171,10 +177,11 @@ , WithClientLog env m , SingI runMode ) - => AddressOrAlias + => Natural + -> AddressOrAlias -> NonEmpty (OperationInfo ClientInput) -> m (RunResult runMode) -runOperationsNonEmptyHelper sender operations = do +runOperationsNonEmptyHelper retryCount sender operations = do logOperations @runMode sender operations senderAddress <- resolveAddress sender prohibitContractSender senderAddress $ head operations @@ -185,7 +192,7 @@ pp <- getProtocolParameters OperationConstants{..} <- preProcessOperation senderAddress - let convertOps i = OperationInput commonData . \case + let convertOps i = WithCommonOperationData commonData . \case OpTransfer (TransactionData TD {..}) -> OpTransfer TransactionOperation { toDestination = tdReceiver @@ -238,9 +245,20 @@ -- Fill in fees let - updateOp opToRun mbFee ar isFirst = do + updateOp :: OperationInput -> Maybe Mutez -> AppliedResult -> Bool -> m (OperationInput, Maybe (Signature, ByteString)) + updateOp opToRun@(WithCommonOperationData _ internalOp) mbFee ar isFirst = do + let gasSafetyGuard = 100 + -- @gasSafetyGuard@ is added to origination operations and transfers to non-implicit + -- accounts, see https://gitlab.com/tezos/tezos/-/blob/v13.0/src/proto_013_PtJakart/lib_client/injection.ml#L750 + additionalGas = case internalOp of + OpOriginate _ -> gasSafetyGuard + OpTransfer (TransactionOperation {..}) -> case toDestination of + KeyAddress _ -> 0 + ContractAddress _ -> gasSafetyGuard + TransactionRollupAddress _ -> gasSafetyGuard + OpReveal _ -> 0 let storageLimit = computeStorageLimit [ar] pp + 20 -- similarly to tezos-client, we add 20 for safety - let gasLimit = arConsumedGas ar + 100 -- adding extra for safety + let gasLimit = arConsumedGas ar + additionalGas updateCommonDataForFee fee = updateCommonData gasLimit storageLimit (TezosMutez fee) @@ -249,7 +267,7 @@ @(Maybe (Signature, ByteString)) -- ready operation and its signature (\fee -> return $ opToRun &~ - oiCommonDataL %= updateCommonDataForFee fee + wcoCommonDataL %= updateCommonDataForFee fee ) (\op -> do forgedOp <- forgeOp $ one op @@ -304,11 +322,10 @@ ars2 <- getAppliedResults (Right preApplyOp) case sing @runMode of SDryRun -> do - let fees = map (codFee . oiCommonData) updOps + let fees = map (codFee . wcoCommon) updOps return $ NE.zip ars2 fees SRealRun -> do - operationHash <- injectOperation (HexJSONByteString signedOp) - waitForOperation operationHash + operationHash <- waitForOperation $ injectOperation (HexJSONByteString signedOp) let contractAddrs = arOriginatedContracts <$> ars2 opsRes <- forM (NE.zip operations contractAddrs) $ \case (OpTransfer _, []) -> @@ -322,7 +339,7 @@ throwM RpcOriginatedNoContracts (OpOriginate OriginationData{..}, [addr]) -> do logDebug $ "Saving " +| addr |+ " for " +| odName |+ "\n" - rememberContract odReplaceExisting addr (AnAliasHint odName) + rememberContract odReplaceExisting addr odName alias <- getAlias $ AddressResolved addr logInfo $ "Originated contract: " <> pretty alias return $ OpOriginate addr @@ -332,6 +349,12 @@ return $ OpReveal () forM_ ars2 logStatistics return (operationHash, opsRes) + `catch` \case + (UnexpectedRunErrors errs) | retryCount > 0 -> do + logError $ pretty $ nameF "When injecting operations, there were unexpected errors" $ + blockListF errs + runOperationsNonEmptyHelper @runMode (retryCount - 1) sender operations + e -> throwM e where mayNeedSenderRevealing :: [OperationInfo i] -> Bool mayNeedSenderRevealing = any \case @@ -350,6 +373,7 @@ prohibitContractSender addr op = case (addr, op) of (KeyAddress _, _) -> pass (ContractAddress _, op') -> throwM $ ContractSender addr (opName op') + (TransactionRollupAddress _, op') -> throwM $ ContractSender addr (opName op') opName = \case OpTransfer _ -> "transfer" 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 @@ -41,6 +41,7 @@ import Morley.Michelson.Typed.Scope import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address +import Morley.Tezos.Address.Alias (AddressOrAlias, Alias) import Morley.Tezos.Core import Morley.Util.Exception @@ -74,7 +75,7 @@ , ParameterScope cp ) => Bool - -> AliasHint + -> Alias -> AddressOrAlias -> Mutez -> Contract cp st @@ -93,7 +94,7 @@ , WithClientLog env m ) => Bool - -> AliasHint + -> Alias -> AddressOrAlias -> Mutez -> U.Contract @@ -129,7 +130,7 @@ , NiceParameterFull cp ) => Bool - -> AliasHint + -> Alias -> AddressOrAlias -> Mutez -> L.Contract cp st vd @@ -185,7 +186,7 @@ , ParameterScope cp ) => Bool - -> AliasHint + -> Alias -> AddressOrAlias -> Mutez -> Contract cp st @@ -204,7 +205,7 @@ , WithClientLog env m ) => Bool - -> AliasHint + -> Alias -> AddressOrAlias -> Mutez -> U.Contract @@ -240,7 +241,7 @@ , NiceParameterFull cp ) => Bool - -> AliasHint + -> Alias -> AddressOrAlias -> Mutez -> L.Contract cp st vd @@ -259,7 +260,7 @@ data LOriginationData = forall cp st vd. (NiceParameterFull cp, NiceStorage st) => LOriginationData { lodReplaceExisting :: Bool - , lodName :: AliasHint + , lodName :: Alias , lodBalance :: Mutez , lodContract :: L.Contract cp st vd , lodStorage :: st 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 @@ -53,6 +53,7 @@ import Morley.Michelson.Typed.Util (PushableStorageSplit(..), splitPushableStorage) import Morley.Michelson.Typed.Value import Morley.Michelson.Untyped.Annotation (annQ, noAnn) +import Morley.Tezos.Address.Alias (Alias(..)) -- | Just a utility type to hold 'SomeLargeContractOriginator' and its large -- contract 'OriginationData'. @@ -135,7 +136,7 @@ cEntriesOrder = def cViews = def - cCode = + cCode = T.mkContractCode $ UNPAIR `Seq` -- make checks on the storage DIP @@ -192,7 +193,7 @@ -> T.Contract param store -- ^ large contract -> Mutez -- ^ balance to tranfer during contract creation -> Value (ToT (Lambda (Value heavy) (Address, [Operation]))) -mkOriginationLambda instr largeContract xtzs = VLam $ RfNormal $ +mkOriginationLambda instr largeContract xtzs = mkVLam $ RfNormal $ instr `Seq` PUSH (VMutez xtzs) `Seq` NONE `Seq` CREATE_CONTRACT largeContract `Seq` NIL `Seq` SWAP `Seq` CONS `Seq` SWAP `Seq` PAIR @@ -220,7 +221,7 @@ mkLargeOriginatorData sender' LargeOriginationData{..} = case largeOriginator of SomeLargeContractOriginator heavyVal origContract _origLambda -> OriginationData { odReplaceExisting = odReplaceExisting $ largeContractData - , odName = "largeOriginator." <> odName largeContractData + , odName = Alias $ "largeOriginator." <> unAlias (odName largeContractData) , 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) @@ -272,6 +273,6 @@ case completedStore of Right (VPair (_, VOr (Left largeVAddr))) -> do let largeAddr = fromVal @Address largeVAddr - rememberContract odReplaceExisting largeAddr (AnAliasHint odName) + rememberContract odReplaceExisting largeAddr odName pure largeAddr _ -> throwM RpcOriginatedNoContracts diff --git a/src/Morley/Client/Action/Reveal.hs b/src/Morley/Client/Action/Reveal.hs --- a/src/Morley/Client/Action/Reveal.hs +++ b/src/Morley/Client/Action/Reveal.hs @@ -17,9 +17,10 @@ import Morley.Client.RPC.Error import Morley.Client.RPC.Getters import Morley.Client.RPC.Types -import Morley.Client.TezosClient (AddressOrAlias(..), HasTezosClient) +import Morley.Client.TezosClient (HasTezosClient) import Morley.Client.Types import Morley.Tezos.Address +import Morley.Tezos.Address.Alias (AddressOrAlias(..)) -- | Reveal given key. -- diff --git a/src/Morley/Client/Action/SizeCalculation.hs b/src/Morley/Client/Action/SizeCalculation.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Client/Action/SizeCalculation.hs @@ -0,0 +1,40 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module Morley.Client.Action.SizeCalculation + ( computeUntypedContractSize + , computeContractSize + ) where + +import Morley.Client.RPC +import Morley.Micheline.Class (ToExpression(..)) +import Morley.Michelson.Typed (Contract, Value) +import Morley.Michelson.Typed.Scope +import Morley.Michelson.Untyped qualified as U + +computeUntypedContractSize :: HasTezosRpc m => U.Contract -> U.Value -> m Natural +computeUntypedContractSize ct st = do + pps <- getProtocolParameters + let csProgram = toExpression ct + csStorage = toExpression st + csGas = ppHardGasLimitPerOperation pps + csLegacy = False + ScriptSize size <- getScriptSize CalcSize{..} + return size + +computeContractSize + :: forall m cp st. + ( HasTezosRpc m + , StorageScope st + ) + => Contract cp st + -> Value st + -> m Natural +computeContractSize ct st = do + pps <- getProtocolParameters + let csProgram = toExpression ct + csStorage = toExpression st + csGas = ppHardGasLimitPerOperation pps + csLegacy = False + ScriptSize size <- getScriptSize CalcSize{..} + return size 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 @@ -24,12 +24,12 @@ import Morley.Client.RPC.Error import Morley.Client.RPC.Types import Morley.Client.TezosClient.Class -import Morley.Client.TezosClient.Types 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 +import Morley.Tezos.Address.Alias (AddressOrAlias(..)) import Morley.Tezos.Core (Mutez) -- | Perform sequence of transactions to the contract, each transactions should be 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 @@ -14,7 +14,9 @@ , getCounterImpl , getBlockHeaderImpl , getBlockConstantsImpl + , getScriptSizeAtBlockImpl , getBlockOperationsImpl + , getBlockOperationHashesImpl , getProtocolParametersImpl , runOperationImpl , preApplyOperationsImpl @@ -30,6 +32,7 @@ , runCodeImpl , getChainIdImpl , getDelegateImpl + , waitForOperationImpl -- * Timeouts and retries , retryOnTimeout @@ -51,8 +54,11 @@ import Servant.Client.Core (ClientError(..), Request, RequestBody(..), RequestF(..), Response, ResponseF(..), RunClient) import Servant.Client.Core.RunClient (runRequest) +import Servant.Client.Streaming (withClientM) +import Servant.Types.SourceT (SourceT(unSourceT), StepT(..)) import System.Random (randomRIO) -import UnliftIO (MonadUnliftIO) +import UnliftIO (MonadUnliftIO, withRunInIO) +import UnliftIO.Async (wait, waitEither, withAsync) import UnliftIO.Timeout (timeout) import Morley.Client.Logging (WithClientLog, logDebug) @@ -102,8 +108,8 @@ -- HasTezosRpc functions ---------------- -getBlockHashImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m Text -getBlockHashImpl = retryOnceOnTimeout ... API.getBlockHash API.nodeMethods +getBlockHashImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m BlockHash +getBlockHashImpl = retryOnceOnTimeout ... fmap BlockHash . API.getBlockHash API.nodeMethods getCounterImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Address -> m TezosInt64 getCounterImpl = retryOnceOnTimeout ... API.getCounter API.nodeMethods @@ -119,6 +125,10 @@ getBlockOperationsImpl = retryOnceOnTimeout ... API.getBlockOperations API.nodeMethods +getBlockOperationHashesImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m [[OperationHash]] +getBlockOperationHashesImpl = + retryOnceOnTimeout ... API.getBlockOperationHashes API.nodeMethods + getProtocolParametersImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m ProtocolParameters getProtocolParametersImpl = retryOnceOnTimeout ... API.getProtocolParameters API.nodeMethods @@ -160,6 +170,10 @@ BlockId -> Address -> GetBigMap -> m GetBigMapResult getContractBigMapImpl = retryOnceOnTimeout ... API.getBigMap API.nodeMethods +getScriptSizeAtBlockImpl :: + (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> CalcSize -> m ScriptSize +getScriptSizeAtBlockImpl = retryOnceOnTimeout ... API.getScriptSizeAtBlock API.nodeMethods + getBigMapValueAtBlockImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Natural -> Text -> m Expression @@ -193,6 +207,70 @@ getChainIdImpl :: (RunClient m, MonadCatch m) => m ChainId getChainIdImpl = throwLeft $ parseChainId <$> API.getChainId API.nodeMethods + +waitForOperationImpl :: forall m + . (MonadUnliftIO m, HasTezosRpc m) + => m OperationHash + -> ClientEnv + -> m OperationHash +waitForOperationImpl opHash env = do + finalHead <- getBlockHeader FinalHeadId + hash <- opHash + let limit = 10 -- blocks to wait for + blockout = throwM $ WaitForOperationBlockout limit + handle other = maybe (wait other >>= maybe blockout pure) pure + -- NB: we can't really use race here because even on failure on one direction + -- we still want to check the other. + withAsync (searchForwards limit hash) \fwd -> + withAsync (searchBackwards hash (bhLevel finalHead) HeadId) \bwd -> + waitEither fwd bwd >>= \case + Left res -> handle bwd res + Right res -> handle fwd res + where + monitorHeads :: Word -> (BlockHeader -> m (MonitorHeadsStep OperationHash)) -> m (Maybe OperationHash) + monitorHeads limit test = withRunInIO $ \runInIO -> + withClientM (client runInIO) env (either throwM pure) + where + client runInIO = do + src <- API.monitorHeads + liftIO $ unSourceT src $ go limit runInIO + go 0 _ = const $ pure Nothing + go n runInIO = \case + Stop -> pure Nothing + Error str -> throwM $ WaitForOperationStreamingError (fromString str) + Skip next -> go n runInIO next + Yield a next -> runInIO (test a) >>= \case + MonitorHeadsContinue -> go (n - 1) runInIO next + MonitorHeadsStop res -> pure $ Just res + Effect eff -> eff >>= go n runInIO + searchBackwards :: OperationHash -> Int64 -> BlockId -> m (Maybe OperationHash) + searchBackwards hash stopAtLevel blkHead = do + checkBlock hash blkHead >>= \case + MonitorHeadsContinue -> do + header <- getBlockHeader blkHead + if bhLevel header == stopAtLevel + then pure Nothing + else searchBackwards hash stopAtLevel $ BlockHashId $ bhPredecessor header + MonitorHeadsStop res -> pure $ Just res + searchForwards :: Word -> OperationHash -> m (Maybe OperationHash) + searchForwards limit hash = monitorHeads limit (checkBlock hash . BlockHashId . bhHash) + checkBlock :: OperationHash -> BlockId -> m (MonitorHeadsStep OperationHash) + checkBlock hash blkId = do + opHashes <- concat <$> getBlockOperationHashes blkId + if hash `notElem` opHashes + then pure MonitorHeadsContinue + else do + ops <- concat <$> getBlockOperations blkId + case find (\op -> boHash op == unOperationHash hash) ops of + Just op -> do + for_ (boContents op) + \(OperationRespWithMeta{..}) -> case unOperationMetadata =<< orwmMetadata of + Just res -> case res of + OperationApplied{} -> pass + OperationFailed errs -> throwM $ UnexpectedRunErrors errs + Nothing -> pass + pure $ MonitorHeadsStop hash + Nothing -> error "impossible" ---------------- -- Logging of requests and responses 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 @@ -37,8 +37,7 @@ -- | Run 'MorleyClientM' action within given t'MorleyClientEnv'. Retry action -- in case of invalid counter error. runMorleyClientM :: MorleyClientEnv -> MorleyClientM a -> IO a -runMorleyClientM env client = - runReaderT (unMorleyClientM client) env +runMorleyClientM env client = runReaderT (unMorleyClientM client) env instance HasLog MorleyClientEnv Message MorleyClientM where getLogAction = mceLogAction @@ -50,12 +49,12 @@ case mceSecretKey env of Just sk -> pure . SignatureEd25519 $ Ed25519.sign sk opHash Nothing -> TezosClient.signBytes senderAlias mbPassword opHash - waitForOperation = retryOnceOnTimeout ... TezosClient.waitForOperationInclusion rememberContract = failOnTimeout ... TezosClient.rememberContract importKey = failOnTimeout ... TezosClient.importKey resolveAddressMaybe = retryOnceOnTimeout ... TezosClient.resolveAddressMaybe getAlias = retryOnceOnTimeout ... TezosClient.getAlias getPublicKey = retryOnceOnTimeout ... TezosClient.getPublicKey + getSecretKey = retryOnceOnTimeout ... TezosClient.getSecretKey -- This function doesn't perform any chain related operations with tezos-client, -- so @ECONNRESET@ cannot appear here getTezosClientConfig = do @@ -85,6 +84,8 @@ getBlockHeader = getBlockHeaderImpl getBlockConstants = getBlockConstantsImpl getBlockOperations = getBlockOperationsImpl + getScriptSizeAtBlock = getScriptSizeAtBlockImpl + getBlockOperationHashes = getBlockOperationHashesImpl getProtocolParametersAtBlock = getProtocolParametersImpl runOperationAtBlock = runOperationImpl preApplyOperationsAtBlock = preApplyOperationsImpl @@ -100,3 +101,4 @@ runCodeAtBlock = runCodeImpl getChainId = getChainIdImpl getManagerKeyAtBlock = getManagerKeyImpl + waitForOperation = (asks mceClientEnv >>=) . waitForOperationImpl 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 @@ -8,7 +8,6 @@ , mkLogAction -- * Lens - , mccAliasPrefixL , mccEndpointUrlL , mccTezosClientPathL , mccMbTezosClientDataDirL @@ -31,9 +30,7 @@ -- | Data necessary for morley client initialization. data MorleyClientConfig = MorleyClientConfig - { mccAliasPrefix :: Maybe Text - -- ^ Optional prefix for aliases that will be passed to @tezos-client@. - , mccEndpointUrl :: Maybe BaseUrl + { mccEndpointUrl :: Maybe BaseUrl -- ^ URL of tezos endpoint on which operations are performed , mccTezosClientPath :: FilePath -- ^ Path to @tezos-client@ binary through which operations are @@ -66,8 +63,7 @@ let endpointUrl = fromMaybe tcEndpointUrl mccEndpointUrl tezosClientEnv = TezosClientEnv - { tceAliasPrefix = mccAliasPrefix - , tceEndpointUrl = endpointUrl + { tceEndpointUrl = endpointUrl , tceTezosClientPath = tezosClientPath , tceMbTezosClientDataDir = mccMbTezosClientDataDir } 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 @@ -16,13 +16,11 @@ , logWarning , logError , logException - , logFlush ) where import Colog - (LogAction(..), Message, WithLog, logDebug, logError, logException, logInfo, logWarning) -import System.IO (hFlush) + (LogAction(..), Message, WithLog, logDebug, logError, logException, logFlush, logInfo, logWarning) -- | 'LogAction' with fixed message parameter. type ClientLogAction m = LogAction m Message @@ -31,12 +29,3 @@ -- If we want to use another message type we can change this constraint -- and exported functions, presumably without breaking other code significantly. type WithClientLog env m = WithLog env Message m - --- See , hopefully we won't need it one day. -{- | This action can be used in combination with other actions to flush - a handle every time you log anything. --} -logFlush :: MonadIO m => Handle -> LogAction m a -logFlush handle = LogAction $ const $ liftIO $ hFlush handle -{-# INLINE logFlush #-} -{-# SPECIALIZE logFlush :: Handle -> LogAction IO () #-} 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 @@ -27,8 +27,8 @@ import Morley.Client.RPC.Class (HasTezosRpc(..)) import Morley.Client.RPC.HttpClient (newClientEnv) import Morley.Client.TezosClient.Class (HasTezosClient(..)) -import Morley.Client.TezosClient.Types (AddressOrAlias(..), mkAlias) import Morley.Tezos.Address (Address, mkKeyAddress) +import Morley.Tezos.Address.Alias (AddressOrAlias(..), Alias(..)) import Morley.Tezos.Crypto (SecretKey, sign, toPublic) ---------------- @@ -77,12 +77,7 @@ -- | Run 'MorleyOnlyRpcM' action within given 'MorleyOnlyRpcEnv'. Retry action -- in case of invalid counter error. runMorleyOnlyRpcM :: MorleyOnlyRpcEnv -> MorleyOnlyRpcM a -> IO a -runMorleyOnlyRpcM env action = - runReaderT (unMorleyOnlyRpcM (retryInvalidCounter action)) env - where - retryInvalidCounter a = a `catch` handleInvalidCounterRpc retryAction - where - retryAction = waitBeforeRetry >> retryInvalidCounter action +runMorleyOnlyRpcM env action = runReaderT (unMorleyOnlyRpcM action) env ---------------- -- Exceptions @@ -125,11 +120,6 @@ -- In RPC-only mode we only use unencrypted in-memory passwords. getKeyPassword _ = pure Nothing - -- This method can be implemented if necessary by manually checking whether - -- the operation is confirmed. For now we simply don't wait for confirmation - -- in RPC-only mode. - waitForOperation = \_ -> pass - -- Stateful actions that simply do nothing because there is no persistent state. rememberContract = \_ _ _ -> pass @@ -137,7 +127,7 @@ -- places and with an exception here it's not possible to send transactions. -- So be aware of this and do not rely on this value! -- TODO [#652]: consider using a `Map` instead - getAlias _ = pure (mkAlias "MorleyOnlyRpc") + getAlias _ = pure (Alias "MorleyOnlyRpc") -- Actions that are not supported and simply throw exceptions. genKey _ = throwM $ UnsupportedByOnlyRPC "genKey" @@ -146,6 +136,7 @@ revealKey _ _ = throwM $ UnsupportedByOnlyRPC "revealKey" resolveAddressMaybe _ = throwM $ UnsupportedByOnlyRPC "resolveAddressMaybe" getPublicKey _ = throwM $ UnsupportedByOnlyRPC "getPublicKey" + getSecretKey _ = throwM $ UnsupportedByOnlyRPC "getSecretKey" registerDelegate _ _ = throwM $ UnsupportedByOnlyRPC "registerDelegate" getTezosClientConfig = throwM $ UnsupportedByOnlyRPC "getTezosClientConfig" calcTransferFee _ _ _ _ = throwM $ UnsupportedByOnlyRPC "calcTransferFee" @@ -163,10 +154,12 @@ getBlockHeader = getBlockHeaderImpl getBlockConstants = getBlockConstantsImpl getBlockOperations = getBlockOperationsImpl + getBlockOperationHashes = getBlockOperationHashesImpl getProtocolParametersAtBlock = getProtocolParametersImpl runOperationAtBlock = runOperationImpl preApplyOperationsAtBlock = preApplyOperationsImpl forgeOperationAtBlock = forgeOperationImpl + getScriptSizeAtBlock = getScriptSizeAtBlockImpl injectOperation = injectOperationImpl getContractScriptAtBlock = getContractScriptImpl getContractStorageAtBlock = getContractStorageAtBlockImpl @@ -178,3 +171,4 @@ runCodeAtBlock = runCodeImpl getChainId = getChainIdImpl getManagerKeyAtBlock = getManagerKeyImpl + waitForOperation = (asks moreClientEnv >>=) . waitForOperationImpl 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 @@ -6,6 +6,7 @@ , ClientArgsRaw (..) , OriginateArgs (..) , TransferArgs (..) + , GetScriptSizeArgs (..) , addressOrAliasOption , clientConfigParser , morleyClientInfo @@ -25,20 +26,21 @@ import Options.Applicative.Help.Pretty (Doc, linebreak) import Servant.Client (BaseUrl(..), parseBaseUrl) -import Morley.CLI +import Morley.CLI (addressOrAliasOption, mutezOption, parserInfo, valueOption) import Morley.Client.Init import Morley.Client.RPC.Types (BlockId(HeadId)) -import Morley.Client.TezosClient.Types (AddressOrAlias, AliasHint) import Morley.Michelson.Untyped qualified as U +import Morley.Tezos.Address.Alias (AddressOrAlias, Alias(..)) import Morley.Tezos.Core import Morley.Util.CLI (mkCLOptionParser, mkCommandParser) import Morley.Util.Named data ClientArgs - = ClientArgs MorleyClientConfig Bool ClientArgsRaw + = ClientArgs MorleyClientConfig ClientArgsRaw data ClientArgsRaw = Originate OriginateArgs + | GetScriptSize GetScriptSizeArgs | Transfer TransferArgs | GetBalance AddressOrAlias | GetBlockHeader BlockId @@ -46,13 +48,18 @@ data OriginateArgs = OriginateArgs { oaMbContractFile :: Maybe FilePath - , oaContractName :: AliasHint + , oaContractName :: Alias , oaInitialBalance :: Mutez , oaInitialStorage :: U.Value , oaOriginateFrom :: AddressOrAlias , oaMbFee :: Maybe Mutez } +data GetScriptSizeArgs = GetScriptSizeArgs + { ssScriptFile :: FilePath + , ssStorage :: U.Value + } + data TransferArgs = TransferArgs { taSender :: AddressOrAlias , taDestination :: AddressOrAlias @@ -71,16 +78,11 @@ -- | Parser for the @morley-client@ executable. clientParser :: Opt.Parser ClientArgs -clientParser = ClientArgs <$> clientConfigParser (pure Nothing) <*> enableExtsOption <*> argsRawParser - where - enableExtsOption = Opt.switch $ - long "deprecated-morley-extensions" <> - help "Enable parsing deprecated Morley extensions" +clientParser = ClientArgs <$> clientConfigParser <*> argsRawParser -clientConfigParser :: Opt.Parser (Maybe Text) -> Opt.Parser MorleyClientConfig -clientConfigParser prefixParser = do +clientConfigParser :: Opt.Parser MorleyClientConfig +clientConfigParser = do let mccSecretKey = Nothing - mccAliasPrefix <- prefixParser mccEndpointUrl <- endpointOption mccTezosClientPath <- pathOption mccMbTezosClientDataDir <- dataDirOption @@ -123,14 +125,6 @@ \By default fee will be computed automatically." ) --- | Generic parser to read an option of 'AddressOrAlias' type. -addressOrAliasOption - :: Maybe AddressOrAlias - -> "name" :! String - -> "help" :! String - -> Opt.Parser AddressOrAlias -addressOrAliasOption = mkCLOptionParser - -- | Generic parser to read an option of 'BlockId' type. blockIdOption :: Maybe BlockId @@ -144,6 +138,7 @@ [ originateCmd , transferCmd , getBalanceCmd + , getScriptSizeCmd , getBlockHeaderCmd , getBlockOperationsCmd ] @@ -180,6 +175,10 @@ (#help :! "Id of the block whose operations will be queried.") ) "Get operations contained in a block" + getScriptSizeCmd = + mkCommandParser "compute-script-size" + (GetScriptSize <$> getScriptSizeArgsOption) + "Compute script size" originateArgsOption :: Opt.Parser OriginateArgs originateArgsOption = do @@ -203,14 +202,25 @@ oaMbFee <- feeOption pure $ OriginateArgs {..} +getScriptSizeArgsOption :: Opt.Parser GetScriptSizeArgs +getScriptSizeArgsOption = GetScriptSizeArgs <$> scriptFileOption + <*> valueOption Nothing (#name :! "storage") + (#help :! "Contract storage value") + mbContractFileOption :: Opt.Parser (Maybe FilePath) mbContractFileOption = optional . strOption $ mconcat [ long "contract", metavar "FILEPATH" , help "Path to contract file" ] -contractNameOption :: Opt.Parser AliasHint -contractNameOption = strOption $ mconcat +scriptFileOption :: Opt.Parser FilePath +scriptFileOption = strOption $ mconcat + [ long "script", metavar "FILEPATH" + , help "Path to script file" + ] + +contractNameOption :: Opt.Parser Alias +contractNameOption = fmap Alias . strOption $ mconcat [ long "contract-name" , value "stdin" , help "Alias of originated contract" 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 @@ -6,12 +6,15 @@ module Morley.Client.RPC.API ( NodeMethods (..) , nodeMethods + , monitorHeads ) where import Network.HTTP.Types.Status (Status(..)) import Servant.API - (Capture, Get, JSON, Post, QueryParam, ReqBody, ToHttpApiData(..), (:<|>)(..), (:>)) -import Servant.Client.Core (ResponseF(..), RunClient, clientIn, pattern FailureResponse) + (Capture, Get, JSON, NewlineFraming, Post, QueryParam, ReqBody, SourceIO, StreamGet, + ToHttpApiData(..), (:<|>)(..), (:>)) +import Servant.Client.Core + (ResponseF(..), RunClient, RunStreamingClient, clientIn, pattern FailureResponse) import Morley.Client.RPC.QueryFixedParam import Morley.Client.RPC.Types @@ -44,6 +47,8 @@ Capture "block_id" BlockId :> "operations" :> Get '[JSON] [[BlockOperation]] :<|> + Capture "block_id" BlockId :> "operation_hashes" :> Get '[JSON] [[OperationHash]] :<|> + -- Despite this RPC is deprecated, it is said to be implemented quite sanely, -- and also we were said that it is not going to be removed soon. -- In babylonnet this entrypoint finds big_map with relevant key type and @@ -76,8 +81,15 @@ Capture "block_id" BlockId :> "context" :> "contracts" :> Capture "contract" Address' :> "delegate" :> Get '[JSON] KeyHash :<|> + Capture "block_id" BlockId :> "context" :> "contracts" :> Capture "address" Address' :> "manager_key" + :> Get '[JSON] (Maybe PublicKey) :<|> + -- POST + -- Calculate script size with given storage. + Capture "block_id" BlockId :> "helpers" :> "scripts" :> "script_size" + :> ReqBody '[JSON] CalcSize :> Post '[JSON] ScriptSize :<|> + -- Turn a structured representation of an operation into a -- bytestring that can be submitted to the blockchain. Capture "block_id" BlockId :> "helpers" :> "forge" :> "operations" @@ -93,10 +105,7 @@ -- Run contract with given parameter and storage. Capture "block_id" BlockId :> "helpers" :> "scripts" :> "run_code" - :> ReqBody '[JSON] RunCode :> Post '[JSON] RunCodeResult :<|> - - Capture "block_id" BlockId :> "context" :> "contracts" :> Capture "address" Address' :> "manager_key" - :> Get '[JSON] (Maybe PublicKey) + :> ReqBody '[JSON] RunCode :> Post '[JSON] RunCodeResult ) :<|> @@ -109,6 +118,10 @@ :> ReqBody '[JSON] HexJSONByteString :> Post '[JSON] OperationHash +type StreamingAPI = + "monitor" :> "heads" :> "main" + :> StreamGet NewlineFraming JSON (SourceIO BlockHeader) + nodeAPI :: Proxy NodeAPI nodeAPI = Proxy @@ -121,11 +134,13 @@ , getBlockHeader :: BlockId -> m BlockHeader , getProtocolParameters :: BlockId -> m ProtocolParameters , getBlockOperations :: BlockId -> m [[BlockOperation]] + , getBlockOperationHashes :: BlockId -> m [[OperationHash]] , getBigMap :: BlockId -> Address -> GetBigMap -> m GetBigMapResult , getBigMapValueAtBlock :: BlockId -> Natural -> Text -> m Expression , getBigMapValuesAtBlock :: BlockId -> Natural -> Maybe Natural -> Maybe Natural -> m Expression , getBalance :: BlockId -> Address -> m TezosMutez , getDelegate :: BlockId -> Address -> m (Maybe KeyHash) + , getScriptSizeAtBlock :: BlockId -> CalcSize -> m ScriptSize , forgeOperation :: BlockId -> ForgeOperation -> m HexJSONByteString , runOperation :: BlockId -> RunOperation -> m RunOperationResult , preApplyOperations :: BlockId -> [PreApplyOperation] -> m [RunOperationResult] @@ -135,6 +150,10 @@ , injectOperation :: HexJSONByteString -> m OperationHash } + +monitorHeads :: forall m. (RunStreamingClient m) => m (SourceIO BlockHeader) +monitorHeads = Proxy @StreamingAPI `clientIn` Proxy @m + nodeMethods :: forall m. (MonadCatch m, RunClient m) => NodeMethods m nodeMethods = NodeMethods { getCounter = withAddress' getCounter' @@ -155,12 +174,29 @@ where withAddress' f blockId = f blockId . Address' getDelegate' :: BlockId -> Address' -> m KeyHash - (getBlockHash :<|> getCounter' :<|> getScript' :<|> getStorageAtBlock' :<|> getBlockConstants :<|> - getBlockHeader :<|> getProtocolParameters :<|> getBlockOperations :<|> getBigMap' :<|> - getBigMapValueAtBlock :<|> getBigMapValuesAtBlock :<|> getBalance' :<|> getDelegate' :<|> - forgeOperation :<|> runOperation :<|> preApplyOperations :<|> runCode :<|> getManagerKey') :<|> - getChainId :<|> injectOperation = - nodeAPI `clientIn` (Proxy @m) + (getBlockHash + :<|> getCounter' + :<|> getScript' + :<|> getStorageAtBlock' + :<|> getBlockConstants + :<|> getBlockHeader + :<|> getProtocolParameters + :<|> getBlockOperations + :<|> getBlockOperationHashes + :<|> getBigMap' + :<|> getBigMapValueAtBlock + :<|> getBigMapValuesAtBlock + :<|> getBalance' + :<|> getDelegate' + :<|> getManagerKey' + :<|> getScriptSizeAtBlock + :<|> forgeOperation + :<|> runOperation + :<|> preApplyOperations + :<|> runCode) + :<|> getChainId + :<|> injectOperation + = nodeAPI `clientIn` (Proxy @m) ---------------------------------------------------------------------------- -- Instances and helpers 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 @@ -19,7 +19,7 @@ -- | Type class that provides interaction with tezos node via RPC class (Monad m, MonadCatch m) => HasTezosRpc m where - getBlockHash :: BlockId -> m Text + getBlockHash :: BlockId -> m BlockHash -- ^ Get hash of the given 'BlockId', mostly used to get hash of -- 'HeadId' getCounterAtBlock :: BlockId -> Address -> m TezosInt64 @@ -27,10 +27,14 @@ -- and contract origination. getBlockHeader :: BlockId -> m BlockHeader -- ^ Get the whole header of a block. + getScriptSizeAtBlock :: BlockId -> CalcSize -> m ScriptSize + -- ^ Get the script size at block. getBlockConstants :: BlockId -> m BlockConstants -- ^ Get block constants that are required by other RPC calls. getBlockOperations :: BlockId -> m [[BlockOperation]] -- ^ Get all operations from the block with specified ID. + getBlockOperationHashes :: BlockId -> m [[OperationHash]] + -- ^ Get all operation hashes from the block with specified ID. getProtocolParametersAtBlock :: BlockId -> m ProtocolParameters -- ^ Get protocol parameters that are for limits calculations. runOperationAtBlock :: BlockId -> RunOperation -> m RunOperationResult @@ -75,3 +79,7 @@ getManagerKeyAtBlock :: BlockId -> Address -> m (Maybe PublicKey) -- ^ Get manager key for given address. -- Returns @Nothing@ if this key wasn't revealed. + waitForOperation :: m OperationHash -> m OperationHash + -- ^ Blocks until an operation with the given hash is included into the chain. + -- The first argument is the action that puts the operation on the chain. + -- Returns the hash of the included operation. 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 @@ -7,6 +7,7 @@ , RunCodeErrors (..) , UnexpectedErrors (..) , IncorrectRpcResponse (..) + , WaitForOperationError (..) ) where import Fmt (Buildable(..), blockListF, pretty, (+|), (|+)) @@ -136,4 +137,18 @@ "No operations was run" instance Exception IncorrectRpcResponse where + displayException = pretty + +data WaitForOperationError + = WaitForOperationBlockout Word + | WaitForOperationStreamingError Text + deriving stock Show + +instance Buildable WaitForOperationError where + build = \case + WaitForOperationBlockout n -> "Operation not included after " +| n |+ " blocks" + WaitForOperationStreamingError s -> + "Streaming error received waiting for operation: " +| s |+ "" + +instance Exception WaitForOperationError where displayException = pretty 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 @@ -16,6 +16,7 @@ , getImplicitContractCounter , getContractsParameterTypes , getContractStorage + , getScriptSize , getBigMapValue , getBigMapValues , getHeadBlock @@ -175,6 +176,7 @@ getImplicitContractCounter addr = case addr of KeyAddress _ -> getCounter addr ContractAddress _ -> throwM $ ContractGetCounterAttempt addr + TransactionRollupAddress _ -> throwM $ ContractGetCounterAttempt addr handleStatusCode :: MonadCatch m => Int -> m a -> m a -> m a handleStatusCode code onError action = action `catch` @@ -194,6 +196,7 @@ -> m (Maybe (ContractHash, SomeParamType)) extractParameterType addr = case addr of KeyAddress _ -> return Nothing + TransactionRollupAddress _ -> return Nothing ContractAddress ch -> handleStatusCode 404 (return Nothing) $ do params <- fmap (U.contractParameter) . throwLeft $ @@ -215,7 +218,7 @@ -- | Get hash of the current head block, this head hash is used in other -- RPC calls. -getHeadBlock :: HasTezosRpc m => m Text +getHeadBlock :: HasTezosRpc m => m BlockHash getHeadBlock = getBlockHash HeadId -- | 'getCounterAtBlock' applied to the head block. @@ -249,6 +252,10 @@ -- | 'getBalanceAtBlock' applied to the head block. getBalance :: HasTezosRpc m => Address -> m Mutez getBalance = getBalanceAtBlock HeadId + +-- | 'getScriptSizeAtBlock' applied to the head block. +getScriptSize :: HasTezosRpc m => CalcSize -> m ScriptSize +getScriptSize = getScriptSizeAtBlock HeadId -- | 'getDelegateAtBlock' applied to the head block. getDelegate :: HasTezosRpc m => Address -> m (Maybe KeyHash) 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 @@ -5,7 +5,9 @@ ( QueryFixedParam ) where -import Servant.API (ToHttpApiData(toQueryParam), type (:>)) +import Data.ByteString.Builder qualified as Builder +import Data.ByteString.Lazy qualified as LBS +import Servant.API (ToHttpApiData(..), type (:>)) import Servant.Client.Core (HasClient(..), appendToQueryString) import Morley.Util.TypeLits (KnownSymbol, Symbol, symbolValT') @@ -16,11 +18,16 @@ instance (KnownSymbol sym, KnownSymbol val, HasClient m api) => HasClient m (QueryFixedParam sym val :> api) where + type Client m (QueryFixedParam sym val :> api) = Client m api + clientWithRoute pm Proxy req = clientWithRoute pm (Proxy :: Proxy api) - $ appendToQueryString pname (Just $ toQueryParam pval) req + $ appendToQueryString pname (Just $ encodeQueryParamValue pval) req where pname = symbolValT' @sym pval = symbolValT' @val + -- Lifted from the unreleased https://github.com/haskell-servant/servant/pull/1549 + encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl 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 @@ -25,12 +25,16 @@ , CommonOperationData (..) , ForgeOperation (..) , GetBigMap (..) + , CalcSize(..) + , ScriptSize(..) , GetBigMapResult (..) , InternalOperation (..) , OperationContent (..) , OperationHash (..) - , OperationInput (..) + , OperationInput , OperationResp (..) + , OperationRespWithMeta (..) + , OperationMetadata (..) , OperationResult (..) , OriginationOperation (..) , OriginationScript (..) @@ -46,7 +50,8 @@ , RunOperationResult (..) , RPCInput , TransactionOperation (..) - , combineResults + , WithCommonOperationData (..) + , MonitorHeadsStep(..) , mkCommonOperationData -- * Errors @@ -72,13 +77,14 @@ , _GasExhaustedOperation -- * Lenses - , oiCommonDataL + , wcoCommonDataL ) where -import Control.Lens (makeLensesFor, makePrisms) +import Control.Lens (makePrisms) import Data.Aeson - (FromJSON(..), Object, ToJSON(..), Value(..), object, omitNothingFields, withObject, (.!=), (.:), - (.:?), (.=)) + (FromJSON(..), Key, Object, ToJSON(..), Value(..), object, omitNothingFields, withObject, (.!=), + (.:), (.:?), (.=)) +import Data.Aeson.Key qualified as Key (toText) import Data.Aeson.TH (deriveFromJSON, deriveJSON, deriveToJSON) import Data.Default (Default(..)) import Data.Fixed (Milli) @@ -92,8 +98,8 @@ import Morley.Client.RPC.Aeson (morleyClientAesonOptions) import Morley.Client.Types import Morley.Micheline - (Expression(..), MichelinePrimAp(..), MichelinePrimitive(..), StringEncode(..), TezosInt64, - TezosMutez(..), TezosNat) + (Expression, MichelinePrimAp(..), MichelinePrimitive(..), StringEncode(..), TezosInt64, + TezosMutez(..), TezosNat, expressionPrim) import Morley.Tezos.Address (Address) import Morley.Tezos.Core (Mutez, tz, zeroMutez) import Morley.Tezos.Crypto (PublicKey, Signature, decodeBase58CheckWithPrefix, formatSignature) @@ -113,45 +119,19 @@ 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 +type OperationInput = WithCommonOperationData (OperationInfo RPCInput) data ForgeOperation = ForgeOperation - { foBranch :: Text + { foBranch :: BlockHash , foContents :: NonEmpty OperationInput } -instance ToJSON ForgeOperation where - toJSON ForgeOperation{..} = object - [ "branch" .= toString foBranch - , "contents" .= foContents - ] - data RunOperationInternal = RunOperationInternal - { roiBranch :: Text + { roiBranch :: BlockHash , roiContents :: NonEmpty OperationInput , roiSignature :: Signature } -instance ToJSON RunOperationInternal where - toJSON RunOperationInternal{..} = object - [ "branch" .= toString roiBranch - , "contents" .= roiContents - , "signature" .= roiSignature - ] - data RunOperation = RunOperation { roOperation :: RunOperationInternal , roChainId :: Text @@ -159,19 +139,11 @@ data PreApplyOperation = PreApplyOperation { paoProtocol :: Text - , paoBranch :: Text + , paoBranch :: BlockHash , paoContents :: NonEmpty OperationInput , paoSignature :: Signature } -instance ToJSON PreApplyOperation where - toJSON PreApplyOperation{..} = object - [ "branch" .= toString paoBranch - , "contents" .= paoContents - , "protocol" .= toString paoProtocol - , "signature" .= formatSignature paoSignature - ] - data RunOperationResult = RunOperationResult { rrOperationContents :: NonEmpty OperationContent } @@ -233,7 +205,7 @@ } newtype BlockHash = BlockHash { unBlockHash :: Text } - deriving newtype (ToJSON, FromJSON) + deriving newtype (Eq, Ord, Show, Buildable, ToJSON, FromJSON, ToHttpApiData) data FeeConstants = FeeConstants { fcBase :: Mutez @@ -262,7 +234,7 @@ -- ^ Identifier referring to the genesis block. | LevelId Natural -- ^ Identifier referring to a block by its level. - | BlockHashId Text + | BlockHashId BlockHash -- ^ Idenfitier referring to a block by its hash in Base58Check notation. | AtDepthId Natural -- ^ Identifier of a block at specific depth relative to @head@. @@ -296,7 +268,7 @@ | Right lvl <- readEither t = Just (LevelId lvl) | Just depthTxt <- "head~" `T.stripPrefix` t , Right depth <- readEither depthTxt = Just (AtDepthId depth) - | Right _ <- decodeBase58CheckWithPrefix blockPrefix t = Just (BlockHashId t) + | Right _ <- decodeBase58CheckWithPrefix blockPrefix t = Just (BlockHashId (BlockHash t)) | otherwise = Nothing -- A magic prefix used by Tezos for block hashes @@ -363,6 +335,7 @@ | BalanceTooLow ("balance" :! Mutez) ("required" :! Mutez) | PreviouslyRevealedKey Address | NonExistingContract Address + | InvalidB58Check Text deriving stock Show instance FromJSON RunError where @@ -417,6 +390,8 @@ PreviouslyRevealedKey <$> o .: "contract" x | "non_existing_contract" `isSuffixOf` x -> NonExistingContract <$> o .: "contract" + x | "invalid_b58check" `isSuffixOf` x -> + InvalidB58Check <$> o .: "input" _ -> fail ("unknown id: " <> id') instance Buildable RunError where @@ -474,6 +449,8 @@ "Key for " +| addr |+ " has already been revealed" NonExistingContract addr -> "Contract is not registered: " +| addr |+ "" + InvalidB58Check input -> + "Failed to read a valid b58check_encoding data from \"" +| input |+ "\"" -- | Errors that are sent as part of an "Internal Server Error" -- response (HTTP code 500). @@ -518,11 +495,11 @@ "failure" -> Failure <$> o .: "msg" x -> fail ("unknown id: " <> x) where - parseCounter :: Object -> Text -> Parser Word + parseCounter :: Object -> Key -> Parser Word parseCounter o fieldName = do fieldValue <- o .: fieldName let mCounter = fromIntegralMaybe fieldValue - maybe (fail $ mkErrorMsg fieldName fieldValue) pure mCounter + maybe (fail $ mkErrorMsg (Key.toText fieldName) fieldValue) pure mCounter mkErrorMsg :: Text -> TezosInt64 -> String mkErrorMsg fieldName fieldValue = toString $ unwords @@ -556,17 +533,6 @@ instance Monoid AppliedResult where mempty = AppliedResult 0 0 0 [] 0 -combineResults :: OperationResult -> OperationResult -> OperationResult -combineResults - (OperationApplied res1) (OperationApplied res2) = - OperationApplied $ res1 <> res2 -combineResults (OperationApplied _) (OperationFailed e) = - OperationFailed e -combineResults (OperationFailed e) (OperationApplied _) = - OperationFailed e -combineResults (OperationFailed e1) (OperationFailed e2) = - OperationFailed $ e1 <> e2 - instance FromJSON OperationResult where parseJSON = withObject "operation_costs" $ \o -> do status <- o .: "status" @@ -598,7 +564,7 @@ defaultParametersInternal :: ParametersInternal defaultParametersInternal = ParametersInternal { piEntrypoint = "default" - , piValue = ExpressionPrim MichelinePrimAp + , piValue = expressionPrim MichelinePrimAp { mpaPrim = MichelinePrimitive "Unit" , mpaArgs = [] , mpaAnnots = [] @@ -649,6 +615,19 @@ codStorageLimit <- o .: "storage_limit" pure CommonOperationData {..} +-- | Some operation data accompanied with common data. +data WithCommonOperationData a = WithCommonOperationData + { wcoCommon :: CommonOperationData + , wcoCustom :: a + } + +instance ToJSONObject a => ToJSON (WithCommonOperationData a) where + toJSON (WithCommonOperationData common custom) = + toJSON common `mergeObjects` toJSON custom + +instance FromJSON a => FromJSON (WithCommonOperationData a) where + parseJSON v = WithCommonOperationData <$> parseJSON v <*> parseJSON v + -- | All the data needed to perform a transaction through -- Tezos RPC interface. -- For additional information, please refer to RPC documentation @@ -659,21 +638,6 @@ , toParameters :: ParametersInternal } -instance ToJSON TransactionOperation where - toJSON TransactionOperation{..} = object $ - [ "kind" .= String "transaction" - , "amount" .= toAmount - , "destination" .= toDestination - , "parameters" .= toParameters - ] - -instance FromJSON TransactionOperation where - parseJSON = withObject "TransactionOperation" $ \obj -> do - toAmount <- obj .: "amount" - toDestination <- obj .: "destination" - toParameters <- fromMaybe defaultParametersInternal <$> obj .:? "parameters" - pure TransactionOperation {..} - data OriginationScript = OriginationScript { osCode :: Expression , osStorage :: Expression @@ -686,13 +650,6 @@ , ooScript :: OriginationScript } -instance ToJSON OriginationOperation where - toJSON OriginationOperation{..} = object $ - [ "kind" .= String "origination" - , "balance" .= ooBalance - , "script" .= ooScript - ] - -- | All the data needed to perform key revealing -- through Tezos RPC interface data RevealOperation = RevealOperation @@ -704,27 +661,32 @@ [ "kind" .= String "reveal" , "public_key" .= roPublicKey ] +instance ToJSONObject RevealOperation -- | @$operation@ in Tezos docs. data BlockOperation = BlockOperation { boHash :: Text - , boContents :: [OperationResp] + , boContents :: [OperationRespWithMeta] } -- | Contents of an operation that can appear in RPC responses. data OperationResp - = TransactionOpResp TransactionOperation + = TransactionOpResp (WithCommonOperationData TransactionOperation) -- ^ Operation with kind @transaction@. | OtherOpResp -- ^ Operation with kind that we don't support yet (but need to parse to something). -instance FromJSON OperationResp where - parseJSON = withObject "OperationResp" $ \obj -> do - kind :: Text <- obj .: "kind" - case kind of - "transaction" -> TransactionOpResp <$> parseJSON (Object obj) - _ -> pure OtherOpResp +data OperationRespWithMeta = OperationRespWithMeta + { orwmResponse :: OperationResp + , orwmMetadata :: Maybe OperationMetadata + } +newtype OperationMetadata = OperationMetadata { unOperationMetadata :: Maybe OperationResult } + +instance FromJSON OperationMetadata where + parseJSON = withObject "operationMetadata" $ \o -> + OperationMetadata <$> o .:? "operation_result" + data GetBigMap = GetBigMap { bmKey :: Expression , bmType :: Expression @@ -742,6 +704,8 @@ , rcAmount :: TezosMutez , rcBalance :: TezosMutez , rcChainId :: Text + , rcNow :: Maybe TezosNat + , rcLevel :: Maybe TezosNat , rcSource :: Maybe Address , rcPayer :: Maybe Address } @@ -754,13 +718,84 @@ { rcrStorage :: Expression } +newtype ScriptSize = ScriptSize { ssScriptSize :: Natural } + +data CalcSize = CalcSize + { csProgram :: Expression + , csStorage :: Expression + , csGas :: TezosInt64 + , csLegacy :: Bool + } + +data MonitorHeadsStep a = MonitorHeadsStop a | MonitorHeadsContinue + deriveJSON morleyClientAesonOptions ''ParametersInternal + +instance ToJSON TransactionOperation where + toJSON TransactionOperation{..} = object $ + [ "kind" .= String "transaction" + , "amount" .= toAmount + , "destination" .= toDestination + , "parameters" .= toParameters + ] +instance ToJSONObject TransactionOperation + +instance FromJSON TransactionOperation where + parseJSON = withObject "TransactionOperation" $ \obj -> do + toAmount <- obj .: "amount" + toDestination <- obj .: "destination" + toParameters <- fromMaybe defaultParametersInternal <$> obj .:? "parameters" + pure TransactionOperation {..} + +instance FromJSON OperationResp where + parseJSON = withObject "OperationResp" $ \obj -> do + kind :: Text <- obj .: "kind" + case kind of + "transaction" -> TransactionOpResp <$> parseJSON (Object obj) + _ -> pure OtherOpResp + +instance FromJSON OperationRespWithMeta where + parseJSON = withObject "OperationRespWithMeta" $ \obj -> do + OperationRespWithMeta <$> parseJSON (Object obj) <*> obj .:? "metadata" + deriveToJSON morleyClientAesonOptions ''OriginationScript + +instance ToJSON OriginationOperation where + toJSON OriginationOperation{..} = object $ + [ "kind" .= String "origination" + , "balance" .= ooBalance + , "script" .= ooScript + ] +instance ToJSONObject OriginationOperation + +instance ToJSON ForgeOperation where + toJSON ForgeOperation{..} = object + [ "branch" .= unBlockHash foBranch + , "contents" .= foContents + ] + +instance ToJSON RunOperationInternal where + toJSON RunOperationInternal{..} = object + [ "branch" .= unBlockHash roiBranch + , "contents" .= roiContents + , "signature" .= roiSignature + ] + +instance ToJSON PreApplyOperation where + toJSON PreApplyOperation{..} = object + [ "branch" .= unBlockHash paoBranch + , "contents" .= paoContents + , "protocol" .= paoProtocol + , "signature" .= formatSignature paoSignature + ] + deriveToJSON morleyClientAesonOptions ''RunOperation deriveToJSON morleyClientAesonOptions ''GetBigMap +deriveToJSON morleyClientAesonOptions ''CalcSize deriveToJSON morleyClientAesonOptions{omitNothingFields = True} ''RunCode -deriveFromJSON morleyClientAesonOptions ''BlockConstants deriveFromJSON morleyClientAesonOptions ''BlockHeaderNoHash +deriveFromJSON morleyClientAesonOptions ''ScriptSize +deriveFromJSON morleyClientAesonOptions ''BlockConstants deriveJSON morleyClientAesonOptions ''BlockHeader deriveFromJSON morleyClientAesonOptions ''ProtocolParameters deriveFromJSON morleyClientAesonOptions ''BlockOperation @@ -771,4 +806,7 @@ parseJSON v = maybe GetBigMapNotFound GetBigMapResult <$> parseJSON v makePrisms ''RunError -makeLensesFor [("oiCommonData", "oiCommonDataL")] ''OperationInput + +wcoCommonDataL :: Lens' (WithCommonOperationData a) CommonOperationData +wcoCommonDataL = \f (WithCommonOperationData com cust) -> + (`WithCommonOperationData` cust) <$> f com 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 @@ -10,34 +10,32 @@ import Data.ByteArray (ScrubbedBytes) -import Morley.Client.RPC.Types import Morley.Client.TezosClient.Types import Morley.Micheline import Morley.Michelson.Typed.Scope import Morley.Tezos.Address +import Morley.Tezos.Address.Alias (AddressOrAlias, Alias) import Morley.Tezos.Crypto -- | Type class that provides interaction with @tezos-client@ binary class (Monad m) => HasTezosClient m where signBytes :: AddressOrAlias -> Maybe ScrubbedBytes -> ByteString -> m Signature -- ^ Sign an operation with @tezos-client@. - genKey :: AliasOrAliasHint -> m Address + genKey :: Alias -> m Address -- ^ Generate a secret key and store it with given alias. -- If a key with this alias already exists, the corresponding address -- will be returned and no state will be changed. - genFreshKey :: AliasOrAliasHint -> m Address + genFreshKey :: Alias -> m Address -- ^ Generate a secret key and store it with given alias. -- Unlike 'genKey' this function overwrites -- the existing key when given alias is already stored. revealKey :: Alias -> Maybe ScrubbedBytes -> m () -- ^ Reveal public key associated with given implicit account. - waitForOperation :: OperationHash -> m () - -- ^ Wait until operation known by some hash is included into the chain. - rememberContract :: Bool -> Address -> AliasOrAliasHint -> m () + rememberContract :: Bool -> Address -> Alias -> m () -- ^ 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 Alias + importKey :: Bool -> Alias -> 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. @@ -53,7 +51,9 @@ getPublicKey :: AddressOrAlias -> m PublicKey -- ^ Get public key for given address. Public keys are often used when interacting -- with the multising contracts - registerDelegate :: AliasOrAliasHint -> Maybe ScrubbedBytes -> m () + getSecretKey :: AddressOrAlias -> m SecretKey + -- ^ Get secret key for given address. + registerDelegate :: Alias -> Maybe ScrubbedBytes -> m () -- ^ Register a given address as delegate getTezosClientConfig :: m TezosClientConfig -- ^ Retrieve the current @tezos-client@ config. 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 @@ -8,7 +8,6 @@ -- * @tezos-client@ api , signBytes - , waitForOperationInclusion , rememberContract , importKey , genKey @@ -18,6 +17,7 @@ , resolveAddress , getAlias , getPublicKey + , getSecretKey , getTezosClientConfig , calcTransferFee , calcOriginationFee @@ -28,8 +28,6 @@ -- * Internals , callTezosClient , callTezosClientStrict - , prefixName - , prefixNameM ) where import Unsafe qualified ((!!)) @@ -56,6 +54,7 @@ import Morley.Micheline import Morley.Michelson.Typed.Scope import Morley.Tezos.Address +import Morley.Tezos.Address.Alias (AddressOrAlias(..), Alias(..)) import Morley.Tezos.Crypto import Morley.Util.Peano import Morley.Util.SizedList.Types @@ -212,10 +211,9 @@ genKey :: ( MonadThrow m, MonadCatch m, WithClientLog env m, HasTezosClientEnv env, MonadIO m , Class.HasTezosClient m) - => AliasOrAliasHint + => Alias -> m Address -genKey originatorAlias = do - name <- prefixNameM originatorAlias +genKey name = do let isAlreadyExistsError :: Text -> Bool -- We can do a bit better here using more complex parsing if necessary. @@ -234,10 +232,9 @@ genFreshKey :: ( MonadThrow m, MonadCatch m, WithClientLog env m, HasTezosClientEnv env, MonadIO m , Class.HasTezosClient m) - => AliasOrAliasHint + => Alias -> m Address -genFreshKey originatorAlias = do - name <- prefixNameM originatorAlias +genFreshKey name = do let isNoAliasError :: Text -> Bool -- We can do a bit better here using more complex parsing if necessary. @@ -279,11 +276,10 @@ -- | Register alias as delegate registerDelegate :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m) - => AliasOrAliasHint + => Alias -> Maybe ScrubbedBytes -> m () -registerDelegate addressOrAliasHint mbPassword = do - alias <- prefixNameM addressOrAliasHint +registerDelegate alias mbPassword = do logDebug $ "Registering " +| alias |+ " as delegate" let emptyImplicitContract = T.isInfixOf "Empty implicit contract" @@ -308,7 +304,7 @@ AddressAlias originatorName -> do logDebug $ "Resolving " +| originatorName |+ "" output <- callTezosClientStrict ["list", "known", "contracts"] MockupMode Nothing - let parse = T.stripPrefix (unsafeGetAliasText originatorName <> ": ") + let parse = T.stripPrefix (unAlias originatorName <> ": ") liftIO case safeHead . mapMaybe parse . lines $ output of Nothing -> pure Nothing Just addrText -> @@ -328,7 +324,7 @@ let parse = T.stripSuffix (": " <> pretty senderAddress) liftIO case safeHead . mapMaybe parse . lines $ output of Nothing -> throwM $ UnknownAddress senderAddress - Just alias -> pure (mkAlias alias) + Just alias -> pure (Alias alias) -- | Return 'PublicKey' corresponding to given 'AddressOrAlias'. getPublicKey @@ -348,19 +344,23 @@ parsePublicKey pkText _ -> throwM $ TezosClientUnexpectedOutputFormat output --- | This function blocks until operation with given hash is included into blockchain. -waitForOperationInclusion +-- | Return 'SecretKey' corresponding to given 'AddressOrAlias'. +getSecretKey :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m) - => OperationHash - -> m () -waitForOperationInclusion op = void do - logDebug $ "Waiting for operation " +| op |+ " to be included..." - callTezosClient errHandler - ["wait", "for", toCmdArg op, "to", "be", "included"] ClientMode Nothing - where - errHandler _ errOutput = - False <$ when ("Invalid operation hash:" `T.isInfixOf` errOutput) - (throwM $ InvalidOperationHash op) + => AddressOrAlias + -> m SecretKey +getSecretKey addrOrAlias = do + alias <- getAlias addrOrAlias + logDebug $ "Getting " +| alias |+ " secret key" + output <- callTezosClientStrict ["show", "address", toCmdArg alias, "--show-secret"] MockupMode Nothing + liftIO case lines output of + _ : _ : [rawSK] -> do + skText <- maybe + (throwM $ TezosClientUnexpectedOutputFormat rawSK) pure + (T.stripPrefix "Secret Key: " rawSK) + either (throwM . TezosClientCryptoParseError skText) pure $ + parseSecretKey skText + _ -> throwM $ TezosClientUnexpectedOutputFormat output -- | Save a contract with given address and alias. -- If @replaceExisting@ is @False@ and a contract with given alias @@ -369,10 +369,9 @@ :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m) => Bool -> Address - -> AliasOrAliasHint + -> Alias -> m () -rememberContract replaceExisting contractAddress newAlias = do - name <- prefixNameM newAlias +rememberContract replaceExisting contractAddress name = do let isAlreadyExistsError = T.isInfixOf "already exists" errHandler _ errOut = pure (isAlreadyExistsError errOut) @@ -386,11 +385,10 @@ importKey :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m) => Bool - -> AliasOrAliasHint + -> Alias -> SecretKey -> m Alias -importKey replaceExisting alias key = do - name <- prefixNameM alias +importKey replaceExisting name key = do let isAlreadyExistsError = T.isInfixOf "already exists" errHandler _ errOut = pure (isAlreadyExistsError errOut) @@ -630,22 +628,6 @@ errorMsg = "ERROR!! There was an error in executing `" <> toText fp <> "` program. Is the \ \ executable available in PATH ?" - -prefixName :: Maybe Text -> AliasOrAliasHint -> Alias -prefixName _ (AnAlias x) = x -prefixName mPrefix (AnAliasHint (unsafeGetAliasHintText -> hint)) = - mkAlias $ case mPrefix of - Just prefix -> prefix <> "." <> hint - Nothing -> hint - --- | Prefix an alias with the value available in any 'HasTezosClientEnv'. -prefixNameM - :: (HasTezosClientEnv env, MonadReader env m) - => AliasOrAliasHint - -> m Alias -prefixNameM alias = do - prefix <- tceAliasPrefix <$> view tezosClientEnvL - pure $ prefixName prefix alias -- | Return 'Address' corresponding to given 'AddressOrAlias'. resolveAddress 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 @@ -5,10 +5,6 @@ module Morley.Client.TezosClient.Types ( CmdArg (..) - , Alias - , AliasHint - , AliasOrAliasHint (..) - , AddressOrAlias (..) , addressResolved , CalcOriginationFeeData (..) , CalcTransferFeeData (..) @@ -17,16 +13,7 @@ , HasTezosClientEnv (..) , SecretKeyEncryption (..) - -- * Unsafe coercions - , unsafeCoerceAliasHintToAlias - , unsafeCoerceAliasToAliasHint - , unsafeGetAliasText - , unsafeGetAliasHintText - , mkAlias - , mkAliasHint - -- * Lens - , tceAliasPrefixL , tceEndpointUrlL , tceTezosClientPathL , tceMbTezosClientDataDirL @@ -34,11 +21,9 @@ import Data.Aeson (FromJSON(..), KeyValue(..), ToJSON(..), object, withObject, (.:)) import Data.ByteArray (ScrubbedBytes) -import Data.Coerce (coerce) import Data.Fixed (E6, Fixed(..)) import Fmt (Buildable(..), pretty) import Morley.Util.Lens (makeLensesWith, postfixLFields) -import Options.Applicative qualified as Opt import Servant.Client (BaseUrl(..), showBaseUrl) import Text.Hex (encodeHex) @@ -49,10 +34,10 @@ import Morley.Michelson.Printer import Morley.Michelson.Typed (Contract, EpName, Value) import Morley.Michelson.Typed qualified as T -import Morley.Tezos.Address (Address, parseAddress) +import Morley.Tezos.Address (Address) +import Morley.Tezos.Address.Alias (AddressOrAlias(..), Alias) import Morley.Tezos.Core import Morley.Tezos.Crypto -import Morley.Util.CLI (HasCLReader(..)) -- | An object that can be put as argument to a tezos-client command-line call. class CmdArg a where @@ -92,84 +77,14 @@ instance CmdArg OperationHash --- | @tezos-client@ can associate addresses with textual aliases. --- This type denotes such an alias. -newtype Alias = Alias - { unsafeGetAliasText :: Text - -- ^ Unsafely extract 'Text' from 'Alias'. Do NOT use the result with - -- 'mkAliasHint'. - } - deriving stock (Show, Eq, Ord) - deriving newtype (Buildable, CmdArg) - --- | A hint for constructing an alias when generating an address or --- remembering a contract. --- --- Resulting 'Alias' most likely will differ from this as we tend to prefix --- aliases, but a user should be able to recognize your alias visually. --- For instance, passing @"alice"@ as a hint may result into @"myTest.alice"@ --- alias being created. -newtype AliasHint = AliasHint - { unsafeGetAliasHintText :: Text - -- ^ Unsafely extract 'Text' from 'AliasHint'. Do NOT use the result with - -- 'mkAlias'. - } - deriving stock (Show) - deriving newtype (IsString, Buildable, Semigroup, Monoid) - --- | Coerce 'Alias' to 'AliasHint'. Unless you know for a fact that prefix is empty, --- this is unsafe. -unsafeCoerceAliasToAliasHint :: Alias -> AliasHint -unsafeCoerceAliasToAliasHint = coerce - --- | Coerce 'AliasHint' to 'Alias'. Unless you know for a fact that prefix is empty, --- this is unsafe. -unsafeCoerceAliasHintToAlias :: AliasHint -> Alias -unsafeCoerceAliasHintToAlias = coerce - --- | Make 'Alias' from 'Text' -mkAlias :: Text -> Alias -mkAlias = Alias - --- | Make 'AliasHint' from 'Text' -mkAliasHint :: Text -> AliasHint -mkAliasHint = AliasHint - --- | Either an 'Alias', or an 'AliasHint'. The difference is that 'AliasHint' needs to be --- prefixed (if alias prefix is non-empty), while 'Alias' doesn't. -data AliasOrAliasHint - = AnAlias Alias - | AnAliasHint AliasHint - deriving stock (Show) - --- | Representation of an address that @tezos-client@ uses. It can be --- an address itself or a textual alias. -data AddressOrAlias - = AddressResolved Address - -- ^ Address itself, can be used as is. - | AddressAlias Alias - -- ^ Address alias, should be resolved by @tezos-client@. - deriving stock (Show, Eq, Ord) +instance CmdArg Alias where instance CmdArg AddressOrAlias where -instance HasCLReader AddressOrAlias where - getReader = - Opt.str <&> \addrOrAlias -> - case parseAddress addrOrAlias of - Right addr -> AddressResolved addr - Left _ -> AddressAlias (Alias addrOrAlias) - getMetavar = "ADDRESS OR ALIAS" - -- | Creates an 'AddressOrAlias' with the given address. addressResolved :: ToAddress addr => addr -> AddressOrAlias addressResolved = AddressResolved . toAddress -instance Buildable AddressOrAlias where - build = \case - AddressResolved addr -> build addr - AddressAlias alias -> build alias - -- | Representation of address secret key encryption type data SecretKeyEncryption = UnencryptedKey @@ -189,15 +104,7 @@ -- | Runtime environment for @tezos-client@ bindings. data TezosClientEnv = TezosClientEnv - { tceAliasPrefix :: Maybe Text - -- ^ Optional prefix for aliases that will be passed to @tezos-client@. - -- If you call some function and pass @foo@ 'Alias' to it when the prefix - -- is provided, it will be prepened to @foo@. So @prefix.foo@ will be passed - -- to @tezos-client@. Note that the prefix will be only applied in functions - -- such as 'Morley.Client.TezosClient.Class.genKey' and - -- 'Morley.Client.TezosClient.Class.rememberContract' that work directly - -- with @tezos-client@ contract cache and add addresses to it. - , tceEndpointUrl :: BaseUrl + { tceEndpointUrl :: BaseUrl -- ^ URL of tezos node on which operations are performed. , tceTezosClientPath :: FilePath -- ^ Path to tezos client binary through which operations are diff --git a/src/Morley/Client/Types.hs b/src/Morley/Client/Types.hs --- a/src/Morley/Client/Types.hs +++ b/src/Morley/Client/Types.hs @@ -2,7 +2,8 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA module Morley.Client.Types - ( OperationInfoDescriptor (..) + ( ToJSONObject + , OperationInfoDescriptor (..) , OperationInfo (..) , _OpTransfer , _OpOriginate @@ -10,7 +11,11 @@ ) where import Control.Lens (makePrisms) +import Data.Aeson (ToJSON(..)) +-- | Designates types whose 'ToJSON' instance produces only 'Data.Aeson.Object's. +class ToJSON a => ToJSONObject a + class OperationInfoDescriptor (i :: Type) where type family TransferInfo i :: Type type family OriginationInfo i :: Type @@ -20,5 +25,16 @@ = OpTransfer (TransferInfo i) | OpOriginate (OriginationInfo i) | OpReveal (RevealInfo i) + +-- Requiring 'ToJSONObject' in superclass as those different types of operation +-- must be distinguishable and that is usually done by a special field +instance + Each '[ToJSONObject] [TransferInfo i, OriginationInfo i, RevealInfo i] => + ToJSON (OperationInfo i) where + toJSON = \case + OpTransfer op -> toJSON op + OpOriginate op -> toJSON op + OpReveal op -> toJSON op +instance ToJSON (OperationInfo i) => ToJSONObject (OperationInfo 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 @@ -13,6 +13,8 @@ , withAmount , withSender , withSource + , withLevel + , withNow -- * @tezos-client@ password-related helpers , scrubbedBytesToString @@ -37,7 +39,7 @@ import Morley.Michelson.Untyped (InternalByteString(..), Value, Value'(..)) import Morley.Michelson.Untyped.Entrypoints (EpName(..), pattern DefEpName) import Morley.Tezos.Address -import Morley.Tezos.Core (Mutez, zeroMutez) +import Morley.Tezos.Core (Mutez, Timestamp(..), zeroMutez) import Morley.Util.Exception as E (throwLeft) -- | Sets the environment variable for disabling tezos-client @@ -75,6 +77,8 @@ , rcpParameter :: MaybeRPC (T.Value cp) , rcpStorage :: MaybeRPC (T.Value st) , rcpBalance :: Mutez + , rcpNow :: Maybe Timestamp + , rcpLevel :: Maybe Natural , rcpAmount :: Mutez , rcpSender :: Maybe Address , rcpSource :: Maybe Address @@ -93,6 +97,8 @@ , rcpStorage = st , rcpBalance = zeroMutez , rcpAmount = zeroMutez + , rcpNow = Nothing + , rcpLevel = Nothing , rcpSender = Nothing , rcpSource = Nothing } @@ -102,6 +108,8 @@ , ("rcpAmount", "withAmount") , ("rcpSender", "withSender") , ("rcpSource", "withSource") + , ("rcpLevel", "withLevel") + , ("rcpNow", "withNow") ] ''RunContractParameters @@ -119,6 +127,8 @@ , rcAmount = TezosMutez rcpAmount , rcBalance = TezosMutez rcpBalance , rcChainId = bcChainId headConstants + , rcNow = rcpNow <&> StringEncode . round . unTimestamp + , rcLevel = StringEncode <$> rcpLevel -- 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. diff --git a/test/Test/BigMapGet.hs b/test/Test/BigMapGet.hs --- a/test/Test/BigMapGet.hs +++ b/test/Test/BigMapGet.hs @@ -5,7 +5,7 @@ ( test_BigMapGetUnit ) where -import Data.Map (fromList, lookup) +import Data.Map (lookup) import Test.HUnit (Assertion, assertFailure) import Test.Hspec.Expectations (shouldThrow) import Test.Tasty (TestTree, testGroup) @@ -18,9 +18,9 @@ import Morley.Client.RPC.Getters import Morley.Client.RPC.Types -import Morley.Client.TezosClient.Types (AddressOrAlias(..)) import Morley.Michelson.Runtime.GState (genesisAddress1, genesisAddress2, genesisAddress3) import Morley.Michelson.Typed +import Morley.Tezos.Address.Alias (AddressOrAlias(..)) import Test.Util import TestM diff --git a/test/Test/Errors.hs b/test/Test/Errors.hs new file mode 100644 --- /dev/null +++ b/test/Test/Errors.hs @@ -0,0 +1,59 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Errors + ( test_handleOperationResult + ) where + +import Debug qualified + +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +import Morley.Client.Action.Common +import Morley.Client.RPC.Error +import Morley.Client.RPC.Types +import Morley.Tezos.Core +import Morley.Util.Named + +deriving stock instance Eq RunError + +test_handleOperationResult :: TestTree +test_handleOperationResult = testCase "getAppliedResults #709 regression test" do + let res = RunOperationResult + { rrOperationContents = + OperationContent + (RunMetadata + { rmOperationResult = OperationFailed [] + , rmInternalOperationResults = + [ InternalOperation {unInternalOperation = OperationFailed []} + , InternalOperation {unInternalOperation = OperationFailed []} + ] + }) + :| + [ OperationContent + (RunMetadata + { rmOperationResult = OperationFailed + [ CantPayStorageFee + , BalanceTooLow (#balance :! [tz|149.38m|]) (#required :! [tz|355m|]) + ] + , rmInternalOperationResults = + [ InternalOperation {unInternalOperation = OperationFailed []} + , InternalOperation {unInternalOperation = OperationFailed []} + ] + }) + , OperationContent (RunMetadata { rmOperationResult = OperationFailed [] + , rmInternalOperationResults = []}) + ] + } + handleOperationResult @(Either SomeException) res 3 & \case + Right _ -> assertFailure "Expected result to fail, but it succeeded." + Left err -> case fromException err of + Just (UnexpectedRunErrors e) -> + e @?= + [ CantPayStorageFee + , BalanceTooLow (#balance :! [tz|149.38m|]) (#required :! [tz|355m|]) + ] + _ -> assertFailure $ "Expected failure to be UnexpectedRunErrors, but it was " <> Debug.show err diff --git a/test/Test/Fees.hs b/test/Test/Fees.hs --- a/test/Test/Fees.hs +++ b/test/Test/Fees.hs @@ -5,7 +5,6 @@ ( test_Fees_comp_iterations ) where -import Data.Map (fromList) import Test.HUnit ((@?=)) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) @@ -14,9 +13,9 @@ 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.Address.Alias (AddressOrAlias(..)) import Morley.Tezos.Core (tz) import Test.Util import TestM @@ -66,7 +65,7 @@ Right _ -> count averageContract :: L.Contract () () () -averageContract = L.mkContractWith L.intactCompilationOptions $ +averageContract = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $ L.unpair L.# L.drop L.# foldl' (L.#) L.nop (replicate 100 (L.push () L.# L.drop)) L.# L.nil L.# L.pair diff --git a/test/Test/KeyRevealing.hs b/test/Test/KeyRevealing.hs --- a/test/Test/KeyRevealing.hs +++ b/test/Test/KeyRevealing.hs @@ -13,6 +13,7 @@ import Morley.Client import Morley.Michelson.Runtime.GState (genesisAddress1) import Morley.Michelson.Typed +import Morley.Tezos.Address.Alias (AddressOrAlias(..)) import Morley.Tezos.Core (tz) import Test.Util import TestM @@ -29,7 +30,7 @@ test_keyRevealing = testGroup "Fake test key revealing" [ testCase "Manager key for new address is revealed only once for transfer" $ handleSuccess $ runFakeTest chainOperationHandlers fakeState $ do - senderAddress <- genKey $ AnAlias "sender" + senderAddress <- genKey "sender" dummyTransfer genesisAddress1 senderAddress mbManagerKey <- getManagerKey senderAddress @@ -48,7 +49,7 @@ , testCase "Manager key for new address is revealed only once for origination" $ handleSuccess $ runFakeTest chainOperationHandlers fakeState $ do - originatorAddress <- genKey $ AnAlias "originator" + originatorAddress <- genKey "originator" dummyTransfer genesisAddress1 originatorAddress mbManagerKey <- getManagerKey originatorAddress diff --git a/test/Test/Origination.hs b/test/Test/Origination.hs --- a/test/Test/Origination.hs +++ b/test/Test/Origination.hs @@ -5,7 +5,6 @@ ( test_lRunTransactionsUnit ) where -import Data.Map (fromList) import Test.HUnit (Assertion, assertFailure) import Test.Hspec.Expectations (shouldThrow) import Test.Tasty (TestTree, testGroup) @@ -14,6 +13,7 @@ import Lorentz qualified as L import Morley.Client import Morley.Michelson.Runtime.GState (genesisAddress1, genesisAddress2, genesisAddress3) +import Morley.Tezos.Address.Alias (AddressOrAlias(..)) import Morley.Tezos.Core import Test.Util import TestM diff --git a/test/Test/ParameterTypeGet.hs b/test/Test/ParameterTypeGet.hs --- a/test/Test/ParameterTypeGet.hs +++ b/test/Test/ParameterTypeGet.hs @@ -5,14 +5,13 @@ ( test_parameterTypeGetUnit ) where -import Data.Map as Map (empty, fromList) +import Data.Map as Map (empty) import Test.HUnit (Assertion, assertEqual, assertFailure) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Lorentz qualified as L -import Morley.Client import Morley.Client.RPC.Getters import Morley.Client.RPC.Types import Morley.Micheline @@ -21,6 +20,8 @@ import Morley.Michelson.Typed import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address +import Morley.Tezos.Address.Alias (Alias) +import Morley.Tezos.Crypto import Test.Util import TestM @@ -39,9 +40,9 @@ } contractHash1, contractHash2, contractHash3 :: ContractHash -contractHash1 = ContractHash "lol" -contractHash2 = ContractHash "kek" -contractHash3 = ContractHash "mda" +contractHash1 = Hash HashContract "lol" +contractHash2 = Hash HashContract "kek" +contractHash3 = Hash HashContract "mda" smartContractAddr1, smartContractAddr2, smartContractAddr3 :: Address smartContractAddr1 = ContractAddress contractHash1 diff --git a/test/Test/ReadBigMapValue.hs b/test/Test/ReadBigMapValue.hs --- a/test/Test/ReadBigMapValue.hs +++ b/test/Test/ReadBigMapValue.hs @@ -6,7 +6,6 @@ , test_ReadBigMapValueMaybeUnit ) where -import Data.Map (fromList) import Test.HUnit (Assertion, assertFailure) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) diff --git a/test/Test/Transaction.hs b/test/Test/Transaction.hs --- a/test/Test/Transaction.hs +++ b/test/Test/Transaction.hs @@ -5,7 +5,6 @@ ( test_lRunTransactionsUnit ) where -import Data.Map (fromList) import Test.HUnit (Assertion, assertFailure) import Test.Hspec.Expectations (shouldThrow) import Test.Tasty (TestTree, testGroup) diff --git a/test/Test/Util.hs b/test/Test/Util.hs --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -20,7 +20,7 @@ import Data.Aeson (encode) import Data.ByteArray (ScrubbedBytes) import Data.ByteString.Lazy qualified as LBS (toStrict) -import Data.Map as Map (elems, fromList, insert, lookup, toList) +import Data.Map as Map (elems, insert, lookup, toList) import Data.Singletons (demote) import Fmt ((+|), (|+)) import Network.HTTP.Types.Status (status404) @@ -33,11 +33,11 @@ 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.Address.Alias (AddressOrAlias(..), Alias(..)) import Morley.Tezos.Core import Morley.Tezos.Crypto import Morley.Tezos.Crypto.Ed25519 qualified as Ed25519 @@ -92,7 +92,7 @@ , hGetContractScript = handleGetContractScript , hSignBytes = \_ _ -> pure . SignatureEd25519 . Ed25519.sign testSecretKey - , hWaitForOperation = const pass + , hWaitForOperation = id , hGetAlias = handleGetAlias , hResolveAddressMaybe = handleResolveAddressMaybe , hRememberContract = handleRememberContract @@ -117,7 +117,7 @@ } } -handleGetBlockHash :: Monad m => BlockId -> TestT m Text +handleGetBlockHash :: Monad m => BlockId -> TestT m BlockHash handleGetBlockHash blkId = do unless (blkId == FinalHeadId) do throwString "Expected `getBlockHash` to be called with `head~2`." @@ -197,7 +197,7 @@ :: Monad m => OperationInput -> TestT m [Address] handleTransactionOrOrigination op = do FakeState{..} <- get - case oiCustom op of + case wcoCustom op of -- Ensure that transaction sender exists OpTransfer TransactionOperation{..} -> case lookup codSource fsContracts of Nothing -> throwM $ UnknownContract $ AddressResolved codSource @@ -220,7 +220,7 @@ -- We do not care about reveals at the moment return [] where - CommonOperationData{..} = oiCommonData op + CommonOperationData{..} = wcoCommon op -- | In most places, @morley-client@ executes operations against the @head@ block. assertHeadBlockId :: (HasCallStack, MonadThrow m) => BlockId -> m () @@ -267,15 +267,8 @@ where path = "/chains/main/blocks/head/context/big_maps/" <> show bigMapId <> "/" <> scriptExpr --- Here we have an alias with the prefix already added, --- so we can use 'Alias' instead 'AliasHint'. -getAlias :: AliasOrAliasHint -> Alias -getAlias = \case - AnAlias x -> x - AnAliasHint hint -> unsafeCoerceAliasHintToAlias hint - -handleRememberContract :: Monad m => Bool -> Address -> AliasOrAliasHint -> TestT m () -handleRememberContract replaceExisting addr (getAlias -> alias) = do +handleRememberContract :: Monad m => Bool -> Address -> Alias -> TestT m () +handleRememberContract replaceExisting addr alias = do let cs = dumbContractState { csAlias = alias } remember addr' cs' FakeState{..} = @@ -286,10 +279,10 @@ Nothing -> remember addr cs st _ -> bool pass (remember addr cs st) replaceExisting -handleGenKey :: Monad m => AliasOrAliasHint -> TestT m Address -handleGenKey (getAlias -> alias) = do +handleGenKey :: Monad m => Alias -> TestT m Address +handleGenKey alias = do let - addr = detGenKeyAddress (encodeUtf8 $ unsafeGetAliasText alias) + addr = detGenKeyAddress (encodeUtf8 $ unAlias alias) newContractState = dumbImplicitContractState { csAlias = alias } modify $ \s -> s & fsContractsL . at addr ?~ newContractState diff --git a/test/TestM.hs b/test/TestM.hs --- a/test/TestM.hs +++ b/test/TestM.hs @@ -31,8 +31,8 @@ import Control.Monad.Catch.Pure (CatchT(..)) import Data.ByteArray (ScrubbedBytes) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Fmt (pretty) -import Fmt import Morley.Client import Morley.Client.Logging (ClientLogAction) import Morley.Client.RPC @@ -40,22 +40,25 @@ import Morley.Micheline import Morley.Michelson.Typed.Scope (UntypedValScope) import Morley.Tezos.Address +import Morley.Tezos.Address.Alias (AddressOrAlias, Alias(..)) import Morley.Tezos.Core import Morley.Tezos.Crypto (KeyHash, PublicKey, SecretKey, Signature) import Morley.Util.ByteString -- | A test-specific orphan. instance IsString Alias where - fromString = mkAlias . fromString + fromString = Alias . fromString -- | Reader environment to interact with the fake state. data Handlers m = Handlers { -- HasTezosRpc - hGetBlockHash :: BlockId -> m Text + hGetBlockHash :: BlockId -> m BlockHash , hGetCounter :: BlockId -> Address -> m TezosInt64 , hGetBlockHeader :: BlockId -> m BlockHeader , hGetBlockConstants :: BlockId -> m BlockConstants , hGetBlockOperations :: BlockId -> m [[BlockOperation]] + , hGetScriptSizeAtBlock :: BlockId -> CalcSize -> m ScriptSize + , hGetBlockOperationHashes :: BlockId -> m [[OperationHash]] , hGetProtocolParameters :: BlockId -> m ProtocolParameters , hRunOperation :: BlockId -> RunOperation -> m RunOperationResult , hPreApplyOperations :: BlockId -> [PreApplyOperation] -> m [RunOperationResult] @@ -73,22 +76,23 @@ -- HasTezosClient , hSignBytes :: AddressOrAlias -> Maybe ScrubbedBytes -> ByteString -> m Signature - , hGenKey :: AliasOrAliasHint -> m Address - , hGenFreshKey :: AliasOrAliasHint -> m Address + , hGenKey :: Alias -> m Address + , hGenFreshKey :: Alias -> m Address , hRevealKey :: Alias -> Maybe ScrubbedBytes -> m () - , hWaitForOperation :: OperationHash -> m () - , hRememberContract :: Bool -> Address -> AliasOrAliasHint -> m () - , hImportKey :: Bool -> AliasOrAliasHint -> SecretKey -> m Alias + , hWaitForOperation :: m OperationHash -> m OperationHash + , hRememberContract :: Bool -> Address -> Alias -> m () + , hImportKey :: Bool -> Alias -> SecretKey -> m Alias , hResolveAddressMaybe :: AddressOrAlias -> m (Maybe Address) , hGetAlias :: AddressOrAlias -> m Alias , hGetPublicKey :: AddressOrAlias -> m PublicKey + , hGetSecretKey :: AddressOrAlias -> m SecretKey , hGetTezosClientConfig :: m TezosClientConfig , hCalcTransferFee :: AddressOrAlias -> Maybe ScrubbedBytes -> TezosInt64 -> [CalcTransferFeeData] -> m [TezosMutez] , hCalcOriginationFee :: forall cp st. UntypedValScope st => CalcOriginationFeeData cp st -> m TezosMutez , hGetKeyPassword :: Address -> m (Maybe ScrubbedBytes) - , hRegisterDelegate :: AliasOrAliasHint -> Maybe ScrubbedBytes -> m () + , hRegisterDelegate :: Alias -> Maybe ScrubbedBytes -> m () -- HasLog , hLogAction :: ClientLogAction m @@ -100,7 +104,9 @@ , hGetCounter = \_ _ -> throwM $ UnexpectedRpcCall "getCounter" , hGetBlockHeader = \_ -> throwM $ UnexpectedRpcCall "getBlockHeader" , hGetBlockConstants = \_ -> throwM $ UnexpectedRpcCall "getBlockConstants" + , hGetScriptSizeAtBlock = \_ _ -> throwM $ UnexpectedRpcCall "getScriptSizeAtBlock" , hGetBlockOperations = \_ -> throwM $ UnexpectedRpcCall "getBlockOperations" + , hGetBlockOperationHashes = \_ -> throwM $ UnexpectedRpcCall "hGetBlockOperationHashes" , hGetProtocolParameters = \_ -> throwM $ UnexpectedRpcCall "getProtocolParameters" , hRunOperation = \_ _ -> throwM $ UnexpectedRpcCall "runOperation" , hPreApplyOperations = \_ _ -> throwM $ UnexpectedRpcCall "preApplyOperations" @@ -126,6 +132,7 @@ , hResolveAddressMaybe = \_ -> throwM $ UnexpectedRpcCall "resolveAddressMaybe" , hGetAlias = \_ -> throwM $ UnexpectedRpcCall "getAlias" , hGetPublicKey = \_ -> throwM $ UnexpectedRpcCall "getPublicKey" + , hGetSecretKey = \_ -> throwM $ UnexpectedRpcCall "getSecretKey" , hGetTezosClientConfig = throwM $ UnexpectedClientCall "getTezosClientConfig" , hCalcTransferFee = \_ _ _ _ -> throwM $ UnexpectedClientCall "calcTransferFee" , hCalcOriginationFee = \_ -> throwM $ UnexpectedClientCall "calcOriginationFee" @@ -162,9 +169,9 @@ -- | Type to represent chain state in mock tests. data FakeState = FakeState { fsContracts :: Map Address ContractState - , fsHeadBlock :: Text + , fsHeadBlock :: BlockHash -- ^ Hash of the `head` block - , fsFinalHeadBlock :: Text + , fsFinalHeadBlock :: BlockHash -- ^ Hash of the `head~2` block , fsBlockConstants :: BlockId -> BlockConstants , fsProtocolParameters :: ProtocolParameters @@ -173,8 +180,8 @@ defaultFakeState :: FakeState defaultFakeState = FakeState { fsContracts = mempty - , fsHeadBlock = "HEAD" - , fsFinalHeadBlock = "HEAD~2" + , fsHeadBlock = BlockHash "HEAD" + , fsFinalHeadBlock = BlockHash "HEAD~2" , fsBlockConstants = \blkId -> BlockConstants { bcProtocol = "PROTOCOL" , bcChainId = "CHAIN_ID" @@ -221,7 +228,7 @@ | CantRevealContract Address | InvalidChainId | InvalidProtocol - | InvalidBranch Text + | InvalidBranch BlockHash | CounterMismatch deriving stock Show @@ -245,9 +252,6 @@ revealKey alias mbPassword = do h <- getHandler hRevealKey h alias mbPassword - waitForOperation op = do - h <- getHandler hWaitForOperation - h op rememberContract replaceExisting addr alias = do h <- getHandler hRememberContract h replaceExisting addr alias @@ -263,13 +267,16 @@ getPublicKey alias = do h <- getHandler hGetPublicKey h alias + getSecretKey alias = do + h <- getHandler hGetSecretKey + h alias getTezosClientConfig = join $ getHandler hGetTezosClientConfig calcTransferFee from mbPassword burnCap transferDatas = do h <- getHandler hCalcTransferFee h from mbPassword burnCap transferDatas calcOriginationFee origData = do - h <- getHandler hCalcOriginationFee + h <- getHandler (\hs -> hCalcOriginationFee hs) h origData getKeyPassword addr = do h <- getHandler hGetKeyPassword @@ -303,6 +310,9 @@ preApplyOperationsAtBlock block ops = do h <- getHandler hPreApplyOperations h block ops + getScriptSizeAtBlock block script = do + h <- getHandler hGetScriptSizeAtBlock + h block script forgeOperationAtBlock block op = do h <- getHandler hForgeOperation h block op @@ -337,5 +347,11 @@ getDelegateAtBlock block addr = do h <- getHandler hGetDelegateAtBlock h block addr + getBlockOperationHashes block = do + h <- getHandler hGetBlockOperationHashes + h block + waitForOperation opHash = do + h <- getHandler hWaitForOperation + h opHash makeLensesFor [("fsContracts", "fsContractsL")] ''FakeState