packages feed

morley-client (empty) → 0.1.0

raw patch · 51 files changed

+8662/−0 lines, 51 filesdep +HUnitdep +aesondep +aeson-casing

Dependencies added: HUnit, aeson, aeson-casing, base-noprelude, binary, bytestring, co-log, co-log-core, colourista, constraints, containers, data-default, exceptions, fmt, hex-text, hspec-expectations, http-client, http-client-tls, http-types, lens, lorentz, megaparsec, memory, morley, morley-client, morley-prelude, mtl, named, optparse-applicative, process, random, safe-exceptions, scientific, servant, servant-client, servant-client-core, singletons, syb, tasty, tasty-ant-xml, tasty-hunit-compat, template-haskell, text, th-reify-many, time, universum, unliftio, vector

Files

+ CHANGES.md view
@@ -0,0 +1,8 @@+<!-- Unreleased: append new entries here -->+++0.1.0+=====+Initial release.+A client to interact with the Tezos blockchain, by use of the `tezos-node` RPC+and/or of the `tezos-client` binary.
+ LICENSE view
@@ -0,0 +1,19 @@+MIT License Copyright (c) 2020 Tocqueville Group++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is furnished+to do so, subject to the following conditions:++The above copyright notice and this permission notice (including the next+paragraph) shall be included in all copies or substantial portions of the+Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS+OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF+OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,27 @@+# Morley-client++This package implements a client to interact with the Tezos blockchain.+It is intended to be used both as a library and as a tool.++`morley-client` uses the [Tezos RPC API](https://tezos.gitlab.io/developer/rpc.html)+to interact with a remote (or local) `tezos-node` and uses the `tezos-client`+binary for some operations, such as signing and local contract manipulations.++IMPORTANT: `morley-client` is still actively developed and unstable.+Its interface(s) may change abruptly and it shouldn't be used for anything but testing.++## Command line interface++At the moment, the `morley-client` CLI can be used to perform a handful of operations.++You can use:+```sh+morley-client --help+```+to get a list of available commands and info about common options.++You can also use:+```sh+morley-client COMMAND --help+```+to get more information about each of the available `COMMAND` and its options.
+ app/Main.hs view
@@ -0,0 +1,100 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main+  ( main+  ) where++import Control.Exception.Safe (throwString)+import qualified Data.Aeson as Aeson+import Data.Default (def)+import Fmt (pretty)+import GHC.IO.Encoding (setFileSystemEncoding)+import qualified Options.Applicative as Opt+import System.IO (utf8)++import Morley.Client+import Morley.Client.Parser+import Morley.Client.RPC (BlockOperation(..), OperationResp(..))+import Morley.Client.RPC.Getters+import Morley.Client.Util (extractAddressesFromValue)+import Morley.Michelson.Runtime (prepareContract)+import Morley.Michelson.TypeCheck (typeCheckContract, typeCheckingWith, typeVerifyParameter)+import Morley.Michelson.Typed (Contract, Contract'(..), SomeContract(..))+import Morley.Michelson.Typed.Value (Value'(..))+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address (Address(..), formatAddress)+import Morley.Tezos.Core (prettyTez)+import Morley.Util.Exception (throwLeft)+import Morley.Util.Main (wrapMain)++mainImpl :: ClientArgsRaw -> MorleyClientM ()+mainImpl cmd =+  case cmd of+    Originate OriginateArgs{..} -> do+      contract <- liftIO $ prepareContract oaMbContractFile+      let originator = oaOriginateFrom+      (operationHash, contractAddr) <-+        originateUntypedContract True oaContractName originator oaInitialBalance+        contract oaInitialStorage oaMbFee++      putTextLn "Contract was successfully deployed."+      putTextLn $ "Operation hash: " <> pretty operationHash+      putTextLn $ "Contract address: " <> formatAddress contractAddr++    Transfer TransferArgs{..} -> do+      sendAddress <- resolveAddress taSender+      destAddress <- resolveAddress taDestination+      operationHash <- case destAddress of+        ContractAddress _ -> do+          contract <- getContract destAddress+          SomeContract fullContract <-+            throwLeft $ pure $ typeCheckingWith def $ typeCheckContract contract+          case fullContract of+            (Contract{} :: Contract cp st) -> do+              let addrs = extractAddressesFromValue taParameter+              tcOriginatedContracts <- getContractsParameterTypes addrs+              parameter <- throwLeft $ pure $ typeCheckingWith def $+                typeVerifyParameter @cp tcOriginatedContracts taParameter+              transfer sendAddress destAddress taAmount U.DefEpName parameter taMbFee+        KeyAddress _ -> case taParameter of+          U.ValueUnit -> transfer sendAddress destAddress taAmount U.DefEpName VUnit Nothing+          _ -> throwString ("The transaction parameter must be 'Unit' "+            <> "when transferring to an implicit account")++      putTextLn $ "Transaction was successfully sent.\nOperation hash " <> pretty operationHash <> "."++    GetBalance addrOrAlias -> do+      balance <- getBalance =<< resolveAddress addrOrAlias+      putTextLn $ prettyTez balance++    GetBlockHeader blockId -> do+      blockHeader <- getBlockHeader blockId+      putStrLn $ Aeson.encode blockHeader++    GetBlockOperations blockId -> do+      operationLists <- getBlockOperations blockId+      forM_ operationLists $ \operations -> do+        forM_ operations $ \BlockOperation {..} -> do+          putTextLn $ "Hash: " <> boHash+          putTextLn $ "Contents: "+          forM_ boContents $ \case+            TransactionOpResp to -> putStrLn $ Aeson.encode to+            OtherOpResp -> putTextLn "Non-transaction operation"+          putTextLn ""+      putTextLn "——————————————————————————————————————————————————\n"++main :: IO ()+main = wrapMain $ do+  -- grepcake: the following line is needed to parse CL arguments (argv) in+  -- utf-8. It might be necessary to add the similar line to other+  -- executables. However, I've filed the issue for `with-utf8`+  -- (https://github.com/serokell/haskell-with-utf8/issues/8). If it gets fixed+  -- in upstream, this line should be safe to remove. In that case, FIXME.+  setFileSystemEncoding utf8++  disableAlphanetWarning+  ClientArgs parsedConfig cmd <- Opt.execParser morleyClientInfo+  env <- mkMorleyClientEnv parsedConfig+  runMorleyClientM env (mainImpl cmd)
+ morley-client.cabal view
@@ -0,0 +1,329 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           morley-client+version:        0.1.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+homepage:       https://gitlab.com/morley-framework/morley+bug-reports:    https://gitlab.com/morley-framework/morley/-/issues+author:         Serokell, Tocqueville Group+maintainer:     Serokell <hi@serokell.io>+copyright:      2020 Tocqueville Group+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    CHANGES.md+    README.md++source-repository head+  type: git+  location: git@gitlab.com:morley-framework/morley.git++library+  exposed-modules:+      Morley.Client+      Morley.Client.Action+      Morley.Client.Action.Batched+      Morley.Client.Action.Common+      Morley.Client.Action.Operation+      Morley.Client.Action.Origination+      Morley.Client.Action.Origination.Large+      Morley.Client.Action.Transaction+      Morley.Client.App+      Morley.Client.Env+      Morley.Client.Full+      Morley.Client.Init+      Morley.Client.Logging+      Morley.Client.OnlyRPC+      Morley.Client.Parser+      Morley.Client.RPC+      Morley.Client.RPC.Aeson+      Morley.Client.RPC.API+      Morley.Client.RPC.AsRPC+      Morley.Client.RPC.Class+      Morley.Client.RPC.Error+      Morley.Client.RPC.Getters+      Morley.Client.RPC.HttpClient+      Morley.Client.RPC.QueryFixedParam+      Morley.Client.RPC.Types+      Morley.Client.TezosClient+      Morley.Client.TezosClient.Class+      Morley.Client.TezosClient.Impl+      Morley.Client.TezosClient.Parser+      Morley.Client.TezosClient.Types+      Morley.Client.Util+      Morley.Util.Batching+  other-modules:+      Paths_morley_client+  autogen-modules:+      Paths_morley_client+  hs-source-dirs:+      src+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+      ViewPatterns+      DerivingStrategies+      DeriveAnyClass+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages+  build-depends:+      aeson+    , aeson-casing+    , base-noprelude >=4.7 && <5+    , binary+    , bytestring+    , co-log+    , co-log-core+    , colourista+    , constraints+    , containers+    , data-default+    , fmt+    , hex-text+    , http-client+    , http-client-tls+    , http-types+    , lens+    , lorentz+    , megaparsec+    , memory+    , morley+    , morley-prelude+    , mtl+    , named+    , optparse-applicative+    , process+    , random+    , safe-exceptions+    , scientific+    , servant+    , servant-client+    , servant-client-core+    , singletons+    , syb+    , template-haskell+    , text+    , th-reify-many+    , time+    , universum+    , unliftio+    , vector+  default-language: Haskell2010++executable morley-client+  main-is: Main.hs+  other-modules:+      Paths_morley_client+  hs-source-dirs:+      app+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+      ViewPatterns+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages+  build-depends:+      aeson+    , base-noprelude >=4.7 && <5+    , data-default+    , fmt+    , morley+    , morley-client+    , morley-prelude+    , optparse-applicative+    , safe-exceptions+  default-language: Haskell2010++test-suite morley-client-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Ingredients+      Test.AsRPC+      Test.BigMapGet+      Test.Fees+      Test.KeyRevealing+      Test.Origination+      Test.ParameterTypeGet+      Test.Parser+      Test.ReadBigMapValue+      Test.Transaction+      Test.Util+      TestM+      Tree+      Paths_morley_client+  hs-source-dirs:+      test+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NegativeLiterals+      NumericUnderscores+      NumDecimals+      OverloadedLabels+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      QuasiQuotes+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+      ViewPatterns+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m"+  build-tool-depends:+      tasty-discover:tasty-discover+  build-depends:+      HUnit+    , aeson+    , base-noprelude >=4.7 && <5+    , bytestring+    , co-log+    , co-log-core+    , containers+    , exceptions+    , fmt+    , hex-text+    , hspec-expectations+    , http-types+    , lens+    , lorentz+    , memory+    , morley+    , morley-client+    , morley-prelude+    , safe-exceptions+    , servant-client-core+    , singletons+    , syb+    , tasty+    , tasty-ant-xml+    , tasty-hunit-compat+    , template-haskell+    , time+  default-language: Haskell2010
+ src/Morley/Client.hs view
@@ -0,0 +1,104 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Morley client that connects with real Tezos network through RPC and tezos-client binary.+-- For more information please refer to README.+module Morley.Client+  ( -- * Command line parser+    parserInfo+  , clientConfigParser++  -- * Full client monad and environment+  , MorleyClientM+  , MorleyClientConfig (..)+  , MorleyClientEnv' (..)+  , MorleyClientEnv+  , runMorleyClientM+  , mkMorleyClientEnv+  -- ** Lens+  , mceTezosClientL+  , mceLogActionL+  , mceSecretKeyL+  , mceClientEnvL++  -- * Only-RPC client monad and environment+  , MorleyOnlyRpcM (..)+  , MorleyOnlyRpcEnv (..)+  , mkMorleyOnlyRpcEnv+  , runMorleyOnlyRpcM++  -- * High-level actions+  , module Morley.Client.Action++  -- * RPC+  , BlockId (..)+  , HasTezosRpc (..)+  , getContract+  , getImplicitContractCounter+  , getContractStorage+  , getBigMapValue+  , getHeadBlock+  , getCounter+  , getProtocolParameters+  , runOperation+  , preApplyOperations+  , forgeOperation+  , getContractScript+  , getContractBigMap+  , getBalance+  , getDelegate+  , runCode+  , getManagerKey++  -- ** Errors+  , ClientRpcError (..)+  , UnexpectedErrors (..)+  , IncorrectRpcResponse (..)+  , RunError (..)+  -- ** Getters+  , ValueDecodeFailure (..)+  , ValueNotFound (..)+  , readAllBigMapValues+  , readAllBigMapValuesMaybe+  , readContractBigMapValue+  , readBigMapValueMaybe+  , readBigMapValue+  -- ** AsRPC+  , AsRPC+  , deriveRPC+  , deriveRPCWithStrategy+  , deriveManyRPC+  , deriveManyRPCWithStrategy++  -- * @tezos-client@+  , Alias+  , mkAlias+  , AliasHint+  , mkAliasHint+  , AliasOrAliasHint (..)+  , AddressOrAlias (..)+  , addressResolved+  , HasTezosClient (..)+  , resolveAddress+  , TezosClientError (..)++  -- * Util+  , disableAlphanetWarning++  -- * Reexports+  , Opt.ParserInfo -- Needed for tests+  ) where++import qualified Options.Applicative as Opt++import Morley.Client.Action+import Morley.Client.Env+import Morley.Client.Full+import Morley.Client.Init+import Morley.Client.OnlyRPC+import Morley.Client.Parser+import Morley.Client.RPC+import Morley.Client.RPC.AsRPC+import Morley.Client.TezosClient+import Morley.Client.Util
+ src/Morley/Client/Action.hs view
@@ -0,0 +1,18 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | High-level actions implemented in abstract monads that+-- require both RPC and @tezos-client@ functionality.++module Morley.Client.Action+  ( module Morley.Client.Action.Operation+  , module Morley.Client.Action.Origination+  , module Morley.Client.Action.Transaction+  , revealKeyUnlessRevealed+  ) where++import Morley.Client.Action.Common (revealKeyUnlessRevealed)+import Morley.Client.Action.Operation+import Morley.Client.Action.Origination+import Morley.Client.Action.Transaction
+ src/Morley/Client/Action/Batched.hs view
@@ -0,0 +1,79 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Primitives for running batched operations with a neat interface.+module Morley.Client.Action.Batched+  ( OperationsBatch (..)+  , originateContractM+  , runTransactionM+  , runOperationsBatch+  ) where++import Fmt (Buildable(..))++import Morley.Client.Action.Common+import Morley.Client.Action.Operation+import Morley.Client.Logging+import Morley.Client.RPC.Class+import Morley.Client.RPC.Types+import Morley.Client.TezosClient+import Morley.Tezos.Address+import Morley.Util.Batching++{- | Where the batched operations occur.++Example:++@+runOperationsBatch mySender $ do+  addr <- originateContractM ...+  runTransactionM ...+  return addr+@++Note that this is not a 'Monad', rather an 'Applicative' - use+@-XApplicativeDo@ extension for nicer experience.+-}+newtype OperationsBatch a = OperationsBatch+  { unOperationsBatch+      :: BatchingM+          (Either TransactionData OriginationData)+          (Either () Address)+          BatchedOperationError+          a+  } deriving newtype (Functor, Applicative)++data BatchedOperationError+  = UnexpectedOperationResult++instance Buildable BatchedOperationError where+  build = \case+    UnexpectedOperationResult ->+      "Got unexpected operation type within result of batched operation"++-- | Perform transaction within a batch.+runTransactionM :: TransactionData -> OperationsBatch ()+runTransactionM td = OperationsBatch $+  Left td `submitThenParse` \case+    Left () -> pass+    Right _ -> Left UnexpectedOperationResult++-- | Perform origination within a batch.+originateContractM :: OriginationData -> OperationsBatch Address+originateContractM od = OperationsBatch $+  Right od `submitThenParse` \case+    Left _ -> Left UnexpectedOperationResult+    Right addr -> return addr++-- | Execute a batch.+runOperationsBatch+  :: ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => AddressOrAlias+  -> OperationsBatch a+  -> m (Maybe OperationHash, a)+runOperationsBatch sender (OperationsBatch batch) =+  unsafeRunBatching (runOperations sender) batch
+ src/Morley/Client/Action/Common.hs view
@@ -0,0 +1,291 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module with functions that used in both transaction sending and contract+-- origination.+module Morley.Client.Action.Common+  ( OperationConstants(..)+  , TD (..)+  , TransactionData(..)+  , OriginationData(..)+  , addOperationPrefix+  , buildTxDataWithAlias+  , getAppliedResults+  , computeFee+  , computeStorageLimit+  , convergingFee+  , preProcessOperation+  , stubSignature+  , prepareOpForInjection+  , updateCommonData+  , toParametersInternals+  , mkOriginationScript+  , revealKeyUnlessRevealed+  ) where++import Control.Lens (Prism')+import Data.ByteArray (ScrubbedBytes)+import Data.ByteString (cons)+import Data.Default (def)+import Fmt (Buildable(..), Builder, pretty, (+|), (|+))++import Morley.Client.Logging (WithClientLog, logDebug)+import Morley.Client.RPC.Class+import Morley.Client.RPC.Error+import Morley.Client.RPC.Getters+import Morley.Client.RPC.Types+import Morley.Client.TezosClient+import Morley.Client.Util+import Morley.Micheline (TezosInt64, TezosMutez(..), toExpression)+import Morley.Micheline.Expression (Expression(ExpressionString))+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Untyped.Entrypoints+import Morley.Tezos.Address+import Morley.Tezos.Core+import Morley.Tezos.Crypto++-- | Datatype that contains various values required for+-- chain operations.+data OperationConstants = OperationConstants+  { ocLastBlockHash :: Text+  -- ^ Block in which operations is going to be injected+  , ocBlockConstants :: BlockConstants+  -- ^ Information about block: chain_id and protocol+  , ocFeeConstants :: FeeConstants+  -- ^ Information about fees+  , ocCounter :: TezosInt64+  -- ^ Sender counter+  }++-- | Helper for 'TransactionData' and t'Morley.Client.Action.Transaction.LTransactionData'.+data TD (t :: Type) = TD+  { tdReceiver :: Address+  , tdAmount :: Mutez+  , tdEpName :: EpName+  , tdParam :: t+  , tdMbFee :: Maybe Mutez+  }++-- | Data for a single transaction in a batch.+data TransactionData where+  TransactionData ::+    forall (t :: T.T). ParameterScope t =>+    TD (T.Value t) -> TransactionData++instance Buildable TransactionData where+  build = buildTxDataWithAlias Nothing++-- | Builds 'TransactionData' with additional info about receiver's alias, if present.+buildTxDataWithAlias :: Maybe Alias -> TransactionData -> Builder+buildTxDataWithAlias mbAlias (TransactionData TD{..}) =+  "To: " +| tdReceiver |+ buildMbAlias mbAlias |+ ". EP: " +| tdEpName |++  ". Parameter: " +| tdParam |+ ". Amount: " +| tdAmount |+ ""+  where+    buildMbAlias :: Maybe Alias -> Builder+    buildMbAlias = maybe "" $ \a -> " (" +| a |+ ")"++-- | Data for a single origination in a batch+data OriginationData =+  forall cp st. (ParameterScope cp, StorageScope st) => OriginationData+  { odReplaceExisting :: Bool+  , odName :: AliasHint+  , odBalance :: Mutez+  , odContract :: T.Contract cp st+  , odStorage :: T.Value st+  , odMbFee :: Maybe Mutez+  }++toParametersInternals+  :: ParameterScope t+  => EpName+  -> T.Value t+  -> ParametersInternal+toParametersInternals epName epParam = ParametersInternal+  { piEntrypoint = epNameToTezosEp epName+  , piValue = toExpression epParam+  }++mkOriginationScript+  :: T.Contract cp st -> T.Value st -> OriginationScript+mkOriginationScript contract@T.Contract{} initialStorage = OriginationScript+  { osCode = toExpression contract+  , osStorage = toExpression initialStorage+  }++-- | Preprocess chain operation in order to get required constants.+preProcessOperation+  :: (HasTezosRpc m) => Address -> m OperationConstants+preProcessOperation sourceAddr = do+  ocLastBlockHash <- getHeadBlock+  ocBlockConstants <- getBlockConstants (BlockHashId ocLastBlockHash)+  let ocFeeConstants = def+  ocCounter <- getImplicitContractCounter sourceAddr+  pure OperationConstants{..}++-- | Perform runOperation or preApplyOperations and combine the results.+--+-- If an error occurs, this function tries to turn errors returned by RPC+-- into 'ClientRpcError'. If it can't do the conversion, 'UnexpectedErrors'+-- will be thrown.+getAppliedResults+  :: (HasTezosRpc m)+  => Either RunOperation PreApplyOperation -> m (NonEmpty AppliedResult)+getAppliedResults op = do+  (runResult, expectedContentsSize) <- case op of+    Left runOp ->+      (, length $ roiContents $ roOperation runOp) <$> runOperation runOp+    Right preApplyOp -> do+      results <- preApplyOperations [preApplyOp]+      -- There must be exactly one result because we pass a list+      -- consisting of 1 item.+      case results of+        [result] -> pure (result, length $ paoContents preApplyOp)+        _ -> 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++    -- 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+    -- handling of such scenarios here.+    -- We don't rely on any specific order of errors and on the number of errors.+    -- For example, in case of bad parameter this number can be different.+    handleErrors :: MonadThrow m => [RunError] -> m a+    handleErrors errs+      | Just address <- findError _RuntimeError+      , Just expr <- findError _ScriptRejected+        = throwM $ ContractFailed address expr+      -- This case should be removed once 006 is finally deprecated+      | Just address <- findError _BadContractParameter+      , Just (_, expr) <- findError _InvalidSyntacticConstantError+        = throwM $ BadParameter address expr+      | Just address <- findError _BadContractParameter+      , Just (_, expr) <- findError _InvalidConstant+        = throwM $ BadParameter address expr+      | Just address <- findError _BadContractParameter+      , Just notation <- findError _InvalidContractNotation+        = throwM $ BadParameter address (ExpressionString notation)+      | Just address <- findError _REEmptyTransaction+        = throwM $ EmptyTransaction address+      | Just address <- findError _RuntimeError+      , Just _ <- findError _ScriptOverflow+        = throwM $ ShiftOverflow address+      | Just address <- findError _RuntimeError+      , Just _ <- findError _GasExhaustedOperation+        = throwM $ GasExhaustion address+      | otherwise+        = throwM $ UnexpectedRunErrors errs+      where+        findError :: Prism' RunError a -> Maybe a+        findError prism = fmap head . nonEmpty . mapMaybe (preview prism) $ errs++-- | Reveal key for implicit address if necessary.+--+-- Throws an error if given address is a contract address.+revealKeyUnlessRevealed+  :: (WithClientLog env m, HasTezosRpc m, HasTezosClient m)+  => Address+  -> Maybe ScrubbedBytes+  -> m ()+revealKeyUnlessRevealed addr mbPassword = do+  alias <- getAlias $ AddressResolved addr+  unless (isKeyAddress addr) $+    throwM $ CantRevealContract alias+  mbManagerKey <- getManagerKey addr+  case mbManagerKey of+    Nothing -> revealKey alias mbPassword+    Just _  -> logDebug $ alias |+ " alias has already revealed key"++-- | Compute fee for operation.+computeFee :: FeeConstants -> Int -> TezosInt64 -> Mutez+computeFee FeeConstants{..} opSize gasLimit =+  -- Here and further we mostly follow the Tezos implementation:+  -- https://gitlab.com/tezos/tezos/-/blob/14d6dafd23eeafe30d931a41d43c99b1ebed5373/src/proto_alpha/lib_client/injection.ml#L584++  unsafeMkMutez . ceiling . sum $+    [ toRational $ unMutez fcBase+    , toRational fcMutezPerOpByte * toRational opSize+    , toRational fcMutezPerGas * toRational gasLimit+    ]++-- | @convergingFee mkOperation countFee@ tries to find the most minimal fee+-- @F@ and the respective operation @Op@ so that @mkOperation F = Op@ and+-- @countFee Op <= F@.+convergingFee+  :: forall op extra m. Monad m+  => (Mutez -> m op)+  -> (op -> m (Mutez, extra))+  -> m (Mutez, op, extra)+convergingFee mkOperation countFee = iterateFee 5 assessedMinimalFee+  where+    assessedMinimalFee = zeroMutez+    -- ↑ In real life we can encounter small fees like ~300 mutez+    -- (for small transfers to implicit addresses), but even if we set this+    -- as a starting fee, we won't win any number of iteration steps.+    -- So setting just zero.++    {- We have to use iterative algorithm because fees are included into+       operation, and higher fees increase operation size and thus fee may+       grow again. Fortunatelly, fees strictly grow with operation size and+       operation size strictly grows with fees, so the implementation is simple.+    -}+    iterateFee :: Word -> Mutez -> m (Mutez, op, extra)+    iterateFee 0 _ = error "Failed to converge at some fee"+    iterateFee countdown curFee = do+      op <- mkOperation curFee+      (requiredFee, extra) <- countFee op+      if requiredFee <= curFee+        then pure (curFee, op, extra)+        else iterateFee (countdown - 1) requiredFee++-- | Compute storage limit based on the results of the operations application+-- and given @ProtocolParameters@.+computeStorageLimit :: [AppliedResult] -> ProtocolParameters -> TezosInt64+computeStorageLimit appliedResults pp = sum $ map (\ar -> sum+  [ arPaidStorageDiff ar+  , (arAllocatedDestinationContracts ar) * fromIntegral (ppOriginationSize pp)+  , fromIntegral (length $ arOriginatedContracts ar) * fromIntegral (ppOriginationSize pp)+  ]) appliedResults++-- | Update common operation data based on preliminary run which estimates storage and+-- gas limits and fee.+--+-- Reference implementation adds 100 gas and 20 bytes to the limits for safety.+updateCommonData+  :: TezosInt64 -> TezosInt64 -> TezosMutez+  -> CommonOperationData -> CommonOperationData+updateCommonData gasLimit storageLimit fee commonData =+  commonData+  { codGasLimit = gasLimit+  , codStorageLimit = storageLimit+  , codFee = fee+  }++stubSignature :: Signature+stubSignature = unsafeParseSignature+  "edsigtXomBKi5CTRf5cjATJWSyaRvhfYNHqSUGrn4SdbYRcGwQrUGjzEfQDTuqHhuA8b2d8NarZjz8TRf65WkpQmo423BtomS8Q"+  where+    unsafeParseSignature :: HasCallStack => Text -> Signature+    unsafeParseSignature = either (error . pretty) id . parseSignature++addOperationPrefix :: ByteString -> ByteString+addOperationPrefix = cons 0x03++prepareOpForInjection :: ByteString -> Signature -> ByteString+prepareOpForInjection operationHex signature' =+  operationHex <> signatureToBytes signature'
+ src/Morley/Client/Action/Operation.hs view
@@ -0,0 +1,330 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Implementation of generic operations submission.+module Morley.Client.Action.Operation+  ( runOperations+  , runOperationsNonEmpty+  -- helpers+  , dryRunOperationsNonEmpty+  ) where++import Data.List (zipWith4)+import qualified Data.List.NonEmpty as NE+import Data.Singletons (Sing, SingI, sing)+import qualified Data.Text as T+import Fmt (blockListF', listF, pretty, (+|), (|+))++import Morley.Client.Action.Common+import Morley.Client.Logging+import Morley.Client.RPC.Class+import Morley.Client.RPC.Error+import Morley.Client.RPC.Getters+import Morley.Client.RPC.Types+import Morley.Client.TezosClient+import Morley.Micheline (StringEncode(..), TezosInt64, TezosMutez(..))+import Morley.Tezos.Address+import Morley.Tezos.Crypto+import Morley.Util.ByteString++logOperations+  :: forall (runMode :: RunMode) env m.+     ( WithClientLog env m+     , HasTezosClient m+     , SingI runMode -- We don't ask aliases with 'tezos-client' in 'DryRun' mode+     )+  => AddressOrAlias+  -> NonEmpty (Either TransactionData OriginationData)+  -> m ()+logOperations sender ops = do+  let runMode = sing @runMode++      opName =+        if | all isLeft ops -> "transactions"+           | all isRight ops -> "originations"+           | otherwise -> "operations"++      buildOp = \case+        (Left tx, mbAlias) ->+          buildTxDataWithAlias mbAlias tx+        (Right orig, _) ->+          odName orig |+ " (temporary alias)"++  sender' <- case sender of+    addr@AddressResolved{} -> case runMode of+      SRealRun -> AddressAlias <$> getAlias sender+      SDryRun  -> pure addr+    alias -> pure alias++  aliases <- case runMode of+    SRealRun ->+      forM ops $ \case+        Left (TransactionData tx) ->+          Just <$> (getAlias . AddressResolved $ tdReceiver tx)+        _ ->+          pure Nothing+    SDryRun -> pure $ ops $> Nothing++  logInfo $ T.strip $ -- strip trailing newline+    "Running " +| opName +| " by " +| sender' |+ ":\n" +|+    blockListF' "-" buildOp (ops `NE.zip` aliases)++-- | Perform sequence of operations.+--+-- Returns operation hash (or @Nothing@ in case empty list was provided) and result of+-- each operation (nothing for transactions and an address for originated contracts+runOperations+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => AddressOrAlias+  -> [Either TransactionData OriginationData]+  -> m (Maybe OperationHash, [Either () Address])+runOperations sender operations = case operations of+  [] -> return (Nothing, [])+  op : ops -> do+    (opHash, res) <- runOperationsNonEmpty sender $ op :| ops+    return $ (Just opHash, toList res)++-- | Perform non-empty sequence of operations.+--+-- Returns operation hash and result of each operation+-- (nothing for transactions and an address for originated contracts).+runOperationsNonEmpty+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => AddressOrAlias+  -> NonEmpty (Either TransactionData OriginationData)+  -> m (OperationHash, NonEmpty (Either () Address))+runOperationsNonEmpty sender operations =+  runOperationsNonEmptyHelper @'RealRun sender operations++-- | Flag that is used to determine @runOperationsNonEmptyHelper@ behaviour.+data RunMode = DryRun | RealRun++isRealRun :: forall (runMode :: RunMode). (SingI runMode) => Bool+isRealRun = case sing @runMode of+  SRealRun -> True+  SDryRun  -> False++-- | Type family which is used to determine the output type of the+-- @runOperationsNonEmptyHelper@.+type family RunResult (a :: RunMode) where+  RunResult 'DryRun = NonEmpty (AppliedResult, TezosMutez)+  RunResult 'RealRun = (OperationHash, NonEmpty (Either () Address))++data SingRunResult :: RunMode -> Type where+  SDryRun :: SingRunResult 'DryRun+  SRealRun :: SingRunResult 'RealRun++type instance Sing = SingRunResult++instance SingI 'DryRun where+  sing = SDryRun++instance SingI 'RealRun where+  sing = SRealRun++-- | Perform dry-run for sequence of operations.+--+-- Returned @AppliedResult@ contains information about estimated limits,+-- storage changes, etc. Additionally, estimated fees are returned.+dryRunOperationsNonEmpty+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => AddressOrAlias+  -> NonEmpty (Either TransactionData OriginationData)+  -> m (NonEmpty (AppliedResult, TezosMutez))+dryRunOperationsNonEmpty sender operations =+  runOperationsNonEmptyHelper @'DryRun sender operations++-- | Perform non-empty sequence of operations and either dry-run+-- and return estimated limits and fees or perform operation injection.+-- Behaviour is defined via @RunMode@ flag argument.+runOperationsNonEmptyHelper+  :: forall (runMode :: RunMode) m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     , SingI runMode+     )+  => AddressOrAlias+  -> NonEmpty (Either TransactionData OriginationData)+  -> m (RunResult runMode)+runOperationsNonEmptyHelper sender operations = do+  logOperations @runMode sender operations+  senderAddress <- resolveAddress sender+  prohibitContractSender senderAddress $ head operations+  mbPassword <- getKeyPassword senderAddress+  when (isRealRun @runMode) $+    revealKeyUnlessRevealed senderAddress mbPassword++  pp <- getProtocolParameters+  OperationConstants{..} <- preProcessOperation senderAddress++  let convertOps i = \case+        Left (TransactionData TD {..}) ->+          Left TransactionOperation+          { toDestination = tdReceiver+          , toCommonData = commonData+          , toAmount = TezosMutez tdAmount+          , toParameters = toParametersInternals tdEpName tdParam+          }+        Right OriginationData{..} ->+          Right OriginationOperation+          { ooCommonData = commonData+          , ooBalance = TezosMutez odBalance+          , ooScript = mkOriginationScript odContract odStorage+          }+        where+          commonData = mkCommonOperationData senderAddress (ocCounter + i) pp++  let opsToRun = NE.zipWith convertOps (1 :| [(2 :: TezosInt64)..]) operations+      mbFees = map (either (\(TransactionData TD {..}) -> tdMbFee) odMbFee) operations++  -- Perform run_operation with dumb signature in order+  -- to estimate gas cost, storage size and paid storage diff+  let runOp = RunOperation+        { roOperation = RunOperationInternal+          { roiBranch = ocLastBlockHash+          , roiContents = opsToRun+          , roiSignature = stubSignature+          }+        , roChainId = bcChainId ocBlockConstants+        }+  results <- getAppliedResults (Left runOp)++  let -- Learn how to forge given operations+      forgeOp :: NonEmpty (Either TransactionOperation OriginationOperation) -> m ByteString+      forgeOp ops =+        fmap unHexJSONByteString . forgeOperation $ ForgeOperation+          { foBranch = ocLastBlockHash+          , foContents = ops+          }++  let -- Attach a signature to forged operation + return the signature itself+      signForgedOp :: ByteString -> m (Signature, ByteString)+      signForgedOp op = do+        signature' <- signBytes sender mbPassword (addOperationPrefix op)+        return (signature', prepareOpForInjection op signature')++  -- Fill in fees+  let+    updateOp opToRun mbFee ar isFirst = do+      let storageLimit = computeStorageLimit [ar] pp + 20 -- similarly to tezos-client, we add 20 for safety+      let gasLimit = arConsumedGas ar + 100  -- adding extra for safety+          updateCommonDataForFee fee =+            updateCommonData gasLimit storageLimit (TezosMutez fee)++      (_fee, op, mReadySignedOp) <- convergingFee+        @(Either TransactionOperation OriginationOperation)+        @(Maybe (Signature, ByteString))  -- ready operation and its signature+        (\fee ->+          return $ bimap+            (toCommonDataL %~ updateCommonDataForFee fee)+            (ooCommonDataL %~ updateCommonDataForFee fee)+            opToRun+          )+        (\op -> do+          forgedOp <- forgeOp $ one op+          -- In the Tezos implementation the first transaction+          -- in the series pays for signature.+          -- Signature of hash should be constant in size,+          -- so we can pass any signature, not necessarily the final one+          (fullForgedOpLength, mExtra) <-+            if isFirst+              then do+                res@(_signature, signedOp) <- signForgedOp forgedOp+                return (length signedOp, Just res)+              else+                -- Forge output automatically includes additional 32-bytes header+                -- which should be ommited for all operations in batch except the first one.+                pure (length forgedOp - 32, Nothing)+          return+            ( maybe (computeFee ocFeeConstants fullForgedOpLength gasLimit) id mbFee+            , mExtra+            )+          )++      return (op, mReadySignedOp)++  let+    zipWith4NE+      :: (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d+      -> NonEmpty e+    zipWith4NE f (a :| as) (b :| bs) (c :| cs) (d :| ds) =+      (f a b c d) :| zipWith4 f as bs cs ds+  -- These two lists must have the same length here.+  -- @opsToRun@ is constructed directly from @params@.+  -- The length of @results@ is checked in @getAppliedResults@.+  (updOps, readySignedOps) <- fmap NE.unzip . sequenceA $+    zipWith4NE updateOp opsToRun mbFees results (True :| repeat False)++  -- Forge operation with given limits and get its hexadecimal representation+  (signature', signedOp) <- case readySignedOps of+    -- Save one forge + sign call pair in case of one operation+    Just readyOp :| [] -> pure readyOp+    -- In case of batch we have to reforge the full operation+    _ -> forgeOp updOps >>= signForgedOp++  -- Operation still can fail due to insufficient gas or storage limit, so it's required+  -- to preapply it before injecting+  let preApplyOp = PreApplyOperation+        { paoProtocol = bcProtocol ocBlockConstants+        , paoBranch = ocLastBlockHash+        , paoContents = updOps+        , paoSignature = signature'+        }+  ars2 <- getAppliedResults (Right preApplyOp)+  case sing @runMode of+    SDryRun -> do+      let fees = flip map updOps $ \case+            Left (TransactionOperation commonData _ _ _) -> codFee commonData+            Right (OriginationOperation commonData _ _) -> codFee commonData+      return $ NE.zip ars2 fees+    SRealRun -> do+      operationHash <- injectOperation (HexJSONByteString signedOp)+      waitForOperation operationHash+      let contractAddrs = arOriginatedContracts <$> ars2+      opsRes <- forM (NE.zip operations contractAddrs) $ \case+        (Left _, []) ->+          return $ Left ()+        (Left _, addrs) -> do+          logInfo . T.strip $+            "The following contracts were originated during transactions: " +|+            listF addrs |+ ""+          return $ Left ()+        (Right _, []) ->+          throwM RpcOriginatedNoContracts+        (Right OriginationData{..}, [addr]) -> do+          logDebug $ "Saving " +| addr |+ " for " +| odName |+ "\n"+          rememberContract odReplaceExisting addr (AnAliasHint odName)+          alias <- getAlias $ AddressResolved addr+          logInfo $ "Originated contract: " <> pretty alias+          return $ Right addr+        (Right _, addrs@(_ : _ : _)) ->+          throwM $ RpcOriginatedMoreContracts addrs+      forM_ ars2 logStatistics+      return (operationHash, opsRes)+  where+    logStatistics :: AppliedResult -> m ()+    logStatistics ar = do+      let showTezosInt64 = show . unStringEncode+      logInfo $ "Consumed gas: " <> showTezosInt64 (arConsumedGas ar)+      logInfo $ "Storage size: " <> showTezosInt64 (arStorageSize ar)+      logInfo $ "Paid storage size diff: " <> showTezosInt64 (arPaidStorageDiff ar)++    prohibitContractSender :: Address -> Either TransactionData OriginationData -> m ()+    prohibitContractSender addr op = case (addr, op) of+      (KeyAddress _, _) -> pass+      (ContractAddress _, Left _) -> throwM $ ContractSender addr "transfer"+      (ContractAddress _, Right _) -> throwM $ ContractSender addr "origination"
+ src/Morley/Client/Action/Origination.hs view
@@ -0,0 +1,289 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Functions to originate smart contracts via @tezos-client@ and node RPC.+module Morley.Client.Action.Origination+  ( originateContract+  , originateContracts+  , originateUntypedContract+  -- Lorentz version+  , lOriginateContract+  , lOriginateContracts++  -- * Large originations+  , originateLargeContracts+  , originateLargeContract+  , originateLargeUntypedContract+  -- Lorentz version+  , lOriginateLargeContracts+  , lOriginateLargeContract++  -- Datatypes for batch originations+  , LOriginationData (..)+  , OriginationData (..)+  ) where++import Data.Default (def)+import qualified Lorentz as L+import Lorentz.Constraints+import Morley.Client.Action.Common+import Morley.Client.Action.Operation+import Morley.Client.Action.Origination.Large+import Morley.Client.Action.Transaction (runTransactions)+import Morley.Client.Logging+import Morley.Client.RPC.Class+import Morley.Client.RPC.Error+import Morley.Client.RPC.Types+import Morley.Client.TezosClient+import Morley.Michelson.TypeCheck (typeCheckContractAndStorage, typeCheckingWith)+import Morley.Michelson.Typed (Contract, IsoValue(..), SomeContractAndStorage(..), Value)+import Morley.Michelson.Typed.Scope+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address+import Morley.Tezos.Core+import Morley.Util.Exception++-- | Originate given contracts with given initial storages. Returns+-- operation hash (or @Nothing@ in case empty list was provided)+-- and originated contracts' addresses.+originateContracts+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => AddressOrAlias+  -> [OriginationData]+  -> m (Maybe OperationHash, [Address])+originateContracts sender originations = do+  (opHash, res) <- runOperations sender (Right <$> originations)+  return (opHash, fromOrigination <$> res)+  where+    fromOrigination = either (error "Unexpected transaction") id++-- | Originate single contract+originateContract+  :: forall m cp st env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     , StorageScope st+     , ParameterScope cp+     )+  => Bool+  -> AliasHint+  -> AddressOrAlias+  -> Mutez+  -> Contract cp st+  -> Value st+  -> Maybe Mutez+  -> m (OperationHash, Address)+originateContract odReplaceExisting odName sender' odBalance odContract odStorage odMbFee = do+  (hash, contracts) <- originateContracts sender' [OriginationData{..}]+  singleOriginatedContract hash contracts++-- | Originate a single untyped contract+originateUntypedContract+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => Bool+  -> AliasHint+  -> AddressOrAlias+  -> Mutez+  -> U.Contract+  -> U.Value+  -> Maybe Mutez+  -> m (OperationHash, Address)+originateUntypedContract replaceExisting name sender' balance uContract initialStorage mbFee = do+  SomeContractAndStorage contract storage <-+    throwLeft . pure . typeCheckingWith def $+      typeCheckContractAndStorage uContract initialStorage+  originateContract replaceExisting name sender' balance contract storage mbFee++-- | Lorentz version of 'originateContracts'+lOriginateContracts+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => AddressOrAlias+  -> [LOriginationData]+  -> m (Maybe OperationHash, [Address])+lOriginateContracts sender' originations =+  originateContracts sender' $ map convertLOriginationData originations++-- | Originate single Lorentz contract+lOriginateContract+  :: forall m cp st vd env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     , NiceStorage st+     , NiceParameterFull cp+     )+  => Bool+  -> AliasHint+  -> AddressOrAlias+  -> Mutez+  -> L.Contract cp st vd+  -> st+  -> Maybe Mutez+  -> m (OperationHash, Address)+lOriginateContract lodReplaceExisting lodName sender' lodBalance lodContract lodStorage lodMbFee = do+  (hash, contracts) <- lOriginateContracts sender' [LOriginationData{..}]+  singleOriginatedContract @m hash contracts++--------------------------------------------------------------------------------+-- Large Originations+--------------------------------------------------------------------------------++-- | Automated multi-step origination process for contracts that don't fit into+-- the origination limit. See "Morley.Client.Action.Origination.Large".+originateLargeContracts+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => AddressOrAlias+  -> [OriginationData]+  -> m (Maybe OperationHash, [Address])+originateLargeContracts sender' largeOriginations = do+  senderAddress <- resolveAddress sender'+  -- calculate large contract originators+  let originators = map mkLargeOriginationData largeOriginations+  -- originate them. Note: we use the operation hash from here even tho the+  -- large contracts are originated in another one, because those happen in+  -- several different transactions.+  (opHash, originatorsAddr) <- originateContracts sender' $+    map (mkLargeOriginatorData senderAddress) originators+  -- run all the transactions needed (for each large contract originator)+  -- Note: it is not possible to run these all at once, because the node won't+  -- accept a transaction batch where the sum of the storage cost is over 16k,+  -- so here we need to run them one by one.+  mapM_ (runTransactions senderAddress . (: [])) . concat $+    zipWith mkLargeOriginatorTransactions originatorsAddr originators+  -- get the addresses of the originated large contracts back from the originators+  -- and remember their addresses with their aliases+  originatedContracts <- zipWithM retrieveLargeContracts originatorsAddr largeOriginations+  return (opHash, originatedContracts)++-- | Originate a single large contract+originateLargeContract+  :: forall m cp st env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     , StorageScope st+     , ParameterScope cp+     )+  => Bool+  -> AliasHint+  -> AddressOrAlias+  -> Mutez+  -> Contract cp st+  -> Value st+  -> Maybe Mutez+  -> m (OperationHash, Address)+originateLargeContract odReplaceExisting odName sender' odBalance odContract odStorage odMbFee = do+  (hash, contracts) <- originateLargeContracts sender' [OriginationData{..}]+  singleOriginatedContract @m hash contracts++-- | Originate a single untyped large contract+originateLargeUntypedContract+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => Bool+  -> AliasHint+  -> AddressOrAlias+  -> Mutez+  -> U.Contract+  -> U.Value+  -> Maybe Mutez+  -> m (OperationHash, Address)+originateLargeUntypedContract replaceExisting name sender' balance uContract initialStorage mbFee = do+  SomeContractAndStorage contract storage <-+    throwLeft . pure . typeCheckingWith def $+      typeCheckContractAndStorage uContract initialStorage+  originateLargeContract replaceExisting name sender' balance contract storage mbFee++-- | Lorentz version of 'originateLargeContracts'+lOriginateLargeContracts+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => AddressOrAlias+  -> [LOriginationData]+  -> m (Maybe OperationHash, [Address])+lOriginateLargeContracts sender' originations =+  originateLargeContracts sender' $ map convertLOriginationData originations++-- | Originate a single large Lorentz contract+lOriginateLargeContract+  :: forall m cp st vd env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     , NiceStorage st+     , NiceParameterFull cp+     )+  => Bool+  -> AliasHint+  -> AddressOrAlias+  -> Mutez+  -> L.Contract cp st vd+  -> st+  -> Maybe Mutez+  -> m (OperationHash, Address)+lOriginateLargeContract lodReplaceExisting lodName sender' lodBalance lodContract lodStorage lodMbFee = do+  (hash, contracts) <- lOriginateLargeContracts sender' [LOriginationData{..}]+  singleOriginatedContract @m hash contracts++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++-- | Lorentz version of 'OriginationData'+data LOriginationData = forall cp st vd. (NiceParameterFull cp, NiceStorage st)+  => LOriginationData+  { lodReplaceExisting :: Bool+  , lodName :: AliasHint+  , lodBalance :: Mutez+  , lodContract :: L.Contract cp st vd+  , lodStorage :: st+  , lodMbFee :: Maybe Mutez+  }++convertLOriginationData :: LOriginationData -> OriginationData+convertLOriginationData LOriginationData {..} = case lodContract of+  (_ :: L.Contract cp st vd) ->+    withDict (niceStorageEvi @st) $+      withDict (niceParameterEvi @cp) $ OriginationData+        { odReplaceExisting = lodReplaceExisting+        , odName = lodName+        , odBalance = lodBalance+        , odContract = L.toMichelsonContract lodContract+        , odStorage = toVal lodStorage+        , odMbFee = lodMbFee+        }++-- | Checks that the origination result for a single contract is indeed one.+singleOriginatedContract+  :: forall m. HasTezosRpc m+  => Maybe OperationHash -> [Address]+  -> m (OperationHash, Address)+singleOriginatedContract mbHash contracts = case contracts of+  [addr] -> case mbHash of+    Just hash -> return (hash, addr)+    Nothing -> throwM $ RpcOriginatedNoContracts+  _ ->  throwM $ RpcOriginatedMoreContracts contracts
+ src/Morley/Client/Action/Origination/Large.hs view
@@ -0,0 +1,280 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- TODO: ideally the "originator" contract would be the same for every large+-- contract, but due to a bug (tezos/tezos/1154) we cannot push @big_map@s right+-- before calling @CREATE_CONTRACT@, so we have to store those in the originator.+-- When that bug gets fixed we should reconsider changing the implementation.++-- | Functions to originate large smart contracts via @tezos-client@ and node RPC.+--+-- This is based on a workaround leveraging the lack of gas cost limits on+-- internal transactions produced by @CREATE_CONTRACT@.+--+-- So, in brief, we cannot directly originate a contract that's too large, but+-- we can originate a small "originator" contract, progressively load a packed+-- lambda into it in chunks and finally unpack and execute it, which will+-- run the actual large contract origination.+module Morley.Client.Action.Origination.Large+  ( LargeOriginationData (..)+  , SomeLargeContractOriginator (..)+  , mkLargeOriginationData+  , mkSomeLargeContractOriginator++    -- * Originator contract+  , LargeOriginatorParam+  , LargeOriginatorStore+  , largeContractOriginator++    -- * Origination lambda+  , divideValueInChunks+  , mkOriginationLambda++    -- * Utilities+  , mkLargeOriginatorStore+  , mkLargeOriginatorData+  , mkLargeOriginatorTransactions+  , retrieveLargeContracts+  ) where++import Prelude hiding (concat, drop, swap)++import qualified Data.ByteString.Lazy as LBS++import Lorentz+import Morley.Client.Action.Common+import Morley.Client.RPC.Class+import Morley.Client.RPC.Error+import Morley.Client.RPC.Getters (getContractStorage)+import Morley.Client.TezosClient+import Morley.Micheline (fromExpression)+import Morley.Michelson.Interpret.Pack (packValue)+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Instr+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Typed.Util (PushableStorageSplit(..), splitPushableStorage)+import Morley.Michelson.Typed.Value+import Morley.Michelson.Untyped.Annotation (annQ, noAnn)++-- | Just a utility type to hold 'SomeLargeContractOriginator' and its large+-- contract 'OriginationData'.+data LargeOriginationData = LargeOriginationData+  { largeOriginator :: SomeLargeContractOriginator+  , largeContractData :: OriginationData+  }++-- | Contains the 'Value heavy' with all the large contract @big_map@s+-- and @ticket@s, the 'largeContractOriginator' for it as well as the lambda+-- to use there.+data SomeLargeContractOriginator where+  SomeLargeContractOriginator+    :: forall heavy. StorageScope heavy+    => Value heavy+    -> T.Contract LargeOriginatorParam (LargeOriginatorStore heavy)+    -> Value (ToT (Lambda (Value heavy) (Address, [Operation])))+    -> SomeLargeContractOriginator++mkLargeOriginationData :: OriginationData -> LargeOriginationData+mkLargeOriginationData largeContractData@OriginationData{..} = LargeOriginationData{..}+  where+    largeOriginator = mkSomeLargeContractOriginator odStorage odContract odBalance++mkSomeLargeContractOriginator+  :: (ParameterScope param, StorageScope store)+  => Value store -- ^ initial storage of the large contract+  -> T.Contract param store -- ^ large contract+  -> Mutez -- ^ balance to tranfer during contract creation+  -> SomeLargeContractOriginator+mkSomeLargeContractOriginator store largeContract xtzs =+  case splitPushableStorage store of+    ConstantStorage val ->+      let origContract = largeContractOriginator+          origLambda = mkOriginationLambda (DROP `Seq` PUSH val) largeContract xtzs+      in SomeLargeContractOriginator VUnit origContract origLambda++    PushableValueStorage instr ->+      let origContract = largeContractOriginator+          origLambda = mkOriginationLambda (DROP `Seq` instr) largeContract xtzs+      in SomeLargeContractOriginator VUnit origContract origLambda++    PartlyPushableStorage val instr ->+      let origContract = largeContractOriginator+          origLambda = mkOriginationLambda instr largeContract xtzs+      in SomeLargeContractOriginator val origContract origLambda+++--------------------------------------------------------------------------------+-- Originator contract+--------------------------------------------------------------------------------++-- | Parameter of the originator contract.+type LargeOriginatorParam = 'T.TOr 'T.TBytes 'T.TUnit++-- | Storage of the originator contract.+type LargeOriginatorStore heavy =+  'T.TPair 'T.TAddress ('T.TOr 'T.TAddress ('T.TPair 'T.TBytes heavy))++-- | Large Originator contract.+--+-- Only keeps track of the "owner" address and either+-- - the heavy entries and packed lambda to do the generation (if still loading), or+-- - the resulting address of the originated large contract.+--+-- If the large contract was originated any call will result in a failure containing+-- its address.+-- Any call from an address that's not the "owner" will result in a failure.+largeContractOriginator+  :: StorageScope heavy+  => T.Contract LargeOriginatorParam (LargeOriginatorStore heavy)+largeContractOriginator = T.Contract{..}+  where+    epsNotes = T.NTOr noAnn [annQ|load_lambda|] [annQ|run_lambda|] T.starNotes T.starNotes+    cParamNotes = fromRight T.starParamNotes $ T.mkParamNotes epsNotes noAnn++    stateNotes = T.NTOr noAnn [annQ|originated|] [annQ|loading|] T.starNotes T.starNotes+    cStoreNotes = T.NTPair noAnn [annQ|owner|] noAnn noAnn noAnn T.starNotes stateNotes++    cEntriesOrder = def++    cViews = def+    cCode =+      UNPAIR `Seq`+      -- make checks on the storage+      DIP+        ( UNPAIR `Seq` SWAP `Seq` IF_LEFT+            -- if the large contract has already been originated, fails with its address+            FAILWITH+            -- otherwise, check for the sender+            ( SWAP `Seq` DUP `Seq` SENDER `Seq` COMPARE `Seq` T.EQ `Seq` IF+                ( SWAP `Seq` UNPAIR )+                ( PUSH (VString [mt|sender is not originator owner|]) `Seq` FAILWITH )+            )+        ) `Seq`+      -- stack at this point:+      -- parameter : packed lambda : heavy : owner address : []+      IF_LEFT+        -- if still loading lambda just concat to the exising 'bytes'+        ( CONCAT `Seq` PAIR `Seq` RIGHT `Seq` NIL)+        -- otherwise extract and run the origination lambda+        ( DROP `Seq` UNPACK `Seq`+          IF_NONE+            ( PUSH (VString [mt|failed to unpack lambda|]) `Seq` FAILWITH )+            ( SWAP `Seq` EXEC `Seq` UNPAIR `Seq` LEFT `Seq` SWAP+            )+        ) `Seq`+      -- reconstruct the overall storage+      DIP (SWAP `Seq` PAIR) `Seq`+      -- pair with operations and return+      PAIR++--------------------------------------------------------------------------------+-- Origination lambda+--------------------------------------------------------------------------------++-- | Returns bytes that fit into transaction limits from 'mkOriginationLambda'.+--+-- Note: these have the original order, meaning they should be given to the+-- originator contract from last to first.+divideValueInChunks :: ConstantScope val => Value val -> [ByteString]+divideValueInChunks = divideInChunks . packValue++-- | Returns strict bytes chunks that fit into transaction limits of the input.+divideInChunks :: LByteString -> [ByteString]+divideInChunks bytes+  | LBS.null bytes = []+  | otherwise =+    -- Note: the size is quite a bit below 16k for safety:+    let (chunk, rest) = LBS.splitAt 14000 bytes+    in LBS.toStrict chunk : divideInChunks rest++-- | Generates the lambda to originate a large contract.+mkOriginationLambda+  :: (ParameterScope param, StorageScope store, StorageScope heavy)+  => Instr '[heavy] '[store] -- ^ instruction to recreate the initial storage+  -> 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 $+  instr `Seq` PUSH (VMutez xtzs) `Seq` NONE `Seq`+  CREATE_CONTRACT largeContract `Seq`+  NIL `Seq` SWAP `Seq` CONS `Seq` SWAP `Seq` PAIR+++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++-- | Helper to create a 'LargeOriginatorStore' 'Value'.+mkLargeOriginatorStore+  :: StorageScope heavy+  => Value heavy+  -> Address+  -> Value (LargeOriginatorStore heavy)+mkLargeOriginatorStore heavyVal owner =+  let vAddr = toVal owner in+  VPair (vAddr, VOr $ Right $ VPair (VBytes mempty, heavyVal))++-- | Makes 'OriginationData' of the 'largeContractOriginator' that will generate+-- the large contract of the given 'OriginationData' for the sender 'Address'.+mkLargeOriginatorData+  :: Address -> LargeOriginationData+  -> OriginationData+mkLargeOriginatorData sender' LargeOriginationData{..} = case largeOriginator of+  SomeLargeContractOriginator heavyVal origContract _origLambda -> OriginationData+    { odReplaceExisting = odReplaceExisting $ largeContractData+    , odName = "largeOriginator." <> odName largeContractData+    , odBalance = toMutez 0+    -- Note ^ we don't transfer any balance here, we instead do it as part of the+    -- last transaction (where it will be transferred to the large contract)+    , odContract = origContract+    , odStorage = mkLargeOriginatorStore heavyVal sender'+    , odMbFee = odMbFee largeContractData+    }++-- | Makes all the 'TransactionData' to feed the origination lambda into a+-- 'largeContractOriginator' from the 'Address' of the latter.+mkLargeOriginatorTransactions+  :: Address -> LargeOriginationData+  -> [TransactionData]+mkLargeOriginatorTransactions originatorAddr LargeOriginationData{..} =+  case largeContractData of+    OriginationData{..} -> case largeOriginator of+      SomeLargeContractOriginator _ _ origLambda ->+        let lambdaChunks = divideValueInChunks origLambda+            doRunLambda = TransactionData @'T.TUnit $ TD+              { tdReceiver = originatorAddr+              , tdAmount   = odBalance+              , tdEpName   = eprName $ Call @"run_lambda"+              , tdParam    = VUnit+              , tdMbFee    = odMbFee+              }+            mkLoadLambda bytes = TransactionData @'T.TBytes $ TD+              { tdReceiver = originatorAddr+              , tdAmount   = toMutez 0+              , tdEpName   = eprName $ Call @"load_lambda"+              , tdParam    = VBytes bytes+              , tdMbFee    = odMbFee+              }+        in foldl' (\lst bytes -> mkLoadLambda bytes : lst) [doRunLambda] lambdaChunks++-- | Fetches back the 'Address' of the large contract generated by a completed+-- 'largeContractOriginator' process.+--+-- It also uses the large contract 'OriginationData' to associate it to the+-- expected alias.+retrieveLargeContracts+  :: (HasTezosRpc m, HasTezosClient m)+  => Address -> OriginationData -> m Address+retrieveLargeContracts originatorAddr OriginationData{..} = do+  expr <- getContractStorage originatorAddr+  -- note: for simplicity here we convert the "wrong" value+  -- because we cannot convert from a value with a big_map in its *type*+  -- and also something went wrong if this has a big_map or ticket in its *value*+  let completedStore = fromExpression @(Value (LargeOriginatorStore 'T.TUnit)) expr+  case completedStore of+    Right (VPair (_, VOr (Left largeVAddr))) -> do+      let largeAddr = fromVal @Address largeVAddr+      rememberContract odReplaceExisting largeAddr (AnAliasHint odName)+      pure largeAddr+    _ -> throwM RpcOriginatedNoContracts
+ src/Morley/Client/Action/Transaction.hs view
@@ -0,0 +1,124 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ+-- | Functions to submit transactions via @tezos-client@ and node RPC.++module Morley.Client.Action.Transaction+  ( runTransactions+  , lRunTransactions++  -- * Transfer+  , transfer+  , lTransfer++  -- Datatypes for batch transactions+  , TD (..)+  , LTransactionData (..)+  , TransactionData (..)+  ) where++import Lorentz.Constraints+import Morley.Client.Action.Common+import Morley.Client.Action.Operation+import Morley.Client.Logging+import Morley.Client.RPC.Class+import Morley.Client.RPC.Error+import Morley.Client.RPC.Types+import Morley.Client.TezosClient.Class+import Morley.Client.TezosClient.Types+import qualified Morley.Michelson.Typed as T+import Morley.Michelson.Typed.Scope+import Morley.Michelson.Untyped.Entrypoints+import Morley.Tezos.Address+import Morley.Tezos.Core (Mutez)++-- | Perform sequence of transactions to the contract, each transactions should be+-- defined via @EntrypointParam t@. Returns operation hash and block in which+-- this operation appears or @Nothing@ in case empty list was provided.+runTransactions+  :: forall m env.+     ( HasTezosRpc m+     , HasTezosClient m+     , WithClientLog env m+     )+  => Address -> [TransactionData]+  -> m (Maybe OperationHash)+runTransactions sender transactions = do+  (opHash, _) <- runOperations (AddressResolved sender) (Left <$> transactions)+  return opHash++-- | Lorentz version of 'TransactionData'.+data LTransactionData where+  LTransactionData ::+    forall (t :: Type). NiceParameter t =>+    TD t -> LTransactionData++-- | Lorentz version of 'runTransactions'+lRunTransactions+  :: forall m env.+    ( HasTezosRpc m+    , HasTezosClient m+    , WithClientLog env m+    )+  => Address+  -> [LTransactionData]+  -> m (Maybe OperationHash)+lRunTransactions sender transactions =+  runTransactions sender $ map convertLTransactionData transactions+  where+    convertLTransactionData :: LTransactionData -> TransactionData+    convertLTransactionData (LTransactionData (TD {..} :: TD t))=+      withDict (niceParameterEvi @t) $+      TransactionData TD+      { tdReceiver = tdReceiver+      , tdEpName = tdEpName+      , tdAmount = tdAmount+      , tdParam = T.toVal tdParam+      , tdMbFee = tdMbFee+      }++transfer+  :: forall m t env.+    ( HasTezosRpc m+    , HasTezosClient m+    , WithClientLog env m+    , ParameterScope t+    )+  => Address+  -> Address+  -> Mutez+  -> EpName+  -> T.Value t+  -> Maybe Mutez+  -> m OperationHash+transfer from to amount epName param mbFee = do+  res <- runTransactions from $+    [TransactionData TD+      { tdReceiver = to+      , tdAmount = amount+      , tdEpName = epName+      , tdParam = param+      , tdMbFee = mbFee+      }+    ]+  case res of+    Just hash -> return hash+    _ -> throwM RpcNoOperationsRun++lTransfer+  :: forall m t env.+    ( HasTezosRpc m+    , HasTezosClient m+    , WithClientLog env m+    , NiceParameter t+    )+  => Address+  -> Address+  -> Mutez+  -> EpName+  -> t+  -> Maybe Mutez+  -> m OperationHash+lTransfer from to amount epName param mbFee =+  withDict (niceParameterEvi @t) $+    transfer from to amount epName (T.toVal param) mbFee
+ src/Morley/Client/App.hs view
@@ -0,0 +1,307 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Functions useful for implementing instances of type classes from this package.+-- Monads and actual instances are defined in separate modules.++module Morley.Client.App+  ( -- * RunClient+    runRequestAcceptStatusImpl+  , throwClientErrorImpl++  -- * HasTezosRpc+  , getBlockHashImpl+  , getCounterImpl+  , getBlockHeaderImpl+  , getBlockConstantsImpl+  , getBlockOperationsImpl+  , getProtocolParametersImpl+  , runOperationImpl+  , preApplyOperationsImpl+  , forgeOperationImpl+  , injectOperationImpl+  , getContractScriptImpl+  , getContractStorageAtBlockImpl+  , getContractBigMapImpl+  , getBigMapValueAtBlockImpl+  , getBigMapValuesAtBlockImpl+  , getBalanceImpl+  , getManagerKeyImpl+  , runCodeImpl+  , getChainIdImpl+  , getDelegateImpl++  -- * Timeouts and retries+  , retryOnTimeout+  , failOnTimeout+  , retryOnceOnTimeout+  , waitBeforeRetry+  , handleInvalidCounterRpc+  ) where++import Control.Concurrent (threadDelay)+import qualified Data.Aeson as Aeson+import qualified Data.Binary.Builder as Binary+import Data.List ((!!))+import Data.Text (isInfixOf)+import Fmt (Buildable(..), Builder, build, pretty, (+|), (|+))+import Network.HTTP.Types (Status(..), renderQuery)+import Servant.Client (ClientEnv, runClientM)+import Servant.Client.Core+  (ClientError(..), Request, RequestBody(..), RequestF(..), Response, ResponseF(..), RunClient)+import Servant.Client.Core.RunClient (runRequest)+import System.Random (randomRIO)+import UnliftIO (MonadUnliftIO)+import UnliftIO.Timeout (timeout)+import qualified Unsafe (fromIntegral)++import Morley.Client.Logging (WithClientLog, logDebug)+import Morley.Client.RPC+import qualified Morley.Client.RPC.API as API+import Morley.Micheline (Expression, TezosInt64, TezosNat, unTezosMutez)+import Morley.Tezos.Address (Address)+import Morley.Tezos.Core (ChainId, Mutez, parseChainId)+import Morley.Tezos.Crypto (KeyHash, PublicKey)+import Morley.Util.ByteString (HexJSONByteString)+import Morley.Util.Exception (throwLeft)++----------------+-- RunClient functions+----------------++runRequestAcceptStatusImpl ::+  (WithClientLog env m, MonadIO m, MonadThrow m) =>+  ClientEnv -> Maybe [Status] -> Request -> m Response+runRequestAcceptStatusImpl env _ req = do+  logRequest req+  response <- either throwClientErrorImpl pure =<<+    liftIO (runClientM (runRequest req) env)+  response <$ logResponse response++throwClientErrorImpl :: forall m a . MonadThrow m => ClientError -> m a+throwClientErrorImpl err = case err of+  FailureResponse _ resp+    | 500 <- statusCode (responseStatusCode resp) ->+      handleInternalError (responseBody resp)+  _ -> throwM err+  where+    -- In some cases RPC returns important useful errors as internal ones.+    -- We try to parse the response to a list of 'InternalError'.+    -- If we receive one 'InternalError', we throw it wrapped into+    -- 'ClientInternalError', that's what we observed in most obvious cases.+    -- If we receive more than one, we wrap them into 'UnexpectedInternalErrors'.+    handleInternalError :: LByteString -> m a+    handleInternalError body = case Aeson.decode @[InternalError] body of+      Nothing -> case Aeson.decode @[RunError] body of+        Nothing -> throwM err+        Just runErrs -> throwM $ RunCodeErrors runErrs+      Just [knownErr] -> throwM $ ClientInternalError knownErr+      Just errs -> throwM $ UnexpectedInternalErrors errs++----------------+-- HasTezosRpc functions+----------------++getBlockHashImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m Text+getBlockHashImpl = retryOnceOnTimeout ... API.getBlockHash API.nodeMethods++getCounterImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Address -> m TezosInt64+getCounterImpl = retryOnceOnTimeout ... API.getCounter API.nodeMethods++getBlockHeaderImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m BlockHeader+getBlockHeaderImpl = retryOnceOnTimeout ... API.getBlockHeader API.nodeMethods++getBlockConstantsImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m BlockConstants+getBlockConstantsImpl = retryOnceOnTimeout ... API.getBlockConstants API.nodeMethods++getBlockOperationsImpl :: (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m [[BlockOperation]]+getBlockOperationsImpl =+  retryOnceOnTimeout ... API.getBlockOperations API.nodeMethods++getProtocolParametersImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> m ProtocolParameters+getProtocolParametersImpl = retryOnceOnTimeout ... API.getProtocolParameters API.nodeMethods++runOperationImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> RunOperation -> m RunOperationResult+runOperationImpl = retryOnceOnTimeout ... API.runOperation API.nodeMethods++preApplyOperationsImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) =>+  BlockId -> [PreApplyOperation] -> m [RunOperationResult]+preApplyOperationsImpl =+  retryOnceOnTimeout ... API.preApplyOperations API.nodeMethods++forgeOperationImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) =>+  BlockId -> ForgeOperation -> m HexJSONByteString+forgeOperationImpl = retryOnceOnTimeout ... API.forgeOperation API.nodeMethods++injectOperationImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) =>+  HexJSONByteString -> m OperationHash+injectOperationImpl =+  failOnTimeout ... API.injectOperation API.nodeMethods++getContractScriptImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) =>+  BlockId -> Address -> m OriginationScript+getContractScriptImpl = retryOnceOnTimeout ... API.getScript API.nodeMethods++getContractStorageAtBlockImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) =>+  BlockId -> Address -> m Expression+getContractStorageAtBlockImpl =+  retryOnceOnTimeout ... API.getStorageAtBlock API.nodeMethods++getContractBigMapImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) =>+  BlockId -> Address -> GetBigMap -> m GetBigMapResult+getContractBigMapImpl = retryOnceOnTimeout ... API.getBigMap API.nodeMethods++getBigMapValueAtBlockImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) =>+  BlockId -> Natural -> Text -> m Expression+getBigMapValueAtBlockImpl =+  retryOnceOnTimeout ... API.getBigMapValueAtBlock API.nodeMethods++getBigMapValuesAtBlockImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) =>+  BlockId -> Natural -> Maybe Natural -> Maybe Natural -> m Expression+getBigMapValuesAtBlockImpl =+  retryOnceOnTimeout ... API.getBigMapValuesAtBlock API.nodeMethods++getBalanceImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Address -> m Mutez+getBalanceImpl =+  retryOnceOnTimeout ... fmap unTezosMutez ... API.getBalance API.nodeMethods++getDelegateImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Address -> m (Maybe KeyHash)+getDelegateImpl =+  retryOnceOnTimeout ... API.getDelegate API.nodeMethods++-- | Similar to 'API.getManagerKey', but retries once on timeout.+getManagerKeyImpl ::+  (RunClient m, MonadUnliftIO m, MonadCatch m) => BlockId -> Address -> m (Maybe PublicKey)+getManagerKeyImpl =+  retryOnceOnTimeout ... API.getManagerKey API.nodeMethods++runCodeImpl :: (RunClient m, MonadCatch m) => BlockId -> RunCode -> m RunCodeResult+runCodeImpl = API.runCode API.nodeMethods++getChainIdImpl :: (RunClient m, MonadCatch m) => m ChainId+getChainIdImpl = throwLeft $ parseChainId <$> API.getChainId API.nodeMethods++----------------+-- Logging of requests and responses+----------------++-- | Convert a bytestring to a string assuming this bytestring stores+-- something readable in UTF-8 encoding.+fromBS :: ConvertUtf8 Text bs => bs -> Text+fromBS = decodeUtf8++ppRequestBody :: RequestBody -> Builder+ppRequestBody = build .+  \case+    RequestBodyLBS lbs -> fromBS lbs+    RequestBodyBS bs -> fromBS bs+    RequestBodySource {} -> "<body is not in memory>"++-- | Pretty print a @servant@'s request.+-- Note that we print only some part of t'Request': method, request+-- path and query, request body. We don't print other things that are+-- subjectively less interesting such as HTTP version or media type.+-- But feel free to add them if you want.+ppRequest :: Request -> Builder+ppRequest Request {..} =+  fromBS requestMethod |+ " " +| fromBS (Binary.toLazyByteString requestPath)+  |+ fromBS (renderQuery True $ toList requestQueryString) |++  maybe mempty (mappend "\n" . ppRequestBody . fst) requestBody++logRequest :: WithClientLog env m => Request -> m ()+logRequest req = logDebug $ "RPC request: " +| ppRequest req |+ ""++-- | Pretty print a @servant@'s response.+-- Note that we print only status and body,+-- the rest looks not so interesting in our case.+--+-- If response is not human-readable text in UTF-8 encoding it will+-- print some garbage.  Apparently we don't make such requests for now.+ppResponse :: Response -> Builder+ppResponse Response {..} =+  statusCode responseStatusCode |+ " " +|+  fromBS (statusMessage responseStatusCode) |+ "\n" +|+  fromBS responseBody  |+ ""++logResponse :: WithClientLog env m => Response -> m ()+logResponse resp = logDebug $ "RPC response: " +| ppResponse resp |+ ""++----------------+-- Timeouts and retries+----------------++data TimeoutError = TimeoutError+  deriving stock Show++instance Buildable TimeoutError where+  build TimeoutError =+    "Timeout for action call was reached. Probably, something is wrong with \+    \testing environment."++instance Exception TimeoutError where+  displayException = pretty++-- | Helper function that retries a monadic action in case action hasn't succeed+-- in 'timeoutInterval'. In case retry didn't help, error that indicates+-- timeout is thrown.+retryOnTimeout :: (MonadUnliftIO m, MonadThrow m) => Bool -> m a -> m a+retryOnTimeout wasRetried action = do+  res <- timeout timeoutInterval action+  maybe (if wasRetried then throwM TimeoutError else retryOnTimeout True action)+    pure res++-- | Helper function that consider action failed in case of timeout,+-- because it's unsafe to perform some of the actions twice. E.g. performing two 'injectOperation'+-- action can lead to a situation when operation is injected twice.+failOnTimeout :: (MonadUnliftIO m, MonadThrow m) => m a -> m a+failOnTimeout = retryOnTimeout True++-- | Helper function that retries action once in case of timeout. If retry ended up with timeout+-- as well, action is considered failed. It's safe to retry read-only actions that don't update chain state+-- or @tezos-client@ config/environment.+retryOnceOnTimeout :: (MonadUnliftIO m, MonadThrow m) => m a -> m a+retryOnceOnTimeout = retryOnTimeout False++-- | Timeout for 'retryOnTimeout', 'retryOnceOnTimeout' and 'failOnTimeout' helpers in microseconds.+timeoutInterval :: Int+timeoutInterval = 120 * 1e6++-- | Wait for a reasonable amount of time before retrying an action that failed+-- due to invalid counter.+-- The waiting time depends on protocol parameters.+waitBeforeRetry :: (MonadIO m, HasTezosRpc m, WithClientLog env m) => m ()+waitBeforeRetry = do+  i <- liftIO $+    (blockAwaitAmounts !!) <$> randomRIO (0, length blockAwaitAmounts - 1)+  logDebug $ "Invalid counter error occurred, retrying the request after " <> show i <> " blocks"+  ProtocolParameters {..} <- getProtocolParameters+  -- Invalid counter error may occur in case we try to perform multiple operations+  -- from the same address. We should try to wait different amount of times before retry+  -- in case there are multiple actions failed with invalid counter error.+  liftIO $ threadDelay $ i * Unsafe.fromIntegral @TezosNat @Int ppMinimalBlockDelay * 1e6+  where+    blockAwaitAmounts :: [Int]+    blockAwaitAmounts = [1..5]++-- | Retry action if it failed due to invalid counter (already used one).+handleInvalidCounterRpc :: MonadThrow m => m a -> ClientRpcError -> m a+handleInvalidCounterRpc retryAction = \case+  ClientInternalError (CounterInThePast {}) -> retryAction+  ClientInternalError (Failure msg)+    | "Counter" `isInfixOf` msg && "already used for contract" `isInfixOf` msg ->+      retryAction+  anotherErr -> throwM anotherErr
+ src/Morley/Client/Env.hs view
@@ -0,0 +1,43 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Runtime environment for @morley-client@.++module Morley.Client.Env+  ( MorleyClientEnv' (..)++  -- * Lens+  , mceTezosClientL+  , mceLogActionL+  , mceSecretKeyL+  , mceClientEnvL+  ) where++import Control.Lens (lens)+import Morley.Util.Lens (makeLensesWith, postfixLFields)+import Servant.Client (ClientEnv)++import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519++import Morley.Client.Logging (ClientLogAction)+import Morley.Client.TezosClient.Types++-- | Runtime environment for morley client.+data MorleyClientEnv' m = MorleyClientEnv+  { mceTezosClient :: TezosClientEnv+  -- ^ Environment for @tezos-client@.+  , mceLogAction :: ClientLogAction m+  -- ^ Action used to log messages.+  , mceSecretKey :: Maybe Ed25519.SecretKey+  -- ^ Pass if you want to sign operations manually or leave it+  -- to tezos-client+  , mceClientEnv :: ClientEnv+  -- ^ Environment necessary to make HTTP calls.+  }++makeLensesWith postfixLFields ''MorleyClientEnv'++instance HasTezosClientEnv (MorleyClientEnv' m) where+  tezosClientEnvL =+    lens mceTezosClient (\mce tce -> mce { mceTezosClient = tce })
+ src/Morley/Client/Full.hs view
@@ -0,0 +1,117 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE InstanceSigs #-}++-- | Implementation of full-featured Morley client.++module Morley.Client.Full+  ( MorleyClientEnv+  , MorleyClientM+  , runMorleyClientM+  ) where++import Colog (HasLog(..), Message)+import Network.HTTP.Types (Status(..))+import Servant.Client.Core (Request, Response, RunClient(..))+import UnliftIO (MonadUnliftIO)++import Morley.Client.App+import Morley.Client.Env (MorleyClientEnv'(..))+import Morley.Client.RPC.Class+import Morley.Client.TezosClient.Class+import Morley.Client.TezosClient.Impl (TezosClientError(..))+import qualified Morley.Client.TezosClient.Impl as TezosClient+import Morley.Client.TezosClient.Types+import Morley.Tezos.Crypto (Signature(..))+import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519++type MorleyClientEnv = MorleyClientEnv' MorleyClientM++newtype MorleyClientM a = MorleyClientM+  { unMorleyClientM :: ReaderT MorleyClientEnv IO a }+  deriving newtype+    ( Functor, Applicative, Monad, MonadReader MorleyClientEnv+    , MonadIO, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO+    )++-- | 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 (retryInvalidCounter client)) env++instance HasLog MorleyClientEnv Message MorleyClientM where+  getLogAction = mceLogAction+  setLogAction action mce = mce { mceLogAction = action }++instance HasTezosClient MorleyClientM where+  signBytes senderAlias mbPassword opHash = retryOnceOnTimeout $ do+    env <- ask+    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+  -- This function doesn't perform any chain related operations with tezos-client,+  -- so @ECONNRESET@ cannot appear here+  getTezosClientConfig = do+    path <- tceTezosClientPath <$> view tezosClientEnvL+    mbDataDir <- tceMbTezosClientDataDir <$> view tezosClientEnvL+    liftIO $ TezosClient.getTezosClientConfig path mbDataDir+  genFreshKey = retryOnceOnTimeout ... TezosClient.genFreshKey+  genKey = failOnTimeout ... TezosClient.genKey+  -- Key revealing cannot be safely retried, so we're not trying to recover it+  -- from @ECONNRESET@.+  revealKey = failOnTimeout ... TezosClient.revealKey+  registerDelegate = failOnTimeout ... TezosClient.registerDelegate+  calcTransferFee = retryOnceOnTimeout ... TezosClient.calcTransferFee+  calcOriginationFee = retryOnceOnTimeout ... TezosClient.calcOriginationFee+  getKeyPassword = retryOnceOnTimeout . TezosClient.getKeyPassword++instance RunClient MorleyClientM where+  runRequestAcceptStatus :: Maybe [Status] -> Request -> MorleyClientM Response+  runRequestAcceptStatus statuses req = do+    env <- mceClientEnv <$> ask+    runRequestAcceptStatusImpl env statuses req+  throwClientError = throwClientErrorImpl++instance HasTezosRpc MorleyClientM where+  getBlockHash = getBlockHashImpl+  getCounterAtBlock = getCounterImpl+  getBlockHeader = getBlockHeaderImpl+  getBlockConstants = getBlockConstantsImpl+  getBlockOperations = getBlockOperationsImpl+  getProtocolParametersAtBlock = getProtocolParametersImpl+  runOperationAtBlock = runOperationImpl+  preApplyOperationsAtBlock = preApplyOperationsImpl+  forgeOperationAtBlock = forgeOperationImpl+  injectOperation = injectOperationImpl+  getContractScriptAtBlock = getContractScriptImpl+  getContractStorageAtBlock = getContractStorageAtBlockImpl+  getContractBigMapAtBlock = getContractBigMapImpl+  getBigMapValueAtBlock = getBigMapValueAtBlockImpl+  getBigMapValuesAtBlock = getBigMapValuesAtBlockImpl+  getBalanceAtBlock = getBalanceImpl+  getDelegateAtBlock = getDelegateImpl+  runCodeAtBlock = runCodeImpl+  getChainId = getChainIdImpl+  getManagerKeyAtBlock = getManagerKeyImpl++-- | Helper function that retries 'MorleyClientM' action in case of counter error.+retryInvalidCounter :: forall a. MorleyClientM a -> MorleyClientM a+retryInvalidCounter action = do+  action `catch` handleInvalidCounterRpc retryAction+         `catch` handleTezosClientError+  where+    handleTezosClientError :: TezosClientError -> MorleyClientM a+    handleTezosClientError = \case+      CounterIsAlreadyUsed _ _ -> retryAction+      anotherErr -> throwM anotherErr++    retryAction = waitBeforeRetry >> retryInvalidCounter action
+ src/Morley/Client/Init.hs view
@@ -0,0 +1,93 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Morley client initialization.+module Morley.Client.Init+  ( MorleyClientConfig (..)+  , mkMorleyClientEnv+  , mkLogAction++    -- * Lens+  , mccAliasPrefixL+  , mccEndpointUrlL+  , mccTezosClientPathL+  , mccMbTezosClientDataDirL+  , mccVerbosityL+  , mccSecretKeyL+  ) where++import Colog (cmap, fmtMessage, logTextStderr, msgSeverity)+import Colog.Core (Severity(..), filterBySeverity)+import Morley.Util.Lens+import Servant.Client (BaseUrl(..))+import System.Environment (lookupEnv)++import Morley.Client.Env+import Morley.Client.Logging (ClientLogAction, logFlush)+import Morley.Client.RPC.HttpClient+import Morley.Client.TezosClient.Impl (getTezosClientConfig)+import Morley.Client.TezosClient.Types+import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519++-- | 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+  -- ^ URL of tezos endpoint on which operations are performed+  , mccTezosClientPath :: FilePath+  -- ^ Path to @tezos-client@ binary through which operations are+  -- performed+  , mccMbTezosClientDataDir :: Maybe FilePath+  -- ^ Path to @tezos-client@ data directory.+  , mccVerbosity :: Word+  -- ^ Verbosity level. @0@ means that only important messages will be+  -- printed. The greater this value is, the more messages will be+  -- printed during execution. After some small unspecified limit+  -- increasing this value does not change anything.+  , mccSecretKey :: Maybe Ed25519.SecretKey+  -- ^ Custom secret key to use for signing.+  } deriving stock Show++makeLensesWith postfixLFields ''MorleyClientConfig++-- | Construct 'MorleyClientEnv'.+--+-- * @tezos-client@ path is taken from 'MorleyClientConfig', but can be+-- overridden using @MORLEY_TEZOS_CLIENT@ environment variable.+-- * Node data is taken from @tezos-client@ config and can be overridden+-- by 'MorleyClientConfig'.+-- * The rest is taken from 'MorleyClientConfig' as is.+mkMorleyClientEnv :: MonadIO m => MorleyClientConfig -> IO (MorleyClientEnv' m)+mkMorleyClientEnv MorleyClientConfig{..} = do+  envTezosClientPath <- lookupEnv "MORLEY_TEZOS_CLIENT"+  let tezosClientPath = fromMaybe mccTezosClientPath envTezosClientPath+  TezosClientConfig {..} <- getTezosClientConfig tezosClientPath mccMbTezosClientDataDir+  let+    endpointUrl = fromMaybe tcEndpointUrl mccEndpointUrl+    tezosClientEnv = TezosClientEnv+      { tceAliasPrefix = mccAliasPrefix+      , tceEndpointUrl = endpointUrl+      , tceTezosClientPath = tezosClientPath+      , tceMbTezosClientDataDir = mccMbTezosClientDataDir+      }++  clientEnv <- newClientEnv endpointUrl+  pure MorleyClientEnv+    { mceTezosClient = tezosClientEnv+    , mceLogAction = mkLogAction mccVerbosity+    , mceSecretKey = mccSecretKey+    , mceClientEnv = clientEnv+    }++-- | Make appropriate 'ClientLogAction' based on verbosity specified by the user.+mkLogAction :: MonadIO m => Word -> ClientLogAction m+mkLogAction verbosity =+  filterBySeverity severity msgSeverity (fmtMessage `cmap` logTextStderrFlush)+  where+    severity = case verbosity of+      0 -> Warning+      1 -> Info+      _ -> Debug+    logTextStderrFlush = logTextStderr <> logFlush stderr
+ src/Morley/Client/Logging.hs view
@@ -0,0 +1,42 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | A tiny abstraction layer over logging capability we use in @morley-client@.+--+-- We use the @co-log@ package and this module reduces direct+-- dependencies on @co-log@ making our code more resistant to logging+-- changes.++module Morley.Client.Logging+  ( ClientLogAction+  , WithClientLog+  , logDebug+  , logInfo+  , logWarning+  , logError+  , logException++  , logFlush+  ) where++-- Implicit import should be fine because it's a tiny re-export module.+import Colog+import System.IO (hFlush)++-- | 'LogAction' with fixed message parameter.+type ClientLogAction m = LogAction m Message++-- | A specialization of 'WithLog' constraint to the 'Message' type.+-- 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 <https://github.com/kowainik/co-log/pull/194>, 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 () #-}
+ src/Morley/Client/OnlyRPC.hs view
@@ -0,0 +1,181 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | An alternative implementation of @morley-client@ that does not require+-- @tezos-client@ and has some limitations because of that (not all methods+-- are implemented).++module Morley.Client.OnlyRPC+  ( MorleyOnlyRpcEnv (..)+  , mkMorleyOnlyRpcEnv++  , MorleyOnlyRpcM (..)+  , runMorleyOnlyRpcM+  ) where++import Colog (HasLog(..), Message)+import Control.Lens (at)+import qualified Data.Map.Strict as Map+import Fmt ((+|), (|+))+import Servant.Client (BaseUrl, ClientEnv)+import Servant.Client.Core (RunClient(..))+import UnliftIO (MonadUnliftIO)++import Morley.Client.App+import Morley.Client.Init+import Morley.Client.Logging (ClientLogAction)+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.Crypto (SecretKey, sign, toPublic)++----------------+-- Environment+----------------++-- | Environment used by 'MorleyOnlyRpcM'.+data MorleyOnlyRpcEnv = MorleyOnlyRpcEnv+  { moreLogAction :: ClientLogAction MorleyOnlyRpcM+  -- ^ Action used to log messages.+  , moreClientEnv :: ClientEnv+  -- ^ Environment necessary to make HTTP calls.+  , moreSecretKeys :: Map Address SecretKey+  -- ^ In-memory secret keys that can be used for signing.+  }++-- | Construct 'MorleyOnlyRpcEnv'.+--+-- * Full 'MorleyClientConfig' is not passed because we need just 2 things from it.+-- * Log action is built the same way as for t'Morley.Client.MorleyClientEnv'.+-- * All secret keys are passed as an argument.+mkMorleyOnlyRpcEnv ::+  [SecretKey] -> BaseUrl -> Word -> IO MorleyOnlyRpcEnv+mkMorleyOnlyRpcEnv secretKeys endpoint verbosity = do+  clientEnv <- newClientEnv endpoint+  pure MorleyOnlyRpcEnv+    { moreLogAction = mkLogAction verbosity+    , moreClientEnv = clientEnv+    , moreSecretKeys =+      Map.fromList $ map (\sk -> (mkKeyAddress (toPublic sk), sk)) secretKeys+    }++----------------+-- Monad+----------------++-- | Monad that implements 'HasTezosClient' and 'HasTezosRpc' classes and+-- can be used for high-level actions as an alternative to t'Morley.Client.MorleyClientM'.+newtype MorleyOnlyRpcM a = MorleyOnlyRpcM+  { unMorleyOnlyRpcM :: ReaderT MorleyOnlyRpcEnv IO a }+  deriving newtype+    ( Functor, Applicative, Monad, MonadReader MorleyOnlyRpcEnv+    , MonadIO, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO+    )++-- | 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++----------------+-- Exceptions+----------------++-- | This exception is thrown in methods that are completely unsupported.+data UnsupportedByOnlyRPC = UnsupportedByOnlyRPC Text+  deriving stock (Show, Eq)++instance Exception UnsupportedByOnlyRPC where+  displayException (UnsupportedByOnlyRPC method) =+    toString $ "Method '" <> method <> "' is not supported in only-RPC mode"++-- | This exception is thrown when something goes wrong in supported methods.+data MorleyOnlyRpcException = UnknownSecretKeyFor Address+  deriving stock (Show, Eq)++instance Exception MorleyOnlyRpcException where+  displayException = \case+    UnknownSecretKeyFor addr -> "Secret key is unknown for " +| addr |+ ""++----------------+-- Instances (implementation)+----------------++instance HasLog MorleyOnlyRpcEnv Message MorleyOnlyRpcM where+  getLogAction = moreLogAction+  setLogAction action mce = mce { moreLogAction = action }++-- [#652] We may implement more methods here if the need arises.+instance HasTezosClient MorleyOnlyRpcM where+  signBytes sender _password opHash = case sender of+    AddressAlias {} -> throwM $ UnsupportedByOnlyRPC "signBytes (AddressAlias _)"+    AddressResolved address -> do+      env <- ask+      case moreSecretKeys env ^. at address of+        Nothing -> throwM $ UnknownSecretKeyFor address+        Just secretKey -> liftIO $ sign secretKey opHash++  -- 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+  importKey = \_ _ _ -> pass++  -- We return a dummy value here, because this function is used in a lot of+  -- places and with an exception here it's not possible to send transactions.+  -- So be aware of this and do not rely on this value!+  -- TODO #652: consider using a `Map` instead+  getAlias _ = pure (mkAlias "MorleyOnlyRpc")++  -- Actions that are not supported and simply throw exceptions.+  genKey _ = throwM $ UnsupportedByOnlyRPC "genKey"+  genFreshKey _ = throwM $ UnsupportedByOnlyRPC "genFreshKey"+  revealKey _ _ = throwM $ UnsupportedByOnlyRPC "revealKey"+  resolveAddressMaybe _ = throwM $ UnsupportedByOnlyRPC "resolveAddressMaybe"+  getPublicKey _ = throwM $ UnsupportedByOnlyRPC "getPublicKey"+  registerDelegate _ _ = throwM $ UnsupportedByOnlyRPC "registerDelegate"+  getTezosClientConfig = throwM $ UnsupportedByOnlyRPC "getTezosClientConfig"+  calcTransferFee _ _ _ _ = throwM $ UnsupportedByOnlyRPC "calcTransferFee"+  calcOriginationFee _ = throwM $ UnsupportedByOnlyRPC "calcOriginationFee"++instance RunClient MorleyOnlyRpcM where+  runRequestAcceptStatus statuses req = do+    env <- moreClientEnv <$> ask+    runRequestAcceptStatusImpl env statuses req+  throwClientError = throwClientErrorImpl++instance HasTezosRpc MorleyOnlyRpcM where+  getBlockHash = getBlockHashImpl+  getCounterAtBlock = getCounterImpl+  getBlockHeader = getBlockHeaderImpl+  getBlockConstants = getBlockConstantsImpl+  getBlockOperations = getBlockOperationsImpl+  getProtocolParametersAtBlock = getProtocolParametersImpl+  runOperationAtBlock = runOperationImpl+  preApplyOperationsAtBlock = preApplyOperationsImpl+  forgeOperationAtBlock = forgeOperationImpl+  injectOperation = injectOperationImpl+  getContractScriptAtBlock = getContractScriptImpl+  getContractStorageAtBlock = getContractStorageAtBlockImpl+  getContractBigMapAtBlock = getContractBigMapImpl+  getBigMapValueAtBlock = getBigMapValueAtBlockImpl+  getBigMapValuesAtBlock = getBigMapValuesAtBlockImpl+  getBalanceAtBlock = getBalanceImpl+  getDelegateAtBlock = getDelegateImpl+  runCodeAtBlock = runCodeImpl+  getChainId = getChainIdImpl+  getManagerKeyAtBlock = getManagerKeyImpl
+ src/Morley/Client/Parser.hs view
@@ -0,0 +1,270 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Client.Parser+  ( ClientArgs (..)+  , ClientArgsRaw (..)+  , OriginateArgs (..)+  , TransferArgs (..)+  , addressOrAliasOption+  , clientConfigParser+  , morleyClientInfo+  , parserInfo++  , originateArgsOption+  , mbContractFileOption+  , contractNameOption++    -- * Parser utilities+  , baseUrlReader+  ) where++import Options.Applicative+  (ReadM, eitherReader, help, long, metavar, option, short, strOption, subparser, value)+import qualified Options.Applicative as Opt+import Options.Applicative.Help.Pretty (Doc, linebreak)+import Servant.Client (BaseUrl(..), parseBaseUrl)++import Morley.CLI+import Morley.Client.Init+import Morley.Client.RPC.Types (BlockId(HeadId))+import Morley.Client.TezosClient.Types (AddressOrAlias, AliasHint)+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Core+import Morley.Util.CLI (mkCLOptionParser, mkCommandParser)+import Morley.Util.Named++data ClientArgs+  = ClientArgs MorleyClientConfig ClientArgsRaw++data ClientArgsRaw+  = Originate OriginateArgs+  | Transfer TransferArgs+  | GetBalance AddressOrAlias+  | GetBlockHeader BlockId+  | GetBlockOperations BlockId++data OriginateArgs = OriginateArgs+  { oaMbContractFile :: Maybe FilePath+  , oaContractName   :: AliasHint+  , oaInitialBalance :: Mutez+  , oaInitialStorage :: U.Value+  , oaOriginateFrom  :: AddressOrAlias+  , oaMbFee :: Maybe Mutez+  }++data TransferArgs = TransferArgs+  { taSender      :: AddressOrAlias+  , taDestination :: AddressOrAlias+  , taAmount      :: Mutez+  , taParameter   :: U.Value+  , taMbFee :: Maybe Mutez+  }++morleyClientInfo :: Opt.ParserInfo ClientArgs+morleyClientInfo =+  parserInfo+    (#usage :! usageDoc)+    (#description :! "Morley Client: RPC client for interaction with tezos node")+    (#header :! "Morley Client")+    (#parser :! clientParser)++-- | Parser for the @morley-client@ executable.+clientParser :: Opt.Parser ClientArgs+clientParser = ClientArgs <$> clientConfigParser (pure Nothing) <*> argsRawParser++clientConfigParser :: Opt.Parser (Maybe Text) -> Opt.Parser MorleyClientConfig+clientConfigParser prefixParser = do+  let mccSecretKey = Nothing+  mccAliasPrefix <- prefixParser+  mccEndpointUrl <- endpointOption+  mccTezosClientPath <- pathOption+  mccMbTezosClientDataDir <- dataDirOption+  mccVerbosity <- genericLength <$> many verboseSwitch+  pure MorleyClientConfig{..}+  where+    verboseSwitch :: Opt.Parser ()+    verboseSwitch = Opt.flag' () . mconcat $+      [ short 'V'+      , help "Increase verbosity (pass several times to increase further)"+      ]++-- | Parses URL of the Tezos node.+endpointOption :: Opt.Parser (Maybe BaseUrl)+endpointOption = optional . option baseUrlReader $+  long "endpoint"+  <> short 'E'+  <> help "URL of the remote Tezos node"+  <> metavar "URL"++pathOption :: Opt.Parser FilePath+pathOption = strOption $+  mconcat [ short 'I', long "client-path", metavar "PATH"+          , help "Path to tezos-client binary"+          , value "tezos-client"+          , Opt.showDefault+          ]++dataDirOption :: Opt.Parser (Maybe FilePath)+dataDirOption = optional $ strOption $+  mconcat [ short 'd', long "data-dir", metavar "PATH"+          , help "Path to tezos-client data directory"+          ]++feeOption :: Opt.Parser (Maybe Mutez)+feeOption = optional $ mutezOption+            Nothing+            (#name :! "fee")+            (#help :! "Fee that is going to be used for the transaction. \+                      \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+  -> "name" :! String+  -> "help" :! String+  -> Opt.Parser BlockId+blockIdOption = mkCLOptionParser++argsRawParser :: Opt.Parser ClientArgsRaw+argsRawParser = subparser $ mconcat+  [ originateCmd+  , transferCmd+  , getBalanceCmd+  , getBlockHeaderCmd+  , getBlockOperationsCmd+  ]+  where+    originateCmd =+      mkCommandParser "originate"+      (Originate <$> originateArgsOption)+      "Originate passed contract on real network"+    transferCmd =+      mkCommandParser "transfer"+      (Transfer <$> transferArgsOption)+      "Perform a transfer to the given contract with given amount and parameter"+    getBalanceCmd =+      mkCommandParser "get-balance"+      (GetBalance <$> addressOrAliasOption+        Nothing+        (#name :! "addr")+        (#help :! "Address or alias to get balance for.")+      )+      "Get balance for given address"+    getBlockHeaderCmd =+      mkCommandParser "get-block-header"+      (GetBlockHeader <$> blockIdOption+        (Just HeadId)+        (#name :! "block-id")+        (#help :! "Id of the block whose header will be queried.")+      )+      "Get header of a block"+    getBlockOperationsCmd =+      mkCommandParser "get-block-operations"+      (GetBlockOperations <$> blockIdOption+        (Just HeadId)+        (#name :! "block-id")+        (#help :! "Id of the block whose operations will be queried.")+      )+      "Get operations contained in a block"++originateArgsOption :: Opt.Parser OriginateArgs+originateArgsOption = do+  oaMbContractFile <- mbContractFileOption+  oaContractName <- contractNameOption+  oaInitialBalance <-+    mutezOption+      (Just (toMutez 0))+      (#name :! "initial-balance")+      (#help :! "Inital balance of the contract")+  oaInitialStorage <-+    valueOption+      Nothing+      (#name :! "initial-storage")+      (#help :! "Initial contract storage value")+  oaOriginateFrom <-+    addressOrAliasOption+      Nothing+      (#name :! "from")+      (#help :! "Address or alias of address from which origination is performed")+  oaMbFee <- feeOption+  pure $ OriginateArgs {..}++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+  [ long "contract-name"+  , value "stdin"+  , help "Alias of originated contract"+  ]++transferArgsOption :: Opt.Parser TransferArgs+transferArgsOption = do+  taSender <-+    addressOrAliasOption+      Nothing+      (#name :! "from")+      (#help :! "Address or alias from which transfer is performed")+  taDestination <-+    addressOrAliasOption+      Nothing+      (#name :! "to")+      (#help :! "Address or alias of the contract that receives transfer")+  taAmount <-+    mutezOption+      (Just (toMutez 0))+      (#name :! "amount")+      (#help :! "Transfer amount")+  taParameter <-+    valueOption+      Nothing+      (#name :! "parameter")+      (#help :! "Transfer parameter")+  taMbFee <- feeOption+  pure $ TransferArgs {..}++usageDoc :: Doc+usageDoc = mconcat+  [ "You can use help for specific COMMAND", linebreak+  , "EXAMPLE:", linebreak+  , "morley-client originate --help"+  , "USAGE EXAMPLE:", linebreak+  , "morley-client -E florence.testnet.tezos.serokell.team:8732 originate \\", linebreak+  , "  --from tz1akcPmG1Kyz2jXpS4RvVJ8uWr7tsiT9i6A \\", linebreak+  , "  --contract ../contracts/tezos_examples/attic/add1.tz --initial-balance 1 --initial-storage 0", linebreak+  , linebreak+  , "  This command will originate contract with code stored in add1.tz", linebreak+  , "  on real network with initial balance 1 and initial storage set to 0", linebreak+  , "  and return info about operation: operation hash and originated contract address", linebreak+  , linebreak+  , "morley-client -E florence.testnet.tezos.serokell.team:8732 transfer \\", linebreak+  , "  --from tz1akcPmG1Kyz2jXpS4RvVJ8uWr7tsiT9i6A \\", linebreak+  , "  --to KT1USbmjj6P2oJ54UM6HxBZgpoPtdiRSVABW --amount 1 --parameter 0", linebreak+  , linebreak+  , "  This command will perform tranfer to contract with address on real network", linebreak+  , "  KT1USbmjj6P2oJ54UM6HxBZgpoPtdiRSVABW with amount 1 and parameter 0", linebreak+  , "  as a result it will return operation hash"+  ]++--------------------------------------------------------------------------------+-- Parser utilities+--------------------------------------------------------------------------------++-- | Utility reader to use in parsing 'BaseUrl'.+baseUrlReader :: ReadM BaseUrl+baseUrlReader = eitherReader $ first show . parseBaseUrl
+ src/Morley/Client/RPC.hs view
@@ -0,0 +1,19 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Interface to node RPC (and its implementation).++module Morley.Client.RPC+  ( module Morley.Client.RPC.Class+  , module Morley.Client.RPC.Error+  , module Morley.Client.RPC.Getters+  , module Morley.Client.RPC.HttpClient+  , module Morley.Client.RPC.Types+  ) where++import Morley.Client.RPC.Class+import Morley.Client.RPC.Error+import Morley.Client.RPC.Getters+import Morley.Client.RPC.HttpClient+import Morley.Client.RPC.Types
+ src/Morley/Client/RPC/API.hs view
@@ -0,0 +1,175 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | This module contains servant types for tezos-node+-- RPC API.+module Morley.Client.RPC.API+  ( NodeMethods (..)+  , nodeMethods+  ) 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)++import Morley.Client.RPC.QueryFixedParam+import Morley.Client.RPC.Types+import Morley.Micheline (Expression, TezosInt64, TezosMutez)+import Morley.Tezos.Address (Address, formatAddress)+import Morley.Tezos.Crypto (KeyHash, PublicKey)+import Morley.Util.ByteString++-- We put an empty line after each endpoint to make it easier to+-- visually distinguish them.+type NodeAPI =+  "chains" :> "main" :> "blocks" :> (+    -- GET+    Capture "block_id" BlockId :> "hash" :> Get '[JSON] Text :<|>++    Capture "block_id" BlockId :> "context" :> "contracts" :> Capture "contract" Address'+      :> "counter" :> Get '[JSON] TezosInt64 :<|>++    Capture "block_id" BlockId :> "context" :> "contracts" :> Capture "contract" Address'+      :> "script" :> Get '[JSON] OriginationScript :<|>++    Capture "block_id" BlockId :> "context" :> "contracts" :> Capture "contract" Address'+      :> "storage" :> Get '[JSON] Expression :<|>++    Capture "block_id" BlockId :> Get '[JSON] BlockConstants :<|>++    Capture "block_id" BlockId :> "header" :> Get '[JSON] BlockHeader :<|>++    Capture "block_id" BlockId :> "context" :> "constants" :> Get '[JSON] ProtocolParameters :<|>++    Capture "block_id" BlockId :> "operations" :> Get '[JSON] [[BlockOperation]] :<|>++    -- 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+    -- seeks for key in it; if there are multiple big_maps with the same key type,+    -- only one of them is considered (which one - it seems better not to rely on+    -- this info).+    Capture "block_id" BlockId :> "context" :> "contracts" :> Capture "contract" Address'+      :> "big_map_get" :> ReqBody '[JSON] GetBigMap :> Post '[JSON] GetBigMapResult :<|>++    -- This endpoint supersedes the endpoint above.+    -- It takes a big_map ID instead of a contract ID, so it naturally supports+    -- contracts with multiple big maps.+    -- The 'script_expr' is the `Script-expression-ID-Hash` obtained by either:+    -- 1) calling `tezos-client hash data '123' of type int`.+    -- 2) or using 'Lorentz.Pack.valueToScriptExpr' and then base58 encode it.+    Capture "block_id" BlockId :> "context" :> "big_maps"+      :> Capture "big_map_id" Natural+      :> Capture "script_expr" Text+      :> Get '[JSON] Expression :<|>++    Capture "block_id" BlockId :> "context" :> "big_maps"+      :> Capture "big_map_id" Natural+      :> QueryParam "offset" Natural+      :> QueryParam "length" Natural+      :> Get '[JSON] Expression :<|>++    Capture "block_id" BlockId :> "context" :> "contracts"+      :> Capture "contract" Address' :> "balance" :> Get '[JSON] TezosMutez :<|>++    Capture "block_id" BlockId :> "context" :> "contracts"+      :> Capture "contract" Address' :> "delegate" :> Get '[JSON] KeyHash :<|>++    -- POST++    -- Turn a structured representation of an operation into a+    -- bytestring that can be submitted to the blockchain.+    Capture "block_id" BlockId :> "helpers" :> "forge" :> "operations"+      :> ReqBody '[JSON] ForgeOperation :> Post '[JSON] HexJSONByteString :<|>++    -- Run an operation without signature checks.+    Capture "block_id" BlockId :> "helpers" :> "scripts" :> "run_operation"+      :> ReqBody '[JSON] RunOperation :> Post '[JSON] RunOperationResult :<|>++    -- Simulate the validation of operations.+    Capture "block_id" BlockId :> "helpers" :> "preapply" :> "operations"+      :> ReqBody '[JSON] [PreApplyOperation] :> Post '[JSON] [RunOperationResult] :<|>++    -- 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)++    ) :<|>++  "chains" :> "main" :> "chain_id" :> Get '[JSON] Text :<|>++  -- Inject a previously forged and signed operation into a node and broadcast it.+  -- NOTE: we're hard-coding "chain" to "main" here for consistency with the rest+  -- of this definition+  "injection" :> "operation" :> QueryFixedParam "chain" "main"+    :> ReqBody '[JSON] HexJSONByteString+    :> Post '[JSON] OperationHash++nodeAPI :: Proxy NodeAPI+nodeAPI = Proxy++data NodeMethods m = NodeMethods+  { getBlockHash :: BlockId -> m Text+  , getCounter :: BlockId -> Address -> m TezosInt64+  , getScript :: BlockId -> Address -> m OriginationScript+  , getStorageAtBlock :: BlockId -> Address -> m Expression+  , getBlockConstants :: BlockId -> m BlockConstants+  , getBlockHeader :: BlockId -> m BlockHeader+  , getProtocolParameters :: BlockId -> m ProtocolParameters+  , getBlockOperations :: BlockId -> m [[BlockOperation]]+  , 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)+  , forgeOperation :: BlockId -> ForgeOperation -> m HexJSONByteString+  , runOperation :: BlockId -> RunOperation -> m RunOperationResult+  , preApplyOperations :: BlockId -> [PreApplyOperation] -> m [RunOperationResult]+  , runCode :: BlockId -> RunCode -> m RunCodeResult+  , getManagerKey :: BlockId -> Address -> m (Maybe PublicKey)+  , getChainId :: m Text+  , injectOperation :: HexJSONByteString -> m OperationHash+  }++nodeMethods :: forall m. (MonadCatch m, RunClient m) => NodeMethods m+nodeMethods = NodeMethods+  { getCounter        = withAddress' getCounter'+  , getScript         = withAddress' getScript'+  , getStorageAtBlock = withAddress' getStorageAtBlock'+  , getBigMap         = withAddress' getBigMap'+  , getBalance        = withAddress' getBalance'+  , getDelegate       = \block addr -> do+      result <- try $ getDelegate' block (Address' addr)+      case result of+        Left (FailureResponse _ Response{responseStatusCode=Status{statusCode = 404}})+          -> pure Nothing+        Left err -> throwM err+        Right res -> pure $ Just res+  , getManagerKey     = withAddress' getManagerKey'+  , ..+  }+  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)++----------------------------------------------------------------------------+-- Instances and helpers+----------------------------------------------------------------------------++-- | We use this wrapper to avoid orphan instances.+newtype Address' = Address'+  { unAddress' :: Address }++instance ToHttpApiData Address' where+  toUrlPiece = formatAddress . unAddress'
+ src/Morley/Client/RPC/Aeson.hs view
@@ -0,0 +1,20 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Helpers for the @aeson@ package.+--+-- Currently we need this module due to "GHC stage restriction".++module Morley.Client.RPC.Aeson+  ( morleyClientAesonOptions+  ) where++import Data.Aeson.Casing (aesonPrefix, snakeCase)+import Data.Aeson.TH (Options)++-- | We use these 'Options' to produce JSON encoding in the format+-- that RPC expects. We are not using defaults from @morley@ because+-- we need a specific format.+morleyClientAesonOptions :: Options+morleyClientAesonOptions = aesonPrefix snakeCase
+ src/Morley/Client/RPC/AsRPC.hs view
@@ -0,0 +1,745 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- TODO [#549]: remove this pragma+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | This module contains a type family for converting a type to its RPC representation,+-- and TemplateHaskell functions for deriving RPC representations for custom types.+module Morley.Client.RPC.AsRPC+  ( AsRPC+  , deriveRPC+  , deriveRPCWithStrategy+  , deriveManyRPC+  , deriveManyRPCWithStrategy+  -- * Conversions+  , valueAsRPC+  , notesAsRPC+  -- * Entailments+  , rpcSingIEvi+  , rpcHasNoOpEvi+  , rpcHasNoBigMapEvi+  , rpcHasNoNestedBigMapsEvi+  , rpcHasNoContractEvi+  , rpcStorageScopeEvi+  ) where++import Prelude hiding (Type)++import Control.Lens.Plated (universe)+import Data.Constraint (Dict(..), (***), (:-)(Sub), (\\))+import qualified Data.List as List ((\\))+import Data.Singletons (Sing, withSingI)+import qualified GHC.Generics as G+import Language.Haskell.TH+  (Con(InfixC, NormalC, RecC), Cxt, Dec(DataD, NewtypeD, TySynD, TySynInstD),+  DerivStrategy(AnyclassStrategy), Info(TyConI), Kind, Loc(loc_module), Name, Q, TyLit(StrTyLit),+  TySynEqn(..), TyVarBndr, Type(..), cxt, location, mkName, nameBase, reify, reifyInstances,+  standaloneDerivWithStrategyD)+import Language.Haskell.TH.ReifyMany (reifyManyTyCons)+import Language.Haskell.TH.ReifyMany.Internal (decConcreteNames)++import Lorentz hiding (TAddress, TSignature, drop, not)+import qualified Lorentz as L+import Lorentz.Extensible (Extensible)+import Morley.Michelson.Typed+  (ContractPresence(ContractAbsent), HasNoBigMap, HasNoContract, HasNoNestedBigMaps, HasNoOp,+  Notes(..), OpPresence(..), SingI(sing), SingT(..), StorageScope, T(..), Value'(..),+  checkContractTypePresence, checkOpPresence)+import Morley.Util.Named hiding (Name(..))+import Morley.Util.TH (isTypeAlias, lookupTypeNameOrFail)++{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}++----------------------------------------------------------------------------+-- AsRPC+----------------------------------------------------------------------------++-- | A type-level function that maps a type to its Tezos RPC representation.+--+-- For example, when we retrieve a contract's storage using the Tezos RPC, all its 'BigMap's will be replaced+-- by 'BigMapId's.+--+-- So if a contract has a storage of type @T@, when we call the Tezos RPC+-- to retrieve it, we must deserialize the micheline expression to the type @AsRPC T@.+--+-- > AsRPC (BigMap Integer MText) ~ BigMapId Integer MText+-- > AsRPC [BigMap Integer MText] ~ [BigMapId Integer MText]+-- > AsRPC (MText, (Address, BigMap Integer MText)) ~ (MText, (Address, BigMapId Integer MText))+--+-- The following law holds IFF a type @t@ has an IsoValue instance:+--+-- > ToT (AsRPC t) ~ AsRPC (ToT t)+--+type family AsRPC (a :: k) :: k++-- Value+type instance AsRPC (Value' instr t) = Value' instr (AsRPC t)+type instance AsRPC 'TKey = 'TKey+type instance AsRPC 'TUnit = 'TUnit+type instance AsRPC 'TSignature = 'TSignature+type instance AsRPC 'TChainId = 'TChainId+type instance AsRPC ('TOption t) = 'TOption (AsRPC t)+type instance AsRPC ('TList t) = 'TList (AsRPC t)+type instance AsRPC ('TSet t) = 'TSet t+type instance AsRPC 'TOperation = 'TOperation+type instance AsRPC ('TContract t) = 'TContract t+type instance AsRPC ('TTicket t) = 'TTicket t+type instance AsRPC ('TPair t1 t2) = 'TPair (AsRPC t1) (AsRPC t2)+type instance AsRPC ('TOr t1 t2) = 'TOr (AsRPC t1) (AsRPC t2)+type instance AsRPC ('TLambda t1 t2) = 'TLambda t1 t2+type instance AsRPC ('TMap k v) = 'TMap k (AsRPC v)+type instance AsRPC ('TBigMap _ _) = 'TNat+type instance AsRPC 'TInt = 'TInt+type instance AsRPC 'TNat = 'TNat+type instance AsRPC 'TString = 'TString+type instance AsRPC 'TBytes = 'TBytes+type instance AsRPC 'TMutez = 'TMutez+type instance AsRPC 'TBool = 'TBool+type instance AsRPC 'TKeyHash = 'TKeyHash+type instance AsRPC 'TTimestamp = 'TTimestamp+type instance AsRPC 'TAddress = 'TAddress+type instance AsRPC 'TNever = 'TNever+type instance AsRPC 'TBls12381Fr = 'TBls12381Fr+type instance AsRPC 'TBls12381G1 = 'TBls12381G1+type instance AsRPC 'TBls12381G2 = 'TBls12381G2+type instance AsRPC 'TChest = 'TChest+type instance AsRPC 'TChestKey = 'TChestKey++-- Morley types++-- Note: We don't recursively apply @AsRPC@ to @k@ or @v@ because+-- bigmaps cannot contain nested bigmaps.+-- If this constraint is ever lifted, we'll have to change this instance+-- to @BigMapId k (AsRPC v)@+type instance AsRPC (BigMap k v) = BigMapId k v+type instance AsRPC Integer = Integer+type instance AsRPC Natural = Natural+type instance AsRPC MText = MText+type instance AsRPC Bool = Bool+type instance AsRPC ByteString = ByteString+type instance AsRPC Mutez = Mutez+type instance AsRPC KeyHash = KeyHash+type instance AsRPC Timestamp = Timestamp+type instance AsRPC Address = Address+type instance AsRPC EpAddress = EpAddress+type instance AsRPC (L.TAddress p vd) = L.TAddress p vd+type instance AsRPC (FutureContract p) = FutureContract p+type instance AsRPC PublicKey = PublicKey+type instance AsRPC Signature = Signature+type instance AsRPC ChainId = ChainId+type instance AsRPC Never = Never+type instance AsRPC Bls12381Fr = Bls12381Fr+type instance AsRPC Bls12381G1 = Bls12381G1+type instance AsRPC Bls12381G2 = Bls12381G2+type instance AsRPC () = ()+type instance AsRPC [a] = [AsRPC a]+type instance AsRPC (Maybe a) = Maybe (AsRPC a)+type instance AsRPC (Either l r) = Either (AsRPC l) (AsRPC r)+type instance AsRPC (a, b) = (AsRPC a, AsRPC b)+type instance AsRPC (Set a) = Set a+type instance AsRPC (Map k v) = Map k (AsRPC v)+type instance AsRPC Operation = Operation+type instance AsRPC (Identity a) = Identity (AsRPC a)+type instance AsRPC (NamedF Identity a name) = NamedF Identity (AsRPC a) name+type instance AsRPC (NamedF Maybe a name) = NamedF Maybe (AsRPC a) name+type instance AsRPC (a, b, c) = (AsRPC a, AsRPC b, AsRPC c)+type instance AsRPC (a, b, c, d) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d)+type instance AsRPC (a, b, c, d, e) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d, AsRPC e)+type instance AsRPC (a, b, c, d, e, f) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d, AsRPC e, AsRPC f)+type instance AsRPC (a, b, c, d, e, f, g) = (AsRPC a, AsRPC b, AsRPC c, AsRPC d, AsRPC e, AsRPC f, AsRPC g)+type instance AsRPC (ContractRef arg) = ContractRef arg+type instance AsRPC Chest = Chest+type instance AsRPC ChestKey = ChestKey++-- Lorentz types+type instance AsRPC (Packed a) = Packed a+type instance AsRPC (L.TSignature a) = L.TSignature a+type instance AsRPC (Hash alg a) = Hash alg a+type instance AsRPC (L.TAddress cp) = L.TAddress cp+type instance AsRPC Empty = Empty+type instance AsRPC (Extensible x) = Extensible x+type instance AsRPC (View_ a r) = View_ a r+type instance AsRPC (Void_ a r) = Void_ a r+type instance AsRPC (UParam entries) = UParam entries+type instance AsRPC (inp :-> out) = inp :-> out+type instance AsRPC (ShouldHaveEntrypoints a) = ShouldHaveEntrypoints a+type instance AsRPC (ParameterWrapper deriv cp) = ParameterWrapper deriv (AsRPC cp)+type instance AsRPC L.OpenChest = L.OpenChest+type instance AsRPC (L.ChestT a) = L.ChestT a+type instance AsRPC (L.OpenChestT a) = L.OpenChestT a++----------------------------------------------------------------------------+-- Derive RPC repr+----------------------------------------------------------------------------++-- | Derive an RPC representation for a type, as well as instances for 'Generic', 'IsoValue' and 'AsRPC'.+--+-- > data ExampleStorage a b = ExampleStorage+-- >   { esField1 :: Integer+-- >   , esField2 :: [BigMap Integer MText]+-- >   , esField3 :: a+-- >   }+-- >   deriving stock Generic+-- >   deriving anyclass IsoValue+-- >+-- > deriveRPC "ExampleStorage"+--+-- Will generate:+--+-- > data ExampleStorageRPC a b = ExampleStorageRPC+-- >   { esField1RPC :: AsRPC Integer+-- >   , esField2RPC :: AsRPC [BigMap Integer MText]+-- >   , esField3RPC :: AsRPC a+-- >   }+-- >+-- > type instance AsRPC (ExampleStorage a b) = ExampleStorageRPC a b+-- > deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (ExampleStorageRPC a b)+-- > instance Generic (ExampleStorageRPC a b) where+-- >   ...+deriveRPC :: String -> Q [Dec]+deriveRPC typeStr = deriveRPCWithStrategy typeStr haskellBalanced++-- | Recursively enumerate @data@, @newtype@ and @type@ declarations,+-- and derives an RPC representation for each type that doesn't yet have one.+--+-- You can also pass in a list of types for which you _don't_ want+-- an RPC representation to be derived.+--+-- In this example, 'deriveManyRPC' will generate an RPC+-- representation for @A@ and @B@,+-- but not for @C@ (because we explicitly said we don't want one)+-- or @D@ (because it already has one).+--+-- > data B = B+-- > data C = C+-- > data D = D+-- > deriveRPC "D"+-- >+-- > data A = A B C D+-- > deriveManyRPC "A" ["C"]+deriveManyRPC :: String -> [String] -> Q [Dec]+deriveManyRPC typeStr skipTypes =+  deriveManyRPCWithStrategy typeStr skipTypes haskellBalanced++-- | Same as 'deriveManyRPC', but uses a custom strategy for deriving a 'Generic' instance.+deriveManyRPCWithStrategy :: String -> [String] -> GenericStrategy -> Q [Dec]+deriveManyRPCWithStrategy typeStr skipTypes gs = do+  skipTypeNames <- traverse lookupTypeNameOrFail skipTypes+  typeName <- lookupTypeNameOrFail typeStr+  whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'."+  allTypeNames <- findWithoutInstance typeName+  join <$> forM (allTypeNames List.\\ skipTypeNames) \name -> deriveRPCWithStrategy' name gs+  where++    -- | Recursively enumerate @data@, @newtype@ and @type@ declarations,+    -- and returns the names of only @data@ and @newtype@ of those that+    -- don't yet have an 'AsRPC' instance. Type aliases don't need instances+    -- and respectively there is no need to derive 'AsRPC' for them.+    findWithoutInstance :: Name -> Q [Name]+    findWithoutInstance typeName =+      fmap fst <$>+        reifyManyTyCons+          (\(name, dec) ->+            ifM (isTypeAlias name)+              (pure (False, decConcreteNames dec))+              (ifM (hasRPCInstance name)+                (pure (False, []))+                (pure (True, decConcreteNames dec)))+          )+          [typeName]++    hasRPCInstance :: Name -> Q Bool+    hasRPCInstance typeName = do+      deriveFullTypeFromName typeName >>= \case+        Nothing ->+          fail $ "Found a field with a type that is neither a 'data' nor a 'newtype' nor a 'type': "+            <> show typeName+        Just typ ->+          not . null <$> reifyInstances ''AsRPC [typ]++    -- | Given a type name, return the corresponding type expression+    -- (applied to any type variables, if necessary).+    --+    -- For example, assuming a data type like @data F a b = ...@ exists in the type environment,+    -- then @deriveFullTypeFromName ''F@ will return the type expression @[t|F a b|]@.+    --+    -- Note that only @data@, @newtype@ and @type@ declarations are supported at the moment.+    deriveFullTypeFromName :: Name -> Q (Maybe Type)+    deriveFullTypeFromName typeName = do+      typeInfo <- reify typeName+      case typeInfo of+        TyConI (DataD _ _ vars mKind _ _) -> Just <$> deriveFullType typeName mKind vars+        TyConI (NewtypeD _ _ vars mKind _ _) -> Just <$> deriveFullType typeName mKind vars+        TyConI (TySynD _ vars _) -> Just <$> deriveFullType typeName Nothing vars+        _ -> pure Nothing++-- | Same as 'deriveRPC', but uses a custom strategy for deriving a 'Generic' instance.+deriveRPCWithStrategy :: String -> GenericStrategy -> Q [Dec]+deriveRPCWithStrategy typeStr gs = do+  typeName <- lookupTypeNameOrFail typeStr+  whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'."+  deriveRPCWithStrategy' typeName gs++deriveRPCWithStrategy' :: Name -> GenericStrategy -> Q [Dec]+deriveRPCWithStrategy' typeName gs = do+  (_, decCxt, mKind, tyVars, constructors) <- reifyDataType typeName++  -- TODO: use `reifyInstances` to check that 'AsRPC' exists for `fieldType`+  -- Print user-friendly error msg if it doesn't.+  let typeNameRPC = convertName typeName+  constructorsRPC <- traverse convertConstructor constructors+  fieldTypesRPC <- getFieldTypes constructorsRPC++  derivedType <- deriveFullType typeName mKind tyVars+  derivedTypeRPC <- deriveFullType typeNameRPC mKind tyVars++  -- Note: we can't use `makeRep0Inline` to derive a `Rep` instance for `derivedTypeRPC`+  -- It internally uses `reify` to lookup info about `derivedTypeRPC`, and because `derivedTypeRPC` hasn't+  -- been spliced *yet*, the lookup fails.+  -- So, instead, we fetch the `Rep` instance for `derivedType`, and+  -- append "RPC" to the type/constructor/field names in its metadata.+  --+  -- If, for some reason, we find out that this approach doesn't work for some edge cases,+  -- we should get rid of it and patch the @generic-deriving@ package to export a version of `makeRep0Inline`+  -- that doesn't use `reify` (it should be easy enough).+  repInstance <- reifyRepInstance typeName derivedType+  currentModuleName <- loc_module <$> location+  let repTypeRPC = convertRep currentModuleName repInstance+  typeDecOfRPC <- mkTypeDeclaration typeName decCxt typeNameRPC tyVars mKind constructorsRPC++  mconcat <$> sequence+    [ pure . one $ typeDecOfRPC+    , mkAsRPCInstance derivedType derivedTypeRPC+    , mkIsoValueInstance fieldTypesRPC derivedTypeRPC+    , customGeneric' (Just repTypeRPC) typeNameRPC derivedTypeRPC constructorsRPC gs+    ]++  where+    -- | Given the field type @FieldType a b@, returns @AsRPC (FieldType a b)@.+    convertFieldType :: Type -> Type+    convertFieldType tp = ConT ''AsRPC `AppT` tp++    convertNameStr :: String -> String+    convertNameStr s = s <> "RPC"++    convertName :: Name -> Name+    convertName = mkName . convertNameStr . nameBase++    -- | Given the constructor+    -- @C { f :: Int }@,+    -- returns the constructor+    -- @CRPC { fRPC :: AsRPC Int }@.+    convertConstructor :: Con -> Q Con+    convertConstructor = \case+      RecC conName fields -> pure $+        RecC+          (convertName conName)+          (fields <&> \(fieldName, fieldBang, fieldType) ->+            (convertName fieldName, fieldBang, convertFieldType fieldType)+          )+      NormalC conName fields -> pure $+        NormalC (convertName conName) (second convertFieldType <$> fields)+      InfixC fieldType1 conName fieldType2 -> pure $+        InfixC (second convertFieldType fieldType1) (convertName conName) (second convertFieldType fieldType2)+      constr -> fail $ "Unsupported constructor for '" <> show typeName <> "': " <> show constr++    -- | Get a list of all the unique types of all the fields of all the given constructors.+    getFieldTypes :: [Con] -> Q [Type]+    getFieldTypes constrs = ordNub . join <$> forM constrs \case+      RecC _ fields -> pure $ fields <&> \(_, _, fieldType) -> fieldType+      NormalC _ fields -> pure $ snd <$> fields+      InfixC field1 _ field2 -> pure [snd field1, snd field2]+      constr -> fail $ "Unsupported constructor for '" <> show typeName <> "': " <> show constr++    mkTypeDeclaration :: Name -> Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> [Con] -> Q Dec+    mkTypeDeclaration tyName decCxt typeNameRPC tyVars mKind constructorsRPC = do+      typeInfo <- reify tyName+      case typeInfo of+        TyConI DataD {} -> pure $ DataD decCxt typeNameRPC tyVars mKind constructorsRPC []+        TyConI NewtypeD {} -> (case constructorsRPC of+          [con] -> pure $ NewtypeD decCxt typeNameRPC tyVars mKind con []+          _ -> fail "Newtype has only one constructor")+        _ -> fail $ "Only newtypes and data types are supported, but '" <>+          show tyName <> "' is:\n" <> show typeInfo++    -- | Traverse a 'Rep' type and:+    --+    -- 1. Inspect its metadata and append @RPC@ to the type/constructor/field names.+    -- 2. Convert field types (e.g. @T@ becomes @AsRPC T@).+    -- 3. Replace the Rep's module name with the name of the module of where this Q is being spliced.+    convertRep :: String -> TySynEqn -> Type+    convertRep currentModuleName (TySynEqn _tyVars _lhs rhs) = go rhs+      where+        go :: Type -> Type+        go = \case+          -- Rename type name and module name+          PromotedT t `AppT` LitT (StrTyLit tyName) `AppT` LitT (StrTyLit _moduleName)+            | t == 'G.MetaData+            -> PromotedT t `AppT` LitT (StrTyLit (convertNameStr tyName)) `AppT` LitT (StrTyLit currentModuleName)+          -- Rename constructor names+          PromotedT t `AppT` LitT (StrTyLit conName)+            | t == 'G.MetaCons+            -> PromotedT t `AppT` LitT (StrTyLit (convertNameStr conName))+          -- Rename field names+          PromotedT t `AppT` (PromotedT just `AppT` LitT (StrTyLit fieldName))+            | t == 'G.MetaSel+            -> PromotedT t `AppT` (PromotedT just `AppT` LitT (StrTyLit (convertNameStr fieldName)))+          -- Replace field type @T@ with @AsRPC T@+          ConT x `AppT` fieldType+            | x == ''G.Rec0+            -> ConT x `AppT` convertFieldType fieldType+          x `AppT` y -> go x `AppT` go y+          x -> x++    -- | Lookup the generic 'Rep' type instance for the given type.+    reifyRepInstance :: Name -> Type -> Q TySynEqn+    reifyRepInstance name tp =+      reifyInstances ''G.Rep [tp] >>= \case+        [TySynInstD repInstance] -> pure repInstance+        (_:_) -> fail $ "Found multiple instances of 'Generic' for '" <> show name <> "'."+        [] -> fail $ "Type '" <> show name <> "' must implement 'Generic'."++    -- | Given the type @Foo a b = Foo a@, generate an 'IsoValue' instance like:+    --+    -- > deriving anyclass instance IsoValue (AsRPC a) => IsoValue (FooRPC a b)+    --+    -- Note that if a type variable @t@ is a phantom type variable, then no @IsoValue (AsRPC t)@+    -- constraint is generated for it.+    mkIsoValueInstance :: [Type] -> Type -> Q [Dec]+    mkIsoValueInstance fieldTypes tp =+      one <$> standaloneDerivWithStrategyD (Just AnyclassStrategy) constraints [t|IsoValue $(pure tp)|]+      where+        constraints :: Q Cxt+        constraints =+          cxt $ filter hasTyVar fieldTypes <&> \fieldType ->+            [t|IsoValue $(pure fieldType)|]++        hasTyVar :: Type -> Bool+        hasTyVar ty =+          flip any (universe ty) \case+            VarT _ -> True+            _ -> False++    mkAsRPCInstance :: Type -> Type -> Q [Dec]+    mkAsRPCInstance tp tpRPC =+      [d|+        type instance AsRPC $(pure tp) = $(pure tpRPC)+      |]++----------------------------------------------------------------------------+-- Conversions+----------------------------------------------------------------------------++-- | Replace all big_maps in a value with the respective big_map IDs.+--+-- Throws an error if it finds a big_map without an ID.+valueAsRPC :: HasCallStack => Value t -> Value (AsRPC t)+valueAsRPC v =+  case v of+    VKey {} -> v+    VUnit {} -> v+    VSignature {} -> v+    VChainId {} -> v+    VChest {} -> v+    VChestKey {} -> v+    VOption (vMaybe :: Maybe (Value elem)) ->+      withDict (rpcSingIEvi @elem) $+        VOption $ valueAsRPC <$> vMaybe+    VList (vList :: [Value elem]) ->+      withDict (rpcSingIEvi @elem) $+        VList $ valueAsRPC <$> vList+    VSet {} -> v+    VOp {} -> v+    VContract {} -> v+    VTicket {} -> v+    VPair (x, y) -> VPair (valueAsRPC x, valueAsRPC y)+    VOr (vEither :: Either (Value l) (Value r)) ->+      withDict (rpcSingIEvi @l *** rpcSingIEvi @r) $+        case vEither of+          Right r -> VOr (Right (valueAsRPC r))+          Left l -> VOr (Left (valueAsRPC l))+    VLam {} -> v+    VMap (vMap :: Map (Value k) (Value v)) ->+      withDict (rpcSingIEvi @v) $+        VMap $ valueAsRPC <$> vMap+    VBigMap (Just bmId) _ -> VNat bmId+    VBigMap Nothing _ ->+      error $ unlines+        [ "Expected all big_maps to have an ID, but at least one big_map didn't."+        , "This is most likely a bug."+        ]+    VInt {} -> v+    VNat {} -> v+    VString {} -> v+    VBytes {} -> v+    VMutez {} -> v+    VBool {} -> v+    VKeyHash {} -> v+    VTimestamp {} -> v+    VAddress {} -> v+    VBls12381Fr {} -> v+    VBls12381G1 {} -> v+    VBls12381G2 {} -> v++-- | Replace all @big_map@ annotations in a value with @nat@ annotations.+notesAsRPC :: Notes t -> Notes (AsRPC t)+notesAsRPC notes =+  case notes of+    NTKey {} -> notes+    NTUnit {} -> notes+    NTSignature {} -> notes+    NTChainId {} -> notes+    NTChest {} -> notes+    NTChestKey {} -> notes+    NTOption typeAnn elemNotes -> NTOption typeAnn $ notesAsRPC elemNotes+    NTList typeAnn elemNotes -> NTList typeAnn $ notesAsRPC elemNotes+    NTSet {} -> notes+    NTOperation {} -> notes+    NTContract {} -> notes+    NTTicket {} -> notes+    NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 notes1 notes2 ->+      NTPair typeAnn fieldAnn1 fieldAnn2 varAnn1 varAnn2 (notesAsRPC notes1) (notesAsRPC notes2)+    NTOr typeAnn fieldAnn1 fieldAnn2 notes1 notes2 ->+      NTOr typeAnn fieldAnn1 fieldAnn2 (notesAsRPC notes1) (notesAsRPC notes2)+    NTLambda {} -> notes+    NTMap typeAnn keyAnns valueNotes -> NTMap typeAnn keyAnns (notesAsRPC valueNotes)+    NTBigMap typeAnn _ _ -> NTNat typeAnn+    NTInt {} -> notes+    NTNat {} -> notes+    NTString {} -> notes+    NTBytes {} -> notes+    NTMutez {} -> notes+    NTBool {} -> notes+    NTKeyHash {} -> notes+    NTTimestamp {} -> notes+    NTAddress {} -> notes+    NTBls12381Fr {} -> notes+    NTBls12381G1 {} -> notes+    NTBls12381G2 {} -> notes+    NTNever {} -> notes++----------------------------------------------------------------------------+-- Entailments+----------------------------------------------------------------------------++-- | A proof that if a singleton exists for @t@,+-- then so it does for @AsRPC t@.+rpcSingIEvi :: forall (t :: T). SingI t :- SingI (AsRPC t)+rpcSingIEvi =+  Sub $+    case sing @t of+      STKey -> Dict+      STUnit {} -> Dict+      STSignature {} -> Dict+      STChainId {} -> Dict+      STChest {} -> Dict+      STChestKey {} -> Dict+      STOption (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem+      STList (s :: Sing elem) -> withSingI s $  Dict \\ rpcSingIEvi @elem+      STSet (s :: Sing elem) -> withSingI s $ Dict \\ rpcSingIEvi @elem+      STOperation {} -> Dict+      STContract {} -> Dict+      STTicket {} -> Dict+      STPair (sa :: Sing a) (sb :: Sing b) ->+        withSingI sa $ withSingI sb $+          Dict \\ rpcSingIEvi @a \\ rpcSingIEvi @b+      STOr (sl :: Sing l) (sr :: Sing r) ->+        withSingI sl $ withSingI sr $+          Dict \\ rpcSingIEvi @l \\ rpcSingIEvi @r+      STLambda {} -> Dict+      STMap (sk :: Sing k) (sv :: Sing v) ->+        withSingI sk $ withSingI sv $+          Dict \\ rpcSingIEvi @k \\ rpcSingIEvi @v+      STBigMap {} -> Dict+      STInt {} -> Dict+      STNat {} -> Dict+      STString {} -> Dict+      STBytes {} -> Dict+      STMutez {} -> Dict+      STBool {} -> Dict+      STKeyHash {} -> Dict+      STBls12381Fr {} -> Dict+      STBls12381G1 {} -> Dict+      STBls12381G2 {} -> Dict+      STTimestamp {} -> Dict+      STAddress {} -> Dict+      STNever {} -> Dict++-- | A proof that if @t@ does not contain any operations, then neither does @AsRPC t@.+rpcHasNoOpEvi :: forall (t :: T). (SingI t, HasNoOp t) => HasNoOp t :- HasNoOp (AsRPC t)+rpcHasNoOpEvi = rpcHasNoOpEvi' sing++rpcHasNoOpEvi'+  :: HasNoOp t+  => Sing t+  -> HasNoOp t :- HasNoOp (AsRPC t)+rpcHasNoOpEvi' sng = Sub $ case sng of+  STKey -> Dict+  STUnit {} -> Dict+  STSignature {} -> Dict+  STChainId {} -> Dict+  STChest {} -> Dict+  STChestKey {} -> Dict+  STOption s -> Dict \\ rpcHasNoOpEvi' s+  STList s -> Dict \\ rpcHasNoOpEvi' s+  STSet s -> Dict \\ rpcHasNoOpEvi' s+  STContract {} -> Dict+  STTicket {} -> Dict+  STPair sa sb -> case checkOpPresence sa of+    OpAbsent -> Dict \\ rpcHasNoOpEvi' sa \\ rpcHasNoOpEvi' sb+  STOr sl sr -> case checkOpPresence sl of+    OpAbsent -> Dict \\ rpcHasNoOpEvi' sl \\ rpcHasNoOpEvi' sr+  STLambda {} -> Dict+  STMap _ sv -> case checkOpPresence sv of+    OpAbsent -> Dict \\ rpcHasNoOpEvi' sv+  STBigMap {} -> Dict+  STInt {} -> Dict+  STNat {} -> Dict+  STString {} -> Dict+  STBytes {} -> Dict+  STMutez {} -> Dict+  STBool {} -> Dict+  STKeyHash {} -> Dict+  STBls12381Fr {} -> Dict+  STBls12381G1 {} -> Dict+  STBls12381G2 {} -> Dict+  STTimestamp {} -> Dict+  STAddress {} -> Dict+  STNever {} -> Dict++-- | A proof that @AsRPC (Value t)@ does not contain big_maps.+rpcHasNoBigMapEvi :: forall (t :: T). SingI t => Dict (HasNoBigMap (AsRPC t))+rpcHasNoBigMapEvi = rpcHasNoBigMapEvi' (sing @t)++rpcHasNoBigMapEvi' :: Sing t -> Dict (HasNoBigMap (AsRPC t))+rpcHasNoBigMapEvi' = \case+  STKey -> Dict+  STUnit {} -> Dict+  STSignature {} -> Dict+  STChainId {} -> Dict+  STChest {} -> Dict+  STChestKey {} -> Dict+  STOption s -> Dict \\ rpcHasNoBigMapEvi' s+  STList s -> Dict \\ rpcHasNoBigMapEvi' s+  STSet s -> Dict \\ rpcHasNoBigMapEvi' s+  STOperation {} -> Dict+  STContract {} -> Dict+  STTicket {} -> Dict+  STPair sa sb -> Dict \\ rpcHasNoBigMapEvi' sa \\ rpcHasNoBigMapEvi' sb+  STOr sl sr -> Dict \\ rpcHasNoBigMapEvi' sl \\ rpcHasNoBigMapEvi' sr+  STLambda {} -> Dict+  STMap sk sv -> Dict \\ rpcHasNoBigMapEvi' sk \\ rpcHasNoBigMapEvi' sv+  STBigMap {} -> Dict+  STInt {} -> Dict+  STNat {} -> Dict+  STString {} -> Dict+  STBytes {} -> Dict+  STMutez {} -> Dict+  STBool {} -> Dict+  STKeyHash {} -> Dict+  STBls12381Fr {} -> Dict+  STBls12381G1 {} -> Dict+  STBls12381G2 {} -> Dict+  STTimestamp {} -> Dict+  STAddress {} -> Dict+  STNever {} -> Dict++-- | A proof that @AsRPC (Value t)@ does not contain big_maps.+rpcHasNoNestedBigMapsEvi+  :: forall (t :: T).+     SingI t+  => Dict (HasNoNestedBigMaps (AsRPC t))+rpcHasNoNestedBigMapsEvi = rpcHasNoNestedBigMapsEvi' (sing @t)++rpcHasNoNestedBigMapsEvi' :: Sing t -> Dict (HasNoNestedBigMaps (AsRPC t))+rpcHasNoNestedBigMapsEvi' = \case+  STKey -> Dict+  STUnit {} -> Dict+  STSignature {} -> Dict+  STChainId {} -> Dict+  STChest {} -> Dict+  STChestKey {} -> Dict+  STOption s -> Dict \\ rpcHasNoNestedBigMapsEvi' s+  STList s -> Dict \\ rpcHasNoNestedBigMapsEvi' s+  STSet s -> Dict \\ rpcHasNoNestedBigMapsEvi' s+  STOperation {} -> Dict+  STContract {} -> Dict+  STTicket {} -> Dict+  STPair sa sb ->+    Dict \\ rpcHasNoNestedBigMapsEvi' sa \\ rpcHasNoNestedBigMapsEvi' sb+  STOr sl sr ->+    Dict \\ rpcHasNoNestedBigMapsEvi' sl \\ rpcHasNoNestedBigMapsEvi' sr+  STLambda {} -> Dict+  STMap sk sv ->+    Dict \\ rpcHasNoNestedBigMapsEvi' sk \\ rpcHasNoNestedBigMapsEvi' sv+  STBigMap {} -> Dict+  STInt {} -> Dict+  STNat {} -> Dict+  STString {} -> Dict+  STBytes {} -> Dict+  STMutez {} -> Dict+  STBool {} -> Dict+  STKeyHash {} -> Dict+  STBls12381Fr {} -> Dict+  STBls12381G1 {} -> Dict+  STBls12381G2 {} -> Dict+  STTimestamp {} -> Dict+  STAddress {} -> Dict+  STNever {} -> Dict++-- | A proof that if @t@ does not contain any contract values, then neither does @AsRPC t@.+rpcHasNoContractEvi+  :: forall (t :: T).+     (SingI t, HasNoContract t)+  => HasNoContract t :- HasNoContract (AsRPC t)+rpcHasNoContractEvi = rpcHasNoContractEvi' sing++rpcHasNoContractEvi'+  :: HasNoContract t+  => Sing t+  -> HasNoContract t :- HasNoContract (AsRPC t)+rpcHasNoContractEvi' sng = Sub $ case sng of+  STKey -> Dict+  STUnit {} -> Dict+  STSignature {} -> Dict+  STChainId {} -> Dict+  STChest {} -> Dict+  STChestKey {} -> Dict+  STOption s -> Dict \\ rpcHasNoContractEvi' s+  STList s -> Dict \\ rpcHasNoContractEvi' s+  STSet _ -> Dict+  STOperation {} -> Dict+  STTicket {} -> Dict+  STPair sa sb -> case checkContractTypePresence sa of+    ContractAbsent ->+      Dict \\ rpcHasNoContractEvi' sa \\ rpcHasNoContractEvi' sb+  STOr sl sr -> case checkContractTypePresence sl of+    ContractAbsent ->+      Dict \\ rpcHasNoContractEvi' sl \\ rpcHasNoContractEvi' sr+  STLambda {} -> Dict+  STMap _ sv -> Dict \\ rpcHasNoContractEvi' sv+  STBigMap {} -> Dict+  STInt {} -> Dict+  STNat {} -> Dict+  STString {} -> Dict+  STBytes {} -> Dict+  STMutez {} -> Dict+  STBool {} -> Dict+  STKeyHash {} -> Dict+  STBls12381Fr {} -> Dict+  STBls12381G1 {} -> Dict+  STBls12381G2 {} -> Dict+  STTimestamp {} -> Dict+  STAddress {} -> Dict+  STNever {} -> Dict++-- | A proof that if @t@ is a valid storage type, then so is @AsRPC t@.+rpcStorageScopeEvi :: forall (t :: T). StorageScope t :- StorageScope (AsRPC t)+rpcStorageScopeEvi =+  Sub $ Dict+    \\ rpcSingIEvi @t+    \\ rpcHasNoOpEvi @t+    \\ rpcHasNoNestedBigMapsEvi @t+    \\ rpcHasNoContractEvi @t
+ src/Morley/Client/RPC/Class.hs view
@@ -0,0 +1,78 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | An abstraction layer over RPC implementation.+-- The primary reason it exists is to make it possible to mock+-- RPC in tests.++module Morley.Client.RPC.Class+  ( HasTezosRpc (..)+  ) where++import Morley.Tezos.Address+import Morley.Tezos.Core (ChainId, Mutez)+import Morley.Tezos.Crypto (KeyHash, PublicKey)+import Morley.Util.ByteString++import Morley.Client.RPC.Types+import Morley.Micheline (Expression, TezosInt64)++-- | Type class that provides interaction with tezos node via RPC+class (Monad m, MonadCatch m) => HasTezosRpc m where+  getBlockHash :: BlockId -> m Text+  -- ^ Get hash of the given 'BlockId', mostly used to get hash of+  -- 'HeadId'+  getCounterAtBlock :: BlockId -> Address -> m TezosInt64+  -- ^ Get address counter, which is required for both transaction sending+  -- and contract origination.+  getBlockHeader :: BlockId -> m BlockHeader+  -- ^ Get the whole header of a 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.+  getProtocolParametersAtBlock :: BlockId -> m ProtocolParameters+  -- ^ Get protocol parameters that are for limits calculations.+  runOperationAtBlock :: BlockId -> RunOperation -> m RunOperationResult+  -- ^ Perform operation run, this operation doesn't require proper signing.+  -- As a result it returns burned gas and storage diff (also list of originated+  -- contracts but their addresses are incorrect due to the fact that operation+  -- could be not signed properly) or indicates about operation failure.+  preApplyOperationsAtBlock :: BlockId -> [PreApplyOperation] -> m [RunOperationResult]+  -- ^ Preapply list of operations, each operation has to be signed with sender+  -- secret key. As a result it returns list of results each of which has information+  -- about burned gas, storage diff size and originated contracts.+  forgeOperationAtBlock :: BlockId -> ForgeOperation -> m HexJSONByteString+  -- ^ Forge operation in order to receive its hexadecimal representation.+  injectOperation :: HexJSONByteString -> m OperationHash+  -- ^ Inject operation, note that this operation has to be signed before+  -- injection. As a result it returns operation hash.+  getContractScriptAtBlock :: BlockId -> Address -> m OriginationScript+  -- ^ Get code and storage of the desired contract. Note that both code and storage+  -- are presented in low-level Micheline representation.+  -- If the storage contains a @big_map@, then the expression will contain the @big_map@'s ID,+  -- not its contents.+  getContractStorageAtBlock :: BlockId -> Address -> m Expression+  -- ^ Get storage of the desired contract at some block. Note that storage+  -- is presented in low-level Micheline representation.+  -- If the storage contains a @big_map@, then the expression will contain the @big_map@'s ID,+  -- not its contents.+  getContractBigMapAtBlock :: BlockId -> Address -> GetBigMap -> m GetBigMapResult+  -- ^ Get big map value by contract address.+  getBigMapValueAtBlock :: BlockId -> Natural -> Text -> m Expression+  -- ^ Get big map value at some block by the big map's ID and the hashed entry key.+  getBigMapValuesAtBlock :: BlockId -> Natural -> Maybe Natural -> Maybe Natural -> m Expression+  -- ^ Get all big map values at some block by the big map's ID and the optional offset and length.+  getBalanceAtBlock :: BlockId -> Address -> m Mutez+  -- ^ Get balance for given address.+  getDelegateAtBlock :: BlockId -> Address -> m (Maybe KeyHash)+  -- ^ Get delegate for given address.+  runCodeAtBlock :: BlockId -> RunCode -> m RunCodeResult+  -- ^ Emulate contract call. This RPC endpoint does the same as+  -- @tezos-client run script@ command does.+  getChainId :: m ChainId+  -- ^ Get current @ChainId@+  getManagerKeyAtBlock :: BlockId -> Address -> m (Maybe PublicKey)+  -- ^ Get manager key for given address.+  -- Returns @Nothing@ if this key wasn't revealed.
+ src/Morley/Client/RPC/Error.hs view
@@ -0,0 +1,138 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Various errors that can happen in the RPC part of @morley-client@.+module Morley.Client.RPC.Error+  ( ClientRpcError (..)+  , RunCodeErrors (..)+  , UnexpectedErrors (..)+  , IncorrectRpcResponse (..)+  ) where++import Fmt (Buildable(..), blockListF, pretty, (+|), (|+))+import qualified Text.Show (show)++import Morley.Micheline (Expression)+import Morley.Tezos.Address++import Morley.Client.RPC.Types++----------------------------------------------------------------------------+-- Caused by invalid user action+----------------------------------------------------------------------------++-- | Errors that can happen in the RPC part when a user tries to make+-- failing actions.+data ClientRpcError+  -- | Smart contract execution has failed.+  = ContractFailed+      Address -- ^ Smart contract address.+      Expression -- ^ Value the contract has failed with.++  | BadParameter+    -- ^ Parameter passed to a contract does not match its type.+      Address -- ^ Smart contract address.+      Expression -- ^ Value passed as parameter.+  | EmptyTransaction+    -- ^ Transfer of 0 to an implicit account.+      Address -- ^ Receiver address.+  | ShiftOverflow+    -- ^ A smart contract execution failed due to a shift overflow.+    Address+    -- ^ Smart contract address.+  | GasExhaustion+    -- ^ A smart contract execution failed due gas exhaustion.+    Address+    -- ^ Smart contract address.+  | ClientInternalError+    -- ^ An error that RPC considers internal occurred. These errors+    -- are considered internal by mistake, they are actually quite+    -- realistic and normally indicate bad user action. Currently we+    -- put 'InternalError' here as is, because it's easy for a user of+    -- @morley-client@ to work with this type. In #284 we will+    -- consider more errors and maybe some of them will need to be+    -- mapped into something more user-friendly, then we will+    -- reconsider this approach.+    InternalError+  deriving stock Show++instance Buildable ClientRpcError where+  build = \case+    ContractFailed addr expr ->+      "The execution of the smart contract " +| addr |++      " failed with " +| expr |+ ""+    BadParameter addr expr ->+      "Parameter " +| expr |+ " does not match the type of " +| addr |+ "."+    EmptyTransaction addr -> build (REEmptyTransaction addr)+    ShiftOverflow addr -> addr |+ " failed due to shift overflow"+    GasExhaustion addr -> addr |+ " failed due to gas exhaustion"+    ClientInternalError err -> build err++instance Exception ClientRpcError where+  displayException = pretty++-- | Errors that can happen during @run_code@ endpoint call.+-- These errors returned along with 500 code, so we have to handle+-- them a bit differently in comparison to other run errors that are+-- returned as a part of successful JSON response.+data RunCodeErrors = RunCodeErrors [RunError]+  deriving stock Show++instance Buildable RunCodeErrors where+  build (RunCodeErrors errs) = "'run_code' failed with the following errors: " +|+      blockListF errs |+ ""++instance Exception RunCodeErrors where+  displayException = pretty++----------------------------------------------------------------------------+-- Caused by unexpected node behavior or incorrect assumption in our code+----------------------------------------------------------------------------++-- | Errors that we don't expect to happen, but they can be reported+-- by the server.+data UnexpectedErrors+  = UnexpectedRunErrors [RunError]+  | UnexpectedInternalErrors [InternalError]++instance Buildable UnexpectedErrors where+  build = \case+    UnexpectedRunErrors errs ->+      "Preapply failed due to the following errors:\n" +|+      mconcat (map ((<> "\n\n") . build) errs) |+ ""+    UnexpectedInternalErrors errs ->+      "RPC failed with unexpected internal errors:\n" +|+      mconcat (map ((<> "\n\n") . build) errs) |+ ""++instance Show UnexpectedErrors where+  show = pretty++instance Exception UnexpectedErrors where+  displayException = pretty++-- | Errors that we can throw when we get a response from a node that+-- doesn't match our expectations. It means that either the node we+-- are talking to misbehaves or our code is incorrect.+data IncorrectRpcResponse+  = RpcUnexpectedSize Int Int+  | RpcOriginatedNoContracts+  | RpcNoOperationsRun+  | RpcOriginatedMoreContracts [Address]+  deriving stock Show++instance Buildable IncorrectRpcResponse where+  build = \case+    RpcUnexpectedSize expected got ->+      "An RPC call returned a list that has " +| got |++      " items, but we expected to get " +| expected |+ " results"+    RpcOriginatedMoreContracts addresses ->+      "Operation expected to originate one contract, but will more:\n" +|+      mconcat (map ((<> "\n") . build) addresses) |+ ""+    RpcOriginatedNoContracts ->+      "Operation expected to originate a contract, but produced nothing"+    RpcNoOperationsRun ->+      "No operations was run"++instance Exception IncorrectRpcResponse where+  displayException = pretty
+ src/Morley/Client/RPC/Getters.hs view
@@ -0,0 +1,267 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Some read-only actions (wrappers over RPC calls).++module Morley.Client.RPC.Getters+  ( ValueDecodeFailure (..)+  , ValueNotFound (..)++  , readAllBigMapValues+  , readAllBigMapValuesMaybe+  , readContractBigMapValue+  , readBigMapValueMaybe+  , readBigMapValue+  , getContract+  , getImplicitContractCounter+  , getContractsParameterTypes+  , getContractStorage+  , getBigMapValue+  , getBigMapValues+  , getHeadBlock+  , getCounter+  , getProtocolParameters+  , runOperation+  , preApplyOperations+  , forgeOperation+  , getContractScript+  , getContractBigMap+  , getBalance+  , getDelegate+  , runCode+  , getManagerKey+  ) where++import Data.Map as Map (fromList)+import Data.Singletons (demote)+import Fmt (Buildable(..), pretty, (+|), (|+))+import Network.HTTP.Types.Status (statusCode)+import Servant.Client (ClientError(..), responseStatusCode)+import qualified Text.Show++import Lorentz (NicePackedValue, NiceUnpackedValue, niceUnpackedValueEvi, valueToScriptExpr)+import Lorentz.Value+import Morley.Micheline+import Morley.Michelson.TypeCheck.TypeCheck+  (SomeParamType(..), TcOriginatedContracts, mkSomeParamType)+import Morley.Michelson.Typed+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address+import Morley.Tezos.Crypto (encodeBase58Check)+import Morley.Util.ByteString+import Morley.Util.Exception (throwLeft)++import Morley.Client.RPC.Class+import Morley.Client.RPC.Types++data ContractGetCounterAttempt = ContractGetCounterAttempt Address+instance Exception ContractGetCounterAttempt+instance Show ContractGetCounterAttempt where+  show = pretty+instance Buildable ContractGetCounterAttempt where+  build (ContractGetCounterAttempt addr) =+    "Failed to get counter of contract '" <> build addr <> "', " <>+    "this operation is allowed only for implicit contracts"++-- | Failed to decode received value to the given type.+data ValueDecodeFailure = ValueDecodeFailure Text T+instance Exception ValueDecodeFailure+instance Show ValueDecodeFailure where+  show = pretty+instance Buildable ValueDecodeFailure where+  build (ValueDecodeFailure desc ty) =+    "Failed to decode value with expected type " <> build ty <> " \+    \for '" <> build desc <> "'"++data ValueNotFound = ValueNotFound+instance Exception ValueNotFound+instance Show ValueNotFound where+  show = pretty+instance Buildable ValueNotFound where+  build ValueNotFound =+    "Value with such coordinates is not found in contract big maps"++-- | Read big_map value of given contract by key.+--+-- If the contract contains several @big_map@s with given key type, only one+-- of them will be considered.+readContractBigMapValue+  :: forall k v m.+     (PackedValScope k, HasTezosRpc m, SingI v)+  => Address -> Value k -> m (Value v)+readContractBigMapValue contract key = do+  let+    req = GetBigMap+      { bmKey = toExpression key+      , bmType = toExpression (demote @k)+      }+  res <- getContractBigMap contract req >>= \case+    GetBigMapResult res -> pure res+    GetBigMapNotFound -> throwM ValueNotFound+  fromExpression res+    & either (const $ throwM $ ValueDecodeFailure "big map value" (demote @k)) pure++-- | Read big_map value, given it's ID and a key.+-- If the value is not of the expected type, a 'ValueDecodeFailure' will be thrown.+--+-- Returns 'Nothing' if a big_map with the given ID does not exist,+-- or it does exist but does not contain the given key.+readBigMapValueMaybe+  :: forall v k m.+     (NicePackedValue k, NiceUnpackedValue v, HasTezosRpc m)+  => BigMapId k v -> k -> m (Maybe v)+readBigMapValueMaybe bigMapId key =+  handleStatusCode 404+    (pure Nothing)+    (Just <$> readBigMapValue bigMapId key)++-- | Read big_map value, given it's ID and a key.+-- If the value is not of the expected type, a 'ValueDecodeFailure' will be thrown.+readBigMapValue+  :: forall v k m.+     (NicePackedValue k, NiceUnpackedValue v, HasTezosRpc m)+  => BigMapId k v -> k -> m v+readBigMapValue (BigMapId bigMapId) key =+  getBigMapValue bigMapId scriptExpr >>= \expr ->+    withDict (niceUnpackedValueEvi @v) $+      case fromVal <$> fromExpression expr of+        Right v -> pure v+        Left _ -> throwM $ ValueDecodeFailure "big map value" (demote @(ToT k))+  where+    scriptExpr = encodeBase58Check $ valueToScriptExpr key++-- | Read all big_map values, given it's ID.+-- If the values are not of the expected type, a 'ValueDecodeFailure' will be thrown.+--+-- Returns 'Nothing' if a big_map with the given ID does not exist.+readAllBigMapValuesMaybe+  :: forall v k m.+     (NiceUnpackedValue v, HasTezosRpc m)+  => BigMapId k v -> m (Maybe [v])+readAllBigMapValuesMaybe bigMapId =+  handleStatusCode 404+    (pure Nothing)+    (Just <$> readAllBigMapValues bigMapId)++-- | Read all big_map values, given it's ID.+-- If the values are not of the expected type, a 'ValueDecodeFailure' will be thrown.+readAllBigMapValues+  :: forall v k m.+     (NiceUnpackedValue v, HasTezosRpc m)+  => BigMapId k v -> m [v]+readAllBigMapValues (BigMapId bigMapId) =+  getBigMapValues bigMapId Nothing Nothing >>= \expr ->+    withDict (niceUnpackedValueEvi @v) $+      case fromVal <$> fromExpression expr of+        Right v -> pure v+        Left _ -> throwM $ ValueDecodeFailure "big map value " (demote @(ToT v))++data ContractNotFound = ContractNotFound Address+  deriving stock Show++instance Buildable ContractNotFound where+  build (ContractNotFound addr) =+    "Smart contract " +| addr |+ " was not found"++instance Exception ContractNotFound where+  displayException = pretty++-- | Get originated t'U.Contract' for some address.+getContract :: (HasTezosRpc m) => Address -> m U.Contract+getContract addr =+  handleStatusCode 404 (throwM $ ContractNotFound addr) $+  throwLeft $ fromExpression . osCode <$> getContractScript addr++-- | Get counter value for given address.+--+-- Throws an error if given address is a contract address.+getImplicitContractCounter :: (HasTezosRpc m) => Address -> m TezosInt64+getImplicitContractCounter addr = case addr of+  KeyAddress _      -> getCounter addr+  ContractAddress _ -> throwM $ ContractGetCounterAttempt addr++handleStatusCode :: MonadCatch m => Int -> m a -> m a -> m a+handleStatusCode code onError action = action `catch`+  \case FailureResponse _ resp+          | statusCode (responseStatusCode resp) == code -> onError+        e -> throwM e++-- | Extract parameter types for all smart contracts' addresses and return mapping+-- from their hashes to their parameter types+getContractsParameterTypes+  :: HasTezosRpc m => [Address] -> m TcOriginatedContracts+getContractsParameterTypes addrs =+  Map.fromList <$> concatMapM (fmap maybeToList . extractParameterType) addrs+  where+    extractParameterType+      :: HasTezosRpc m => Address+      -> m (Maybe (ContractHash, SomeParamType))+    extractParameterType addr = case addr of+      KeyAddress _ -> return Nothing+      ContractAddress ch ->+        handleStatusCode 404 (return Nothing) $ do+          params <- fmap (U.contractParameter) . throwLeft $+              fromExpression @U.Contract . osCode <$> getContractScript addr+          (paramNotes :: SomeParamType) <- throwLeft $ pure $ mkSomeParamType params+          pure $ Just (ch, paramNotes)++-- | 'getContractStorageAtBlock' applied to the head block.+getContractStorage :: HasTezosRpc m => Address -> m Expression+getContractStorage = getContractStorageAtBlock HeadId++-- | 'getBigMapValueAtBlock' applied to the head block.+getBigMapValue :: HasTezosRpc m => Natural -> Text -> m Expression+getBigMapValue = getBigMapValueAtBlock HeadId++-- | 'getBigMapValuesAtBlock' applied to the head block.+getBigMapValues :: HasTezosRpc m => Natural -> Maybe Natural -> Maybe Natural -> m Expression+getBigMapValues = getBigMapValuesAtBlock HeadId++-- | Get hash of the current head block, this head hash is used in other+-- RPC calls.+getHeadBlock :: HasTezosRpc m => m Text+getHeadBlock = getBlockHash HeadId++-- | 'getCounterAtBlock' applied to the head block.+getCounter :: HasTezosRpc m => Address -> m TezosInt64+getCounter = getCounterAtBlock HeadId++-- | 'getProtocolParametersAtBlock' applied to the head block.+getProtocolParameters :: HasTezosRpc m => m ProtocolParameters+getProtocolParameters = getProtocolParametersAtBlock HeadId++-- | 'runOperationAtBlock' applied to the head block.+runOperation :: HasTezosRpc m => RunOperation -> m RunOperationResult+runOperation = runOperationAtBlock HeadId++-- | 'preApplyOperationsAtBlock' applied to the head block.+preApplyOperations :: HasTezosRpc m => [PreApplyOperation] -> m [RunOperationResult]+preApplyOperations = preApplyOperationsAtBlock HeadId++-- | 'forgeOperationAtBlock' applied to the head block.+forgeOperation :: HasTezosRpc m => ForgeOperation -> m HexJSONByteString+forgeOperation = forgeOperationAtBlock HeadId++-- | 'getContractScriptAtBlock' applied to the head block.+getContractScript :: HasTezosRpc m => Address -> m OriginationScript+getContractScript = getContractScriptAtBlock HeadId++-- | 'getContractBigMapAtBlock' applied to the head block.+getContractBigMap :: HasTezosRpc m => Address -> GetBigMap -> m GetBigMapResult+getContractBigMap = getContractBigMapAtBlock HeadId++-- | 'getBalanceAtBlock' applied to the head block.+getBalance :: HasTezosRpc m => Address -> m Mutez+getBalance = getBalanceAtBlock HeadId++-- | 'getDelegateAtBlock' applied to the head block.+getDelegate :: HasTezosRpc m => Address -> m (Maybe KeyHash)+getDelegate = getDelegateAtBlock HeadId++-- | 'runCodeAtBlock' applied to the head block.+runCode :: HasTezosRpc m => RunCode -> m RunCodeResult+runCode = runCodeAtBlock HeadId++getManagerKey :: HasTezosRpc m => Address -> m (Maybe PublicKey)+getManagerKey = getManagerKeyAtBlock HeadId
+ src/Morley/Client/RPC/HttpClient.hs view
@@ -0,0 +1,29 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Client.RPC.HttpClient+  ( newClientEnv+  ) where++import Network.HTTP.Client (ManagerSettings(..), Request(..), defaultManagerSettings, newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Servant.Client (BaseUrl(..), ClientEnv, Scheme(..), mkClientEnv)++-- | Make servant client environment from morley client config.+--+-- Note: Creating a new servant manager is a relatively expensive+-- operation, so this function is not supposed to be called often.+newClientEnv :: BaseUrl -> IO ClientEnv+newClientEnv endpointUrl = do+  manager' <- newManager $ case baseUrlScheme endpointUrl of+    Http  -> defaultManagerSettings{ managerModifyRequest = fixRequest }+    Https -> tlsManagerSettings{ managerModifyRequest = fixRequest }+  return $ mkClientEnv manager' endpointUrl++-- | Add header, required by the Tezos RPC interface+fixRequest :: Request -> IO Request+fixRequest req = return $+  req { requestHeaders = ("Content-Type", "application/json") :+        filter (("Content-Type" /=) . fst) (requestHeaders req)+      }
+ src/Morley/Client/RPC/QueryFixedParam.hs view
@@ -0,0 +1,27 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Client.RPC.QueryFixedParam+  ( QueryFixedParam+  ) where++import Servant.API (ToHttpApiData(toQueryParam), type (:>))+import Servant.Client.Core (HasClient(..), appendToQueryString)++import Morley.Util.TypeLits (KnownSymbol, Symbol, symbolValT')++-- | Like servant's @QueryParam@, but the value is fixed as a+-- type-level string.+data QueryFixedParam (name :: Symbol) (value :: Symbol)++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+    where+      pname = symbolValT' @sym+      pval  = symbolValT' @val+  hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+ src/Morley/Client/RPC/Types.hs view
@@ -0,0 +1,733 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | This module contains various types which are used in+-- tezos-node RPC API.+--+-- Documentation for RPC API can be found e. g. [here](http://tezos.gitlab.io/010/rpc.html)+-- (010 is the protocol, change to the desired one).+--+-- Note that errors are reported a bit inconsistently by RPC.+-- For more information see+-- [this question](https://tezos.stackexchange.com/q/2656/342)+-- and [this issue](https://gitlab.com/metastatedev/tezos/-/issues/150).+++module Morley.Client.RPC.Types+  ( AppliedResult (..)+  , BlockConstants (..)+  , BlockHash (..)+  , BlockHeaderNoHash (..)+  , BlockHeader (..)+  , FeeConstants (..)+  , BlockId (..)+  , BlockOperation (..)+  , CommonOperationData (..)+  , ForgeOperation (..)+  , GetBigMap (..)+  , GetBigMapResult (..)+  , InternalOperation (..)+  , OperationContent (..)+  , OperationHash (..)+  , OperationResp (..)+  , OperationResult (..)+  , OriginationOperation (..)+  , OriginationScript (..)+  , ParametersInternal (..)+  , PreApplyOperation (..)+  , ProtocolParameters (..)+  , RunCode (..)+  , RunCodeResult (..)+  , RunMetadata (..)+  , RunOperation (..)+  , RunOperationInternal (..)+  , RunOperationResult (..)+  , TransactionOperation (..)+  , combineResults+  , mkCommonOperationData++  -- * Errors+  , RunError (..)+  , InternalError (..)++  -- * Prisms+  , _RuntimeError+  , _ScriptRejected+  , _BadContractParameter+  , _InvalidConstant+  , _InconsistentTypes+  , _InvalidPrimitive+  , _InvalidSyntacticConstantError+  , _InvalidExpressionKind+  , _InvalidContractNotation+  , _UnexpectedContract+  , _IllFormedType+  , _UnexpectedOperation+  , _REEmptyTransaction+  , _ScriptOverflow+  , _GasExhaustedOperation++  -- * Lenses+  , toCommonDataL+  , ooCommonDataL+  ) where++import Control.Lens (makeLensesFor, makePrisms)+import Data.Aeson+  (FromJSON(..), Object, ToJSON(..), Value(..), object, omitNothingFields, withObject, (.!=), (.:),+  (.:?), (.=))+import Data.Aeson.TH (deriveFromJSON, deriveJSON, deriveToJSON)+import Data.Default (Default(..))+import Data.Fixed (Milli)+import Data.List (isSuffixOf)+import qualified Data.Text as T+import Data.Time (UTCTime)+import Data.Vector (fromList)+import Fmt (Buildable(..), pretty, (+|), (|+))+import Servant.API (ToHttpApiData(..))++import Data.Aeson.Types (Parser)+import Morley.Client.RPC.Aeson (morleyClientAesonOptions)+import Morley.Micheline+  (Expression(..), MichelinePrimAp(..), MichelinePrimitive(..), StringEncode(..), TezosInt64,+  TezosMutez(..), TezosNat)+import Morley.Tezos.Address (Address)+import Morley.Tezos.Core (Mutez, toMutez, zeroMutez)+import Morley.Tezos.Crypto (Signature, decodeBase58CheckWithPrefix, formatSignature)+import Morley.Util.CLI (HasCLReader(..), eitherReader)+import Morley.Util.Named (pattern (:!), pattern N, (:!), (<:!>))+import Morley.Util.Text (dquotes)++data ForgeOperation = ForgeOperation+  { foBranch :: Text+  , foContents :: NonEmpty (Either TransactionOperation OriginationOperation)+  }++contentsToJSON :: NonEmpty (Either TransactionOperation OriginationOperation) -> Value+contentsToJSON = Array . fromList . toList .+  map (\case+          Right transOp -> toJSON transOp+          Left origOp -> toJSON origOp+      )++instance ToJSON ForgeOperation where+  toJSON ForgeOperation{..} = object+    [ "branch" .= toString foBranch+    , ("contents", contentsToJSON foContents)+    ]++data RunOperationInternal = RunOperationInternal+  { roiBranch :: Text+  , roiContents :: NonEmpty (Either TransactionOperation OriginationOperation)+  , roiSignature :: Signature+  }++instance ToJSON RunOperationInternal where+  toJSON RunOperationInternal{..} = object+    [ "branch" .= toString roiBranch+    , ("contents", contentsToJSON roiContents)+    , "signature" .= toJSON roiSignature+    ]++data RunOperation = RunOperation+  { roOperation :: RunOperationInternal+  , roChainId :: Text+  }++data PreApplyOperation = PreApplyOperation+  { paoProtocol :: Text+  , paoBranch :: Text+  , paoContents :: NonEmpty (Either TransactionOperation OriginationOperation)+  , paoSignature :: Signature+  }++instance ToJSON PreApplyOperation where+  toJSON PreApplyOperation{..} = object+    [ "branch" .= toString paoBranch+    , ("contents", contentsToJSON paoContents)+    , "protocol" .= toString paoProtocol+    , "signature" .= formatSignature paoSignature+    ]++data RunOperationResult = RunOperationResult+  { rrOperationContents :: NonEmpty OperationContent+  }++instance FromJSON RunOperationResult where+  parseJSON = withObject "preApplyRes" $ \o ->+    RunOperationResult <$> o .: "contents"++newtype OperationHash = OperationHash+  { unOperationHash :: Text+  }+  deriving stock (Eq, Show)+  deriving newtype (FromJSON, Buildable)++data OperationContent = OperationContent RunMetadata++instance FromJSON OperationContent where+  parseJSON = withObject "operationCostContent" $ \o ->+    OperationContent <$> o .: "metadata"++data RunMetadata = RunMetadata+  { rmOperationResult :: OperationResult+  , rmInternalOperationResults :: [InternalOperation]+  }++instance FromJSON RunMetadata where+  parseJSON = withObject "metadata" $ \o ->+    RunMetadata <$> o .: "operation_result" <*>+    o .:? "internal_operation_results" .!= []++newtype InternalOperation = InternalOperation+  { unInternalOperation :: OperationResult }++instance FromJSON InternalOperation where+  parseJSON = withObject "internal_operation" $ \o ->+    InternalOperation <$> o .: "result"++data BlockConstants = BlockConstants+  { bcProtocol :: Text+  , bcChainId :: Text+  , bcHeader :: BlockHeaderNoHash+  , bcHash :: BlockHash+  }++data BlockHeaderNoHash = BlockHeaderNoHash+  { bhnhTimestamp :: UTCTime+  , bhnhLevel :: Int64+  , bhnhPredecessor :: BlockHash+  }++-- Consider merging this type with 'BlockHeaderNoHash' if it becomes larger (i. e.+-- if we need more data from it).+-- | The whole block header.+data BlockHeader = BlockHeader+  { bhTimestamp :: UTCTime+  , bhLevel :: Int64+  , bhPredecessor :: BlockHash+  , bhHash :: BlockHash+  }++newtype BlockHash = BlockHash { unBlockHash :: Text }+  deriving newtype (ToJSON, FromJSON)++data FeeConstants = FeeConstants+  { fcBase :: Mutez+  , fcMutezPerGas :: Milli+  , fcMutezPerOpByte :: Milli+  }++-- | At the moment of writing, Tezos always uses these constants.+instance Default FeeConstants where+  def = FeeConstants+    { fcBase = toMutez 100+    , fcMutezPerGas = 0.1+    , fcMutezPerOpByte = 1+    }++-- | A block identifier as submitted to RPC.+--+-- A block can be referenced by @head@, @genesis@, level or block hash+data BlockId+  = HeadId+  -- ^ Identifier referring to the head block.+  | GenesisId+  -- ^ Identifier referring to the genesis block.+  | LevelId Natural+  -- ^ Identifier referring to a block by its level.+  | BlockHashId Text+  -- ^ Idenfitier referring to a block by its hash in Base58Check notation.+  | AtDepthId Natural+  -- ^ Identifier of a block at specific depth relative to @head@.+  deriving stock (Show, Eq)++instance ToHttpApiData BlockId where+  toUrlPiece = \case+    HeadId -> "head"+    GenesisId -> "genesis"+    LevelId x -> toUrlPiece x+    BlockHashId hash -> toUrlPiece hash+    AtDepthId depth -> "head~" <> toUrlPiece depth++instance Buildable BlockId where+  build = \case+    HeadId -> "head"+    GenesisId -> "genesis"+    LevelId x -> "block at level " <> build x+    BlockHashId hash -> "block with hash " <> build hash+    AtDepthId depth -> "block at depth " <> build depth++-- | Parse 'BlockId' in its textual representation in the same format as+-- submitted via RPC.+parseBlockId :: Text -> Maybe BlockId+parseBlockId t+  | t == "head" = Just HeadId+  | t == "genesis" = Just GenesisId+  | 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)+  | otherwise = Nothing++-- A magic prefix used by Tezos for block hashes+-- see https://gitlab.com/tezos/tezos/-/blob/v11-release/src/lib_crypto/base58.ml#L341+blockPrefix :: ByteString+blockPrefix = "\001\052"++instance HasCLReader BlockId where+  getReader = eitherReader parseBlockId'+    where+      parseBlockId' :: String -> Either String BlockId+      parseBlockId' =+        maybeToRight ("failed to parse block ID, try passing block's hash, level or 'head'") .+        parseBlockId . toText+  getMetavar = "BLOCK_ID"++-- | Protocol-wide constants.+--+-- There are more constants, but currently, we are using only these+-- in our code.+data ProtocolParameters = ProtocolParameters+  { ppOriginationSize :: Int+  -- ^ Byte size cost for originating new contract.+  , ppHardGasLimitPerOperation :: TezosInt64+  -- ^ Gas limit for a single operation.+  , ppHardStorageLimitPerOperation :: TezosInt64+  -- ^ Storage limit for a single operation.+  , ppMinimalBlockDelay :: TezosNat+  -- ^ Minimal delay between two blocks, this constant is new in V010.+  , ppCostPerByte :: TezosMutez+  -- ^ Burn cost per storage byte+  }++-- | Errors that are sent as part of operation result in an OK+-- response (status 200). They are semi-formally defined as errors+-- that can happen when a contract is executed and something goes+-- wrong.+data RunError+  = RuntimeError Address+  | ScriptRejected Expression+  | BadContractParameter Address+  | InvalidConstant Expression Expression+  | InvalidContract Address+  | InconsistentTypes Expression Expression+  | InvalidPrimitive [Text] Text+  | InvalidSyntacticConstantError Expression Expression+  | InvalidExpressionKind [Text] Text+  | InvalidContractNotation Text+  | UnexpectedContract+  | IllFormedType Expression+  | UnexpectedOperation+  | REEmptyTransaction+    -- ^ Transfer of 0 to an implicit account.+      Address -- ^ Receiver address.+  | ScriptOverflow+    -- ^ A contract failed due to the detection of an overflow.+    -- It seems to happen if a too big value is passed to shift instructions+    -- (as second argument).+  | GasExhaustedOperation+  | MutezAdditionOverflow [TezosInt64]+  | MutezSubtractionUnderflow [TezosInt64]+  | MutezMultiplicationOverflow TezosInt64 TezosInt64+  | CantPayStorageFee+  | BalanceTooLow ("balance" :! Mutez) ("required" :! Mutez)+  | NonExistingContract Address+  deriving stock Show++instance FromJSON RunError where+  parseJSON = withObject "preapply error" $ \o -> do+    id' <- o .: "id"+    case id' of+      x | "runtime_error" `isSuffixOf` x ->+          RuntimeError <$> o .: "contract_handle"+      x | "script_rejected" `isSuffixOf` x ->+          ScriptRejected <$> o .: "with"+      x | "bad_contract_parameter" `isSuffixOf` x ->+          BadContractParameter <$> o .: "contract"+      x | "invalid_constant" `isSuffixOf` x ->+          InvalidConstant <$> o .: "expected_type" <*> o .: "wrong_expression"+      x | "invalid_contract" `isSuffixOf` x ->+          InvalidContract <$> o.: "contract"+      x | "inconsistent_types" `isSuffixOf` x ->+          InconsistentTypes <$> o .: "first_type" <*> o .: "other_type"+      x | "invalid_primitive" `isSuffixOf` x ->+          InvalidPrimitive <$> o .: "expected_primitive_names" <*> o .: "wrong_primitive_name"+      x | "invalidSyntacticConstantError" `isSuffixOf` x ->+          InvalidSyntacticConstantError <$> o .: "expectedForm" <*> o .: "wrongExpression"+      x | "invalid_expression_kind" `isSuffixOf` x ->+          InvalidExpressionKind <$> o .: "expected_kinds" <*> o .: "wrong_kind"+      x | "invalid_contract_notation" `isSuffixOf` x ->+          InvalidContractNotation <$> o .: "notation"+      x | "unexpected_contract" `isSuffixOf` x ->+          pure UnexpectedContract+      x | "ill_formed_type" `isSuffixOf` x ->+          IllFormedType <$> o .: "ill_formed_expression"+      x | "unexpected_operation" `isSuffixOf` x ->+          pure UnexpectedOperation+      x | "empty_transaction" `isSuffixOf` x ->+          REEmptyTransaction <$> o .: "contract"+      x | "script_overflow" `isSuffixOf` x ->+          pure ScriptOverflow+      x | "gas_exhausted.operation" `isSuffixOf` x ->+          pure GasExhaustedOperation+      x | "tez.addition_overflow" `isSuffixOf` x ->+          MutezAdditionOverflow <$> o .: "amounts"+      x | "tez.subtraction_underflow" `isSuffixOf` x ->+          MutezSubtractionUnderflow <$> o .: "amounts"+      x | "tez.multiplication_overflow" `isSuffixOf` x ->+          MutezMultiplicationOverflow <$> o .: "amount" <*> o .: "multiplicator"+      x | "cannot_pay_storage_fee" `isSuffixOf` x ->+          pure CantPayStorageFee+      x | "balance_too_low" `isSuffixOf` x -> do+          balance <- unTezosMutez <$> o .: "balance"+          amount  <- unTezosMutez <$> o .: "amount"+          return $ BalanceTooLow (#balance :! balance) (#required :! amount)+      x | "non_existing_contract" `isSuffixOf` x ->+          NonExistingContract <$> o .: "contract"+      _ -> fail ("unknown id: " <> id')++instance Buildable RunError where+  build = \case+    RuntimeError addr -> "Runtime error for contract: " +| addr |+ ""+    ScriptRejected expr -> "Script rejected with: " +| expr |+ ""+    BadContractParameter addr -> "Bad contract parameter for: " +| addr |+ ""+    InvalidConstant expectedType expr ->+      "Invalid type: " +| expectedType |+ "\n" +|+      "For: " +| expr |+ ""+    InvalidContract addr -> "Invalid contract: " +| addr |+ ""+    InconsistentTypes type1 type2 ->+      "Inconsistent types: " +| type1 |+ " and " +| type2 |+ ""+    InvalidPrimitive expectedPrimitives wrongPrimitive ->+      "Invalid primitive: " +| wrongPrimitive |+ "\n" +|+      "Expecting one of: " +|+      mconcat (intersperse (" " :: Text) $ map pretty expectedPrimitives) |+ ""+    InvalidSyntacticConstantError expectedForm wrongExpression ->+      "Invalid syntatic constant error, expecting: " +| expectedForm |+ "\n" +|+      "But got: " +| wrongExpression |+ ""+    InvalidExpressionKind expectedKinds wrongKind ->+      "Invalid expression kind, expecting expression of kind: " +| expectedKinds |+ "\n" +|+      "But got: " +| wrongKind |+ ""+    InvalidContractNotation notation ->+      "Invalid contract notation: " +| notation |+ ""+    UnexpectedContract ->+      "When parsing script, a contract type was found in \+      \the storage or parameter field."+    IllFormedType expr ->+      "Ill formed type: " +| expr |+ ""+    UnexpectedOperation ->+      "When parsing script, an operation type was found in \+      \the storage or parameter field"+    REEmptyTransaction addr ->+      "It's forbidden to send 0ꜩ to " +| addr |+ " that has no code"+    ScriptOverflow ->+      "A contract failed due to the detection of an overflow"+    GasExhaustedOperation ->+      "Contract failed due to gas exhaustion"+    MutezAdditionOverflow amounts ->+      "A contract failed due to mutez addition overflow when adding following values:\n" +|+      mconcat (intersperse (" " :: Text) $ map show amounts) |+ ""+    MutezSubtractionUnderflow amounts ->+      "A contract failed due to mutez subtraction underflow when subtracting following values:\n" +|+      mconcat (intersperse (" " :: Text) $ map show amounts) |+ ""+    MutezMultiplicationOverflow amount multiplicator ->+      "A contract failed due to mutez multiplication overflow when multiplying" +|+      amount |+ " by " +| multiplicator |+ ""+    CantPayStorageFee ->+      "Balance is too low to pay storage fee"+    BalanceTooLow (N balance) (N required) ->+      "Balance is too low, \+      \current balance: " +| balance |+ ", but required: " +| required |+ ""+    NonExistingContract addr ->+      "Contract is not registered: " +| addr |+ ""++-- | Errors that are sent as part of an "Internal Server Error"+-- response (HTTP code 500).+--+-- We call them internal because of the HTTP code, but we shouldn't+-- treat them as internal. They can be easily triggered by making a+-- failing operation.+data InternalError+  = CounterInThePast+    -- ^ An operation assumed a contract counter in the past.+      Address -- ^ Address whose counter is invalid.+      ("expected" :! Word) -- ^ Expected counter.+      ("found" :! Word) -- ^ Found counter.+  | UnrevealedKey+    -- ^ One tried to apply a manager operation without revealing+    -- the manager public key.+      Address -- ^ Manager address.+  | Failure Text+    -- ^ Failure reported without specific id+  deriving stock Show++instance Buildable InternalError where+  build = \case+    CounterInThePast addr (N expected) (N found) ->+      "Expected counter " +| expected |+ " for " +| addr |+ "but got: " +|+      found |+ ""+    UnrevealedKey addr ->+      "One tried to apply a manager operation without revealing " <>+      "the manager public key of " <> build addr+    Failure msg ->+      "Contract failed with the following message: " +| msg |+ ""++instance FromJSON InternalError where+  parseJSON = withObject "internal error" $ \o ->+    o .: "id" >>= \case+      x | "counter_in_the_past" `isSuffixOf` x ->+          CounterInThePast <$> o .: "contract" <*>+            (#expected <:!> parseCounter o "expected") <*>+            (#found <:!> parseCounter o "found")+      x | "unrevealed_key" `isSuffixOf` x ->+          UnrevealedKey <$> o .: "contract"+      "failure" -> Failure <$> o .: "msg"+      x -> fail ("unknown id: " <> x)+    where+      parseCounter :: Object -> Text -> Parser Word+      parseCounter o fieldName = do+        fieldValue <- o .: fieldName+        let mCounter = fromIntegralMaybe fieldValue+        maybe (fail $ mkErrorMsg fieldName fieldValue) pure mCounter++      mkErrorMsg :: Text -> TezosInt64 -> String+      mkErrorMsg fieldName fieldValue = toString $ unwords+        ["Invalid", dquotes fieldName, "counter:", show $ unStringEncode fieldValue]++data OperationResult+  = OperationApplied AppliedResult+  | OperationFailed [RunError]++data AppliedResult = AppliedResult+  { arConsumedGas :: TezosInt64+  , arStorageSize :: TezosInt64+  , arPaidStorageDiff :: TezosInt64+  , arOriginatedContracts :: [Address]+  , arAllocatedDestinationContracts :: TezosInt64+  -- ^ We need to count number of destination contracts that are new+  -- to the chain in order to calculate proper storage_limit+  }+  deriving stock Show++instance Semigroup AppliedResult where+  (<>) ar1 ar2 = AppliedResult+    { arConsumedGas = arConsumedGas ar1 + arConsumedGas ar2+    , arStorageSize = arStorageSize ar1 + arStorageSize ar2+    , arPaidStorageDiff = arPaidStorageDiff ar1 + arPaidStorageDiff ar2+    , arOriginatedContracts = arOriginatedContracts ar1 <> arOriginatedContracts ar2+    , arAllocatedDestinationContracts =+      arAllocatedDestinationContracts ar1 + arAllocatedDestinationContracts ar2+    }++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"+    case status of+      "applied" -> OperationApplied <$> do+        arConsumedGas <- o .: "consumed_gas"+        arStorageSize <- o .:? "storage_size" .!= 0+        arPaidStorageDiff <- o .:? "paid_storage_size_diff" .!= 0+        arOriginatedContracts <- o .:? "originated_contracts" .!= []+        allocatedFlag <- o .:? "allocated_destination_contract" .!= False+        let arAllocatedDestinationContracts = if allocatedFlag then 1 else 0+        return AppliedResult{..}+      "failed" -> OperationFailed <$> o .: "errors"+      "backtracked" ->+        OperationFailed <$> o .:? "errors" .!= []+      "skipped" ->+        OperationFailed <$> o .:? "errors" .!= []+      _ -> fail ("unexpected status " ++ status)++data ParametersInternal = ParametersInternal+  { piEntrypoint :: Text+  , piValue :: Expression+  }++-- | 'ParametersInternal' can be missing when default entrypoint is called with+-- Unit value. Usually it happens when destination is an implicit account.+-- In our structures 'ParametersInternal' is not optional because missing+-- case is equivalent to explicit calling of @default@ with @Unit@.+defaultParametersInternal :: ParametersInternal+defaultParametersInternal = ParametersInternal+  { piEntrypoint = "default"+  , piValue = ExpressionPrim MichelinePrimAp+    { mpaPrim = MichelinePrimitive "Unit"+    , mpaArgs = []+    , mpaAnnots = []+    }+  }++-- | Data that is common for transaction and origination+-- operations.+data CommonOperationData = CommonOperationData+  { codSource :: Address+  , codFee :: TezosMutez+  , codCounter :: TezosInt64+  , codGasLimit :: TezosInt64+  , codStorageLimit :: TezosInt64+  }++-- | Create 'CommonOperationData' based on current blockchain protocol parameters+-- and sender info. This data is used for operation simulation.+--+-- Fee isn't accounted during operation simulation, so it's safe to use zero amount.+-- Real operation fee is calculated later using 'tezos-client'.+mkCommonOperationData+  :: Address -> TezosInt64 -> ProtocolParameters+  -> CommonOperationData+mkCommonOperationData source counter ProtocolParameters{..} = CommonOperationData+  { codSource = source+  , codFee = TezosMutez zeroMutez+  , codCounter = counter+  , codGasLimit = ppHardGasLimitPerOperation+  , codStorageLimit = ppHardStorageLimitPerOperation+  }++commonDataToValueList :: CommonOperationData -> [(Text, Value)]+commonDataToValueList CommonOperationData{..} =+  [ "source" .= codSource+  , "fee" .= codFee+  , "counter" .= codCounter+  , "gas_limit" .= codGasLimit+  , "storage_limit" .= codStorageLimit+  ]++parseCommonOperationData :: Object -> Parser CommonOperationData+parseCommonOperationData obj = do+  codSource <- obj .: "source"+  codFee <- obj .: "fee"+  codCounter <- obj .: "counter"+  codGasLimit <- obj .: "gas_limit"+  codStorageLimit <- obj .: "storage_limit"+  pure CommonOperationData {..}++-- | All the data needed to perform a transaction through+-- Tezos RPC interface.+-- For additional information, please refer to RPC documentation+-- http://tezos.gitlab.io/api/rpc.html+data TransactionOperation = TransactionOperation+  { toCommonData :: CommonOperationData+  , toAmount :: TezosMutez+  , toDestination :: Address+  , toParameters :: ParametersInternal+  }++instance ToJSON TransactionOperation where+  toJSON TransactionOperation{..} = object $+    [ "kind" .= String "transaction"+    , "amount" .= toJSON toAmount+    , "destination" .= toJSON toDestination+    , "parameters" .= toJSON toParameters+    ] <> commonDataToValueList toCommonData++instance FromJSON TransactionOperation where+  parseJSON = withObject "TransactionOperation" $ \obj -> do+    toCommonData <- parseCommonOperationData obj+    toAmount <- obj .: "amount"+    toDestination <- obj .: "destination"+    toParameters <- fromMaybe defaultParametersInternal <$> obj .:? "parameters"+    pure TransactionOperation {..}++data OriginationScript = OriginationScript+  { osCode :: Expression+  , osStorage :: Expression+  }++-- | All the data needed to perform contract origination+-- through Tezos RPC interface+data OriginationOperation = OriginationOperation+  { ooCommonData :: CommonOperationData+  , ooBalance :: TezosMutez+  , ooScript :: OriginationScript+  }++instance ToJSON OriginationOperation where+  toJSON OriginationOperation{..} = object $+    [ "kind" .= String "origination"+    , "balance" .= toJSON ooBalance+    , "script" .= toJSON ooScript+    ] <> commonDataToValueList ooCommonData++-- | @$operation@ in Tezos docs.+data BlockOperation = BlockOperation+  { boHash :: Text+  , boContents :: [OperationResp]+  }++-- | Contents of an operation that can appear in RPC responses.+data OperationResp+  = TransactionOpResp 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 GetBigMap = GetBigMap+  { bmKey :: Expression+  , bmType :: Expression+  }++data GetBigMapResult+  = GetBigMapResult Expression+  | GetBigMapNotFound++-- | Data required for calling @run_code@ RPC endpoint.+data RunCode = RunCode+  { rcScript :: Expression+  , rcStorage :: Expression+  , rcInput :: Expression+  , rcAmount :: TezosMutez+  , rcBalance :: TezosMutez+  , rcChainId :: Text+  , rcSource :: Maybe Address+  , rcPayer :: Maybe Address+  }++-- | Result storage of @run_code@ RPC endpoint call.+--+-- Actual resulting JSON has more contents, but currently we're interested+-- only in resulting storage.+data RunCodeResult = RunCodeResult+  { rcrStorage :: Expression+  }++deriveJSON morleyClientAesonOptions ''ParametersInternal+deriveToJSON morleyClientAesonOptions ''OriginationScript+deriveToJSON morleyClientAesonOptions ''RunOperation+deriveToJSON morleyClientAesonOptions ''GetBigMap+deriveToJSON morleyClientAesonOptions{omitNothingFields = True} ''RunCode+deriveFromJSON morleyClientAesonOptions ''BlockConstants+deriveFromJSON morleyClientAesonOptions ''BlockHeaderNoHash+deriveJSON morleyClientAesonOptions ''BlockHeader+deriveFromJSON morleyClientAesonOptions ''ProtocolParameters+deriveFromJSON morleyClientAesonOptions ''BlockOperation+deriveFromJSON morleyClientAesonOptions ''OriginationScript+deriveFromJSON morleyClientAesonOptions ''RunCodeResult++instance FromJSON GetBigMapResult where+  parseJSON v = maybe GetBigMapNotFound GetBigMapResult <$> parseJSON v++makePrisms ''RunError+makeLensesFor [("toCommonData", "toCommonDataL")] ''TransactionOperation+makeLensesFor [("ooCommonData", "ooCommonDataL")] ''OriginationOperation
+ src/Morley/Client/TezosClient.hs view
@@ -0,0 +1,16 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Interface to @tezos-client@ (and its implementation).++module Morley.Client.TezosClient+  ( module Morley.Client.TezosClient.Class+  , module Morley.Client.TezosClient.Types+  , TezosClientError (..)+  , resolveAddress+  ) where++import Morley.Client.TezosClient.Class+import Morley.Client.TezosClient.Impl (TezosClientError(..), resolveAddress)+import Morley.Client.TezosClient.Types
+ src/Morley/Client/TezosClient/Class.hs view
@@ -0,0 +1,71 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Abstraction layer for @tezos-client@ functionality.+-- We use it to mock @tezos-client@ in tests.++module Morley.Client.TezosClient.Class+  ( HasTezosClient (..)+  ) where++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.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+  -- ^ 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+  -- ^ 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 ()+  -- ^ Associate the given contract with alias.+  -- The 'Bool' variable indicates whether or not we should replace already+  -- existing contract alias or not.+  importKey :: Bool -> AliasOrAliasHint -> SecretKey -> m ()+  -- ^ Saves 'SecretKey' via @tezos-client@ with given alias associated.+  -- The 'Bool' variable indicates whether or not we should replace already+  -- existing alias key or not.+  resolveAddressMaybe :: AddressOrAlias -> m (Maybe Address)+  -- ^ Retrieve an address from given address or alias. If address or alias does not exist+  -- returns `Nothing`+  getAlias :: AddressOrAlias -> m Alias+  -- ^ Retrieve an alias from given address using @tezos-client@.  The+  -- primary (and probably only) reason this function exists is that+  -- @tezos-client sign@ command only works with aliases. It was+  -- reported upstream: <https://gitlab.com/tezos/tezos/-/issues/836>.+  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 ()+  -- ^ Register a given address as delegate+  getTezosClientConfig :: m TezosClientConfig+  -- ^ Retrieve the current @tezos-client@ config.+  calcTransferFee+    :: AddressOrAlias -> Maybe ScrubbedBytes -> TezosInt64 -> [CalcTransferFeeData] -> m [TezosMutez]+  -- ^ Calculate fee for transfer using `--dry-run` flag.+  calcOriginationFee+    :: UntypedValScope st => CalcOriginationFeeData cp st -> m TezosMutez+  -- ^ Calculate fee for origination using `--dry-run` flag.+  getKeyPassword :: Address -> m (Maybe ScrubbedBytes)+  -- ^ Get password for secret key associated with given address+  -- in case this key is password-protected. Obtained password is used+  -- in two places:+  --   * 1) In @signBytes@ call.+  --   * 2) in @revealKey@ call.
+ src/Morley/Client/TezosClient/Impl.hs view
@@ -0,0 +1,639 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Interface to the @tezos-client@ executable expressed in Haskell types.++module Morley.Client.TezosClient.Impl+  ( TezosClientError (..)++  -- * @tezos-client@ api+  , signBytes+  , waitForOperationInclusion+  , rememberContract+  , importKey+  , genKey+  , genFreshKey+  , revealKey+  , resolveAddressMaybe+  , resolveAddress+  , getAlias+  , getPublicKey+  , getTezosClientConfig+  , calcTransferFee+  , calcOriginationFee+  , getKeyPassword+  , registerDelegate++  -- * Internals+  , callTezosClient+  , callTezosClientStrict+  , prefixName+  , prefixNameM+  ) where++import Colourista (formatWith, red)+import Control.Exception (IOException, throwIO)+import Data.Aeson (eitherDecodeStrict, encode)+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteString.Lazy.Char8 as C (unpack)+import Data.List ((!!))+import qualified Data.Text as T+import Fmt (Buildable(..), pretty, (+|), (|+))+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)+import Text.Printf (printf)+import UnliftIO.IO (hGetEcho, hSetEcho)++import Lorentz.Value+import Morley.Client.Logging+import Morley.Client.RPC.Types+import qualified Morley.Client.TezosClient.Class as Class (HasTezosClient(resolveAddressMaybe))+import Morley.Client.TezosClient.Parser+import Morley.Client.TezosClient.Types+import Morley.Client.Util (readScrubbedBytes, scrubbedBytesToString)+import Morley.Micheline+import Morley.Michelson.Typed.Scope+import Morley.Tezos.Address+import Morley.Tezos.Crypto++----------------------------------------------------------------------------+-- Errors+----------------------------------------------------------------------------++-- | A data type for all /predicatable/ errors that can happen during+-- @tezos-client@ usage.+data TezosClientError =+    UnexpectedClientFailure+    -- ^ @tezos-client@ call unexpectedly failed (returned non-zero exit code).+    -- The error contains the error code, stdout and stderr contents.+      Int -- ^ Exit code+      Text -- ^ stdout+      Text -- ^ stderr++  -- These errors represent specific known scenarios.+  | UnknownAddressAlias+    -- ^ Could not find an address with given name.+      Alias -- ^ Name of address which is eventually used+  | UnknownAddress+    -- ^ Could not find an address.+      Address -- ^ Address that is not present in local tezos cache+  | AlreadyRevealed+    -- ^ Public key of the given address is already revealed.+      Alias -- ^ Address alias that has already revealed its key+  | InvalidOperationHash+    -- ^ Can't wait for inclusion of operation with given hash because+    -- the hash is invalid.+      OperationHash+  | CounterIsAlreadyUsed+    -- ^ Error that indicates when given counter is already used for+    -- given contract.+    Text -- ^ Raw counter+    Text -- ^ Raw address+  | EConnreset+    -- ^ Network error with which @tezos-client@ fails from time to time.++  -- Note: the errors below most likely indicate that something is wrong in our code.+  -- Maybe we made a wrong assumption about tezos-client or just didn't consider some case.+  -- Another possible reason that a broken tezos-client is used.+  | ConfigParseError String+  -- ^ A parse error occurred during config parsing.+  | TezosClientCryptoParseError Text CryptoParseError+  -- ^ @tezos-client@ produced a cryptographic primitive that we can't parse.+  | TezosClientParseAddressError Text ParseAddressError+  -- ^ @tezos-client@ produced an address that we can't parse.+  | TezosClientParseFeeError Text Text+  -- ^ @tezos-client@ produced invalid output for parsing baker fee+  | TezosClientUnexpectedOutputFormat Text+  -- ^ @tezos-client@ printed a string that doesn't match the format we expect.+  | CantRevealContract+    -- ^ Given alias is a contract and cannot be revealed.+    Alias -- ^ Address alias of implicit account+  | ContractSender Address Text+    -- ^ Given contract is a source of a transfer or origination operation.+  | EmptyImplicitContract+    -- ^ Given alias is an empty implicit contract.+    Alias -- ^ Address alias of implicit contract+  | TezosClientUnexpectedSignatureOutput Text+  -- ^ @tezos-client sign bytes@ produced unexpected output format+  | TezosClientParseEncryptionTypeError Text Text+  -- ^ @tezos-client@ produced invalid output for parsing secret key encryption type.+  deriving stock (Show, Eq)++instance Exception TezosClientError where+  displayException = pretty++instance Buildable TezosClientError where+  build = \case+    UnexpectedClientFailure errCode output errOutput ->+      "tezos-client unexpectedly failed with error code " +| errCode |++      ". Stdout:\n" +| output |+ "\nStderr:\n" +| errOutput |+ ""+    UnknownAddressAlias name ->+      "Could not find an address with name " <> build name <> "."+    UnknownAddress uaddr ->+      "Could not find an associated name for the given address " <>+      build uaddr <> "."+    AlreadyRevealed alias ->+      "The address alias " <> build alias <> " is already revealed"+    InvalidOperationHash hash ->+      "Can't wait for inclusion of operation " <> build hash <>+      " because this hash is invalid."+    CounterIsAlreadyUsed counter addr ->+      "Counter " +| counter |+ " already used for " +| addr |+ "."+    EConnreset -> "tezos-client call failed with 'Unix.ECONNRESET' error."+    ConfigParseError err ->+      "A parse error occurred during config parsing: " <> build err+    TezosClientCryptoParseError txt err ->+      "tezos-client produced a cryptographic primitive that we can't parse: " +|+      txt |+ ".\n The error is: " +| err |+ "."+    TezosClientParseAddressError txt err ->+      "tezos-client produced an address that we can't parse: " +|+      txt |+ ".\n The error is: " +| err |+ "."+    TezosClientParseFeeError txt err ->+      "tezos-client produced invalid output for parsing baker fee: " +|+      txt |+ ".\n Parsing error is: " +| err |+ ""+    TezosClientUnexpectedOutputFormat txt ->+      "tezos-client printed a string that doesn't match the format we expect:\n" <>+      build txt+    CantRevealContract alias ->+      "Contracts (" <> build alias <> ") cannot be revealed"+    ContractSender addr opName ->+      "Contract (" <> build addr <> ") cannot be source of " +| opName |+ ""+    EmptyImplicitContract alias ->+      "Empty implicit contract (" <> build alias <> ")"+    TezosClientUnexpectedSignatureOutput txt ->+      "'tezos-client sign bytes' call returned a signature in format we don't expect:\n" <>+      build txt+    TezosClientParseEncryptionTypeError txt err ->+      "tezos-client produced invalid output for parsing secret key encryption type: " +|+      txt |+ ".\n Parsing error is: " +| err |+ ""++----------------------------------------------------------------------------+-- API+----------------------------------------------------------------------------++-- Note: if we try to sign with an unknown alias, tezos-client will+-- report a fatal error (assert failure) to stdout. It's bad. It's+-- reported in two issues: https://gitlab.com/tezos/tezos/-/issues/653+-- and https://gitlab.com/tezos/tezos/-/issues/813.+-- I (@gromak) currently think it's better to wait for it to be resolved upstream.+-- Currently we will throw 'TezosClientUnexpectedOutputFormat' error.+-- | Sign an arbtrary bytestring using @tezos-client@.+-- Secret key of the address corresponding to give 'AddressOrAlias' must be known.+signBytes+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => AddressOrAlias+  -> Maybe ScrubbedBytes+  -> ByteString+  -> m Signature+signBytes signer mbPassword opHash = do+  signerAlias <- getAlias signer+  logDebug $ "Signing for " <> pretty signer+  output <- callTezosClientStrict+    ["sign", "bytes", toCmdArg opHash, "for", toCmdArg signerAlias] MockupMode mbPassword+  liftIO case T.stripPrefix "Signature: " output of+    Nothing ->+      -- There is additional noise in the stdout in case key is password protected+      case T.stripPrefix "Enter password for encrypted key: Signature: " output of+        Nothing -> throwM $ TezosClientUnexpectedSignatureOutput output+        Just signatureTxt -> txtToSignature signatureTxt+    Just signatureTxt -> txtToSignature signatureTxt+  where+    txtToSignature :: MonadCatch m => Text -> m Signature+    txtToSignature signatureTxt = either (throwM . TezosClientCryptoParseError signatureTxt) pure $+      parseSignature . T.strip $ signatureTxt++-- | Generate a new secret key and save it with given alias.+-- If an address with given alias already exists, it will be returned+-- and no state will be changed.+genKey+  :: ( MonadThrow m, MonadCatch m, WithClientLog env m, HasTezosClientEnv env, MonadIO m+     , Class.HasTezosClient m)+  => AliasOrAliasHint+  -> m Address+genKey originatorAlias = do+  name <- prefixNameM originatorAlias+  let+    isAlreadyExistsError :: Text -> Bool+    -- We can do a bit better here using more complex parsing if necessary.+    isAlreadyExistsError = T.isInfixOf "already exists."++    errHandler _ errOut = pure (isAlreadyExistsError errOut)++  _ <-+    callTezosClient errHandler+    ["gen", "keys", toCmdArg name] MockupMode Nothing+  resolveAddress (AddressAlias name)++-- | Generate a new secret key and save it with given alias.+-- If an address with given alias already exists, it will be removed+-- and replaced with a fresh one.+genFreshKey+  :: ( MonadThrow m, MonadCatch m, WithClientLog env m, HasTezosClientEnv env, MonadIO m+     , Class.HasTezosClient m)+  => AliasOrAliasHint+  -> m Address+genFreshKey originatorAlias = do+  name <- prefixNameM originatorAlias+  let+    isNoAliasError :: Text -> Bool+    -- We can do a bit better here using more complex parsing if necessary.+    isNoAliasError = T.isInfixOf "no public key hash alias named"++    errHandler _ errOutput = pure (isNoAliasError errOutput)++  _ <-+    callTezosClient errHandler+    ["forget", "address", toCmdArg name, "--force"] MockupMode Nothing+  callTezosClientStrict ["gen", "keys", toCmdArg name] MockupMode Nothing+  resolveAddress (AddressAlias name)++-- | Reveal public key corresponding to the given alias.+-- Fails if it's already revealed.+revealKey+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => Alias+  -> Maybe ScrubbedBytes+  -> m ()+revealKey alias mbPassword = do+  logDebug $ "Revealing key for " +| alias |+ ""+  let+    alreadyRevealed = T.isInfixOf "previously revealed"+    revealedImplicitAccount = T.isInfixOf "only implicit accounts can be revealed"+    emptyImplicitContract = T.isInfixOf "Empty implicit contract"+    errHandler _ errOut =+      False <$ do+        when (alreadyRevealed errOut) (throwM (AlreadyRevealed alias))+        when (revealedImplicitAccount errOut) (throwM (CantRevealContract alias))+        when (emptyImplicitContract errOut) (throwM (EmptyImplicitContract alias))++  _ <-+    callTezosClient errHandler+    ["reveal", "key", "for", toCmdArg alias] ClientMode mbPassword++  logDebug $ "Successfully revealed key for " +| alias |+ ""++-- | Register alias as delegate+registerDelegate+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => AliasOrAliasHint+  -> Maybe ScrubbedBytes+  -> m ()+registerDelegate addressOrAliasHint mbPassword = do+  alias <- prefixNameM addressOrAliasHint+  logDebug $ "Registering " +| alias |+ " as delegate"+  let+    emptyImplicitContract = T.isInfixOf "Empty implicit contract"+    errHandler _ errOut =+      False <$ do+        when (emptyImplicitContract errOut) (throwM (EmptyImplicitContract alias))++  _ <-+    callTezosClient errHandler+    ["register", "key", toCmdArg alias, "as", "delegate"] ClientMode mbPassword++  logDebug $ "Successfully registered " +| alias |+ " as delegate"++-- | Return 'Address' corresponding to given 'AddressOrAlias', covered in @Maybe@.+-- Return @Nothing@ if address alias is unknown+resolveAddressMaybe+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => AddressOrAlias+  -> m (Maybe Address)+resolveAddressMaybe addressOrAlias = case addressOrAlias of+  AddressResolved addr -> (pure . Just) addr+  AddressAlias originatorName -> do+    logDebug $ "Resolving " +| originatorName |+ ""+    output <- callTezosClientStrict ["list", "known", "contracts"] MockupMode Nothing+    let parse = T.stripPrefix (unsafeGetAliasText originatorName <> ": ")+    liftIO case safeHead . mapMaybe parse . lines $ output of+      Nothing -> pure Nothing+      Just addrText ->+        either (throwM . TezosClientParseAddressError addrText) (pure . Just) $+        parseAddress addrText++-- | Return 'Alias' corresponding to given 'AddressOrAlias'.+getAlias+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => AddressOrAlias+  -> m Alias+getAlias = \case+  AddressAlias alias -> pure alias+  AddressResolved senderAddress -> do+    logDebug $ "Getting an alias for " <> pretty senderAddress+    output <- callTezosClientStrict ["list", "known", "contracts"] MockupMode Nothing+    let parse = T.stripSuffix (": " <> pretty senderAddress)+    liftIO case safeHead . mapMaybe parse . lines $ output of+      Nothing -> throwM $ UnknownAddress senderAddress+      Just alias -> pure (mkAlias alias)++-- | Return 'PublicKey' corresponding to given 'AddressOrAlias'.+getPublicKey+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => AddressOrAlias+  -> m PublicKey+getPublicKey addrOrAlias = do+  alias <- getAlias addrOrAlias+  logDebug $ "Getting " +| alias |+ " public key"+  output <- callTezosClientStrict ["show", "address", toCmdArg alias] MockupMode Nothing+  liftIO case lines output of+    _ : [rawPK] -> do+      pkText <- maybe+        (throwM $ TezosClientUnexpectedOutputFormat rawPK) pure+        (T.stripPrefix "Public Key: " rawPK)+      either (throwM . TezosClientCryptoParseError pkText) pure $+        parsePublicKey pkText+    _ -> throwM $ TezosClientUnexpectedOutputFormat output++-- | This function blocks until operation with given hash is included into blockchain.+waitForOperationInclusion+  :: (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)++-- | Save a contract with given address and alias.+-- If @replaceExisting@ is @False@ and a contract with given alias+-- already exists, this function does nothing.+rememberContract+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => Bool+  -> Address+  -> AliasOrAliasHint+  -> m ()+rememberContract replaceExisting contractAddress newAlias = do+  name <- prefixNameM newAlias+  let+    isAlreadyExistsError = T.isInfixOf "already exists"+    errHandler _ errOut = pure (isAlreadyExistsError errOut)+    args = ["remember", "contract", toCmdArg name, pretty contractAddress]+  _ <-+    callTezosClient errHandler+    (if replaceExisting then args <> ["--force"] else args)+    MockupMode Nothing+  pure ()++importKey+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => Bool+  -> AliasOrAliasHint+  -> SecretKey+  -> m ()+importKey replaceExisting alias key = do+  name <- prefixNameM alias+  let+    isAlreadyExistsError = T.isInfixOf "already exists"+    errHandler _ errOut = pure (isAlreadyExistsError errOut)+    args = ["import", "secret", "key", toCmdArg name, toCmdArg key]+  _ <-+    callTezosClient errHandler+    (if replaceExisting then args <> ["--force"] else args)+    MockupMode Nothing+  pure ()++-- | Read @tezos-client@ configuration.+getTezosClientConfig :: FilePath -> Maybe FilePath -> IO TezosClientConfig+getTezosClientConfig client mbDataDir = do+  t <- readProcessWithExitCode' client+    (maybe [] (\dir -> ["-d", dir]) mbDataDir ++  ["config", "show"]) ""+  case t of+    (ExitSuccess, toText -> output, _) -> case eitherDecodeStrict . encodeUtf8 . toText $ output of+        Right config -> pure config+        Left err -> throwM $ ConfigParseError err+    (ExitFailure errCode, toText -> output, toText -> errOutput) ->+      throwM $ UnexpectedClientFailure errCode output errOutput++-- | Calc baker fee for transfer using @tezos-client@.+calcTransferFee+  :: ( WithClientLog env m, HasTezosClientEnv env+     , MonadIO m, MonadCatch m+     )+  => AddressOrAlias -> Maybe ScrubbedBytes -> TezosInt64 -> [CalcTransferFeeData] -> m [TezosMutez]+calcTransferFee from mbPassword burnCap transferFeeDatas = do+  output <- callTezosClientStrict+    [ "multiple", "transfers", "from", pretty from, "using"+    , C.unpack $ encode transferFeeDatas, "--burn-cap", showBurnCap burnCap, "--dry-run"+    ] ClientMode mbPassword+  feeOutputParser output $ length transferFeeDatas++-- | Calc baker fee for origination using @tezos-client@.+calcOriginationFee+  :: ( UntypedValScope st, WithClientLog env m, HasTezosClientEnv env+     , MonadIO m, MonadCatch m+     )+  => CalcOriginationFeeData cp st -> m TezosMutez+calcOriginationFee CalcOriginationFeeData{..} = do+  output <- callTezosClientStrict+    [ "originate", "contract", "-", "transferring"+    , showTez cofdBalance+    , "from", pretty cofdFrom, "running"+    , toCmdArg cofdContract, "--init"+    , toCmdArg cofdStorage, "--burn-cap"+    , showBurnCap cofdBurnCap, "--dry-run"+    ] ClientMode cofdMbFromPassword+  fees <- feeOutputParser output 1+  case fees of+    [singleFee] -> return singleFee+    _ -> error "Expecting to parse single fee, parsed more"++feeOutputParser :: (MonadIO m, MonadThrow m) => Text -> Int -> m [TezosMutez]+feeOutputParser output n =+  case parseBakerFeeFromOutput output n of+    Right fee -> return fee+    Left err -> throwM $ TezosClientParseFeeError output $ show err++showBurnCap :: TezosInt64 -> String+showBurnCap x = printf "%.6f" $ (fromIntegralToRealFrac @TezosInt64 @Float x) / 1000++showTez :: TezosMutez -> String+showTez = toCmdArg . unTezosMutez++-- | Get password for secret key associated with given address+-- in case this key is password-protected+getKeyPassword+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadMask m)+  => Address -> m (Maybe ScrubbedBytes)+getKeyPassword = \case+  ContractAddress _ -> pure Nothing+  keyAddr -> (getAlias $ AddressResolved keyAddr) >>= getKeyPassword'+  where+    getKeyPassword'+      :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m, MonadMask m)+      => Alias -> m (Maybe ScrubbedBytes)+    getKeyPassword' alias = do+      output <- callTezosClientStrict [ "show", "address", pretty alias, "-S"] MockupMode Nothing+      encryptionType <-+        case parseSecretKeyEncryption output of+          Right t -> return t+          Left err -> throwM $ TezosClientParseEncryptionTypeError output $ show err+      case encryptionType of+        EncryptedKey -> do+          putTextLn $ "Please enter password for '" <> pretty alias <> "':"+          Just <$> withoutEcho readScrubbedBytes+        _ -> pure Nothing++    -- | Hide entered password+    withoutEcho :: (MonadIO m, MonadMask m) => m a -> m a+    withoutEcho action = do+      old <- hGetEcho stdin+      bracket_ (hSetEcho stdin False) (hSetEcho stdin old) action++----------------------------------------------------------------------------+-- Helpers+-- All interesting @tezos-client@ functionality is supposed to be+-- exported as functions with types closely resembling inputs of+-- respective @tezos-client@ functions. If something is not+-- available, consider adding it here. But if it is not feasible,+-- you can use these two functions directly to constructor a custom+-- @tezos-client@ call.+----------------------------------------------------------------------------++-- | Datatype that represents modes for calling node from @tezos-client@.+data CallMode+  = MockupMode+  -- ^ Mode in which @tezos-client@ doesn't perform any actual RPC calls to the node+  -- and use mock instead.+  | ClientMode+  -- ^ Normal mode in which @tezos-client@ performs all necessary RPC calls to the node.++-- | Call @tezos-client@ with given arguments. Arguments defined by+-- config are added automatically. The second argument specifies what+-- should be done in failure case. It takes stdout and stderr+-- output. Possible handling:+--+-- 1. Parse a specific error and throw it.+-- 2. Parse an expected error that shouldn't cause a failure.+-- Return @True@ in this case.+-- 3. Detect an unexpected error, return @False@.+-- In this case 'UnexpectedClientFailure' will be throw.+callTezosClient+  :: forall env m. (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => (Text -> Text -> IO Bool) -> [String] -> CallMode -> Maybe ScrubbedBytes -> m Text+callTezosClient errHandler args mode mbInput = retryEConnreset mode $ do+  TezosClientEnv {..} <- view tezosClientEnvL+  let+    extraArgs :: [String]+    extraArgs = mconcat+      [ ["-E", toCmdArg tceEndpointUrl]+      , maybe [] (\dir -> ["-d", dir]) tceMbTezosClientDataDir+      , ["--mode", case mode of+            MockupMode -> "mockup"+            ClientMode -> "client"+        ]+      ]++    allArgs = extraArgs ++ args+  logDebug $ "Running: " <> unwords (toText <$> tceTezosClientPath:allArgs)+  let+    ifNotEmpty prefix output+      | null output = ""+      | otherwise = prefix <> ":\n" <> output+    logOutput :: Text -> Text -> m ()+    logOutput output errOutput = logDebug $+      ifNotEmpty "stdout" output <>+      ifNotEmpty "stderr" errOutput++  liftIO (readProcessWithExitCode' tceTezosClientPath allArgs+          (maybe "" scrubbedBytesToString mbInput)) >>= \case+    (ExitSuccess, toText -> output, toText -> errOutput) ->+      output <$ logOutput output errOutput+    (ExitFailure errCode, toText -> output, toText -> errOutput) -> do+      checkCounterError errOutput+      checkEConnreset errOutput+      liftIO $ unlessM (errHandler output errOutput) $+        throwM $ UnexpectedClientFailure errCode output errOutput++      output <$ logOutput output errOutput+  where+    checkCounterError+      :: Text -> m ()+    checkCounterError errOutput |+      "Counter" `T.isPrefixOf` errOutput && "already used for contract" `T.isInfixOf` errOutput = do+        let splittedErrOutput = words errOutput+        liftIO $ throwM $+          CounterIsAlreadyUsed (splittedErrOutput !! 1) (splittedErrOutput !! 5)+    checkCounterError _ = pass+    checkEConnreset :: Text -> m ()+    checkEConnreset errOutput+      | "Unix.ECONNRESET" `T.isInfixOf` errOutput = throwM EConnreset+    checkEConnreset _ = pass++    -- | Helper function that retries @tezos-client@ call action in case of @ECONNRESET@.+    -- Note that this error cannot appear in case of 'MockupMode' call.+    retryEConnreset :: CallMode -> m a -> m a+    retryEConnreset MockupMode action = action+    retryEConnreset ClientMode action = retryEConnresetImpl 0 action++    retryEConnresetImpl :: Integer -> m a -> m a+    retryEConnresetImpl attempt action = action `catch` \err -> do+      case err of+        EConnreset ->+          if attempt >= maxRetryAmount then throwM err+          else retryEConnresetImpl (attempt + 1) action+        anotherErr -> throwM anotherErr++    maxRetryAmount = 5++-- | Call tezos-client and expect success.+callTezosClientStrict+  :: (WithClientLog env m, HasTezosClientEnv env, MonadIO m, MonadCatch m)+  => [String] -> CallMode -> Maybe ScrubbedBytes -> m Text+callTezosClientStrict args mode mbInput = callTezosClient errHandler args mode mbInput+  where+    errHandler _ _ = pure False++-- | Variant of @readProcessWithExitCode@ that prints a better error in case of+-- an exception in the inner @readProcessWithExitCode@ call.+readProcessWithExitCode'+  :: FilePath+  -> [String]+  -> String+  -> IO (ExitCode, String, String)+readProcessWithExitCode' fp args inp =+  catch+    (readProcessWithExitCode fp args inp) handler+  where+    handler :: IOException -> IO (ExitCode, String, String)+    handler e = do+      hPutStrLn @Text stderr $ formatWith [red] errorMsg+      throwIO e++    errorMsg =+      "ERROR!! There was an error in executing `" <> (show 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+  :: (MonadThrow m, Class.HasTezosClient m)+  => AddressOrAlias+  -> m Address+resolveAddress addr = case addr of+   AddressResolved addrResolved -> pure addrResolved+   alias@(AddressAlias originatorName) ->+     Class.resolveAddressMaybe alias >>= (\case+       Nothing -> throwM $ UnknownAddressAlias originatorName+       Just existingAddress -> return existingAddress+       )
+ src/Morley/Client/TezosClient/Parser.hs view
@@ -0,0 +1,76 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Parsers that are used in "Morley.Client.TezosClient.Impl"+module Morley.Client.TezosClient.Parser+  ( parseBakerFeeFromOutput+  , parseSecretKeyEncryption+  ) where++import Data.Scientific (Scientific)+import Text.Megaparsec (choice, count, customFailure)+import qualified Text.Megaparsec as P (Parsec, parse, skipManyTill)+import Text.Megaparsec.Char (newline, printChar, space)+import Text.Megaparsec.Char.Lexer (lexeme, scientific, symbol)+import Text.Megaparsec.Error (ParseErrorBundle, ShowErrorComponent(..), errorBundlePretty)+import qualified Text.Show (show)++import Morley.Client.TezosClient.Types (SecretKeyEncryption(..))+import Morley.Micheline+import Morley.Tezos.Core++type Parser = P.Parsec Void Text++data FeeParserException = FeeParserException (ParseErrorBundle Text Void)+  deriving stock Eq++instance Show FeeParserException where+  show (FeeParserException bundle) = errorBundlePretty bundle++instance Exception FeeParserException where+  displayException = show++data SecretKeyEncryptionParserException =+  SecretKeyEncryptionParserException (ParseErrorBundle Text UnexpectedEncryptionType)+  deriving stock Eq++instance Show SecretKeyEncryptionParserException where+  show (SecretKeyEncryptionParserException bundle) = errorBundlePretty bundle++data UnexpectedEncryptionType = UnexpectedEncryptionType+  deriving stock (Eq, Ord, Show)++instance ShowErrorComponent UnexpectedEncryptionType where+  showErrorComponent UnexpectedEncryptionType =+    "Unexpected secret key encryption type occurred"++-- | Function to parse baker fee from given @tezos-client@ output.+parseBakerFeeFromOutput+  :: Text -> Int -> Either FeeParserException [TezosMutez]+parseBakerFeeFromOutput output n = first FeeParserException $+  P.parse (count n bakerFeeParser) "" output+  where+    bakerFeeParser :: Parser TezosMutez+    bakerFeeParser = do+      num <- P.skipManyTill (printChar <|> newline) $ do+        void $ symbol space "Fee to the baker: "+        P.skipManyTill printChar $ lexeme (newline >> pass) scientific+      either (fail . toString) pure $ scientificToMutez num+    scientificToMutez :: Scientific -> Either Text TezosMutez+    scientificToMutez x = fmap TezosMutez . mkMutez @Word64 $ floor $ x * 1e6++parseSecretKeyEncryption+  :: Text -> Either SecretKeyEncryptionParserException SecretKeyEncryption+parseSecretKeyEncryption output = first SecretKeyEncryptionParserException $+  P.parse secretKeyEncryptionParser "" output+  where+    secretKeyEncryptionParser :: P.Parsec UnexpectedEncryptionType Text SecretKeyEncryption+    secretKeyEncryptionParser = do+      P.skipManyTill (printChar <|> newline) $ do+        symbol space "Secret Key: " >> choice+          [ symbol space "unencrypted" >> pure UnencryptedKey+          , symbol space "encrypted" >> pure EncryptedKey+          , symbol space "ledger" >> pure LedgerKey+          , customFailure UnexpectedEncryptionType+          ]
+ src/Morley/Client/TezosClient/Types.hs view
@@ -0,0 +1,241 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Types used for interaction with @tezos-client@.++module Morley.Client.TezosClient.Types+  ( CmdArg (..)+  , Alias+  , AliasHint+  , AliasOrAliasHint (..)+  , AddressOrAlias (..)+  , addressResolved+  , CalcOriginationFeeData (..)+  , CalcTransferFeeData (..)+  , TezosClientConfig (..)+  , TezosClientEnv (..)+  , HasTezosClientEnv (..)+  , SecretKeyEncryption (..)++  -- * Unsafe coercions+  , unsafeCoerceAliasHintToAlias+  , unsafeCoerceAliasToAliasHint+  , unsafeGetAliasText+  , unsafeGetAliasHintText+  , mkAlias+  , mkAliasHint++  -- * Lens+  , tceAliasPrefixL+  , tceEndpointUrlL+  , tceTezosClientPathL+  , tceMbTezosClientDataDirL+  ) where++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 qualified Options.Applicative as Opt+import Servant.Client (BaseUrl(..), showBaseUrl)+import Text.Hex (encodeHex)++import Lorentz (ToAddress, toAddress)+import Morley.Client.RPC.Types (OperationHash)+import Morley.Client.Util+import Morley.Micheline+import Morley.Michelson.Printer+import Morley.Michelson.Typed (Contract, EpName, Value)+import qualified Morley.Michelson.Typed as T+import Morley.Tezos.Address (Address, parseAddress)+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+  -- | Render an object as a command-line argument.+  toCmdArg :: a -> String+  default toCmdArg :: Buildable a => a -> String+  toCmdArg = pretty++instance CmdArg Text where++instance CmdArg LText where++instance CmdArg Word16 where++instance CmdArg SecretKey where+  toCmdArg = toCmdArg . formatSecretKey++instance CmdArg Address where++instance CmdArg ByteString where+  toCmdArg = toCmdArg . ("0x" <>) . encodeHex++instance CmdArg EpName where+  toCmdArg = toCmdArg . epNameToTezosEp++instance CmdArg Mutez where+  toCmdArg m = show . MkFixed @_ @E6 $ fromIntegral (unMutez m)++instance T.ProperUntypedValBetterErrors t => CmdArg (Value t) where+  toCmdArg = toCmdArg . printTypedValue True++instance CmdArg (Contract cp st) where+  toCmdArg = toString . printTypedContract True++instance CmdArg BaseUrl where+  toCmdArg = showBaseUrl++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 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+  | EncryptedKey+  | LedgerKey+  deriving stock (Eq, Show)++-- | Configuration maintained by @tezos-client@, see its @config@ subcommands+-- (e. g. @tezos-client config show@).+-- Only the field we are interested in is present here.+newtype TezosClientConfig = TezosClientConfig { tcEndpointUrl :: BaseUrl }+  deriving stock Show++-- | For reading tezos-client config.+instance FromJSON TezosClientConfig where+  parseJSON = withObject "node info" $ \o -> TezosClientConfig <$> o .: "endpoint"++-- | 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+  -- ^ URL of tezos node on which operations are performed.+  , tceTezosClientPath :: FilePath+  -- ^ Path to tezos client binary through which operations are+  -- performed.+  , tceMbTezosClientDataDir :: Maybe FilePath+  -- ^ Path to tezos client data directory.+  }++makeLensesWith postfixLFields ''TezosClientEnv++-- | Using this type class one can require 'MonadReader' constraint+-- that holds any type with 'TezosClientEnv' inside.+class HasTezosClientEnv env where+  tezosClientEnvL :: Lens' env TezosClientEnv++-- | Data required for calculating fee for transfer operation.+data CalcTransferFeeData = forall t. T.UntypedValScope t => CalcTransferFeeData+  { ctfdTo :: AddressOrAlias+  , ctfdParam :: Value t+  , ctfdEp :: EpName+  , ctfdAmount :: TezosMutez+  }++instance ToJSON CalcTransferFeeData where+  toJSON CalcTransferFeeData{..} = object+    [ "destination" .= pretty @_ @Text ctfdTo+    , "amount" .= (fromString @Text $ toCmdArg $ unTezosMutez ctfdAmount)+    , "arg" .= (fromString @Text $ toCmdArg ctfdParam)+    , "entrypoint" .= (fromString @Text $ toCmdArg ctfdEp)+    ]++-- | Data required for calculating fee for origination operation.+data CalcOriginationFeeData cp st = CalcOriginationFeeData+  { cofdFrom :: AddressOrAlias+  , cofdBalance :: TezosMutez+  , cofdMbFromPassword :: Maybe ScrubbedBytes+  , cofdContract :: Contract cp st+  , cofdStorage :: Value st+  , cofdBurnCap :: TezosInt64+  }
+ src/Morley/Client/Util.hs view
@@ -0,0 +1,130 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Client.Util+  ( epNameToTezosEp+  , extractAddressesFromValue+  , disableAlphanetWarning+  , runContract+  , runContractSimple+  , RunContractParameters(..)++  -- tezos-client password-related helpers+  , scrubbedBytesToString+  , readScrubbedBytes+  ) where++import Data.ByteArray (ScrubbedBytes, convert)+import qualified Data.ByteString as BS (getLine)+import Data.Constraint ((\\))+import Generics.SYB (everything, mkQ)+import System.Environment (setEnv)++import Morley.Client.RPC.AsRPC (AsRPC, rpcHasNoBigMapEvi, rpcStorageScopeEvi)+import Morley.Client.RPC.Class+import Morley.Client.RPC.Getters+import Morley.Client.RPC.Types+import Morley.Micheline+import Morley.Michelson.Text+import qualified Morley.Michelson.Typed as T (Contract, ParameterScope, StorageScope, Value)+import Morley.Michelson.Typed.Entrypoints (EpAddress(..), parseEpAddress)+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.Util.Exception as E (throwLeft)++-- | Sets the environment variable for disabling tezos-client+-- "not a mainnet" warning+disableAlphanetWarning :: IO ()+disableAlphanetWarning = setEnv "TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" "YES"++-- | Convert 'EpName' to the textual representation used by RPC and tezos-client.+epNameToTezosEp :: EpName -> Text+epNameToTezosEp = \case+  DefEpName -> "default"+  epName -> unEpName epName++-- | Extract all addresses value from given untyped 'Value'.+--+-- Note that it returns all values that can be used as an address.+-- However, some of fetched values can never be used as an address.+extractAddressesFromValue :: Value -> [Address]+extractAddressesFromValue val =+  everything (<>) (mkQ [] fetchAddress) val+  where+    fetchAddress :: Value -> [Address]+    fetchAddress = \case+      ValueString s -> case parseEpAddress (unMText s) of+        Right addr -> [eaAddress addr]+        Left _ -> []+      ValueBytes (InternalByteString b) -> case parseAddressRaw b of+        Right addr -> [addr]+        Left _ -> []+      _ -> []++-- | Simplified version of 'runContract' for convenience+--+-- Sets transfer amount to 0 and sender and source are both unspecified.+runContractSimple+  :: forall cp st m. (HasTezosRpc m, T.ParameterScope cp, T.StorageScope st)+  => T.Contract cp st -- ^ Contract+  -> T.Value cp -- ^ Parameter passed to the contract+  -> T.Value st -- ^ Initial storage+  -> Mutez -- ^ Initial balance+  -> m (AsRPC (T.Value st))+runContractSimple rcpContract rcpParameter rcpStorage rcpBalance =+  let rcpSender = Nothing+      rcpSource = Nothing+      rcpAmount = zeroMutez+  in runContract RunContractParameters {..}++-- | A structure with all the parameters for 'runContract'+data RunContractParameters cp st = RunContractParameters+  { rcpContract :: T.Contract cp st+  , rcpParameter :: T.Value cp+  , rcpStorage :: T.Value st+  , rcpBalance :: Mutez+  , rcpAmount :: Mutez+  , rcpSender :: Maybe Address+  , rcpSource :: Maybe Address+  }++-- | Run contract with given parameter and storage and get new storage without+-- injecting anything to the chain.+--+-- Storage type is limited to not have any bigmaps because their updates are treated differently+-- in node RPC and its quite nontrivial to properly support storage update when storage type+-- contains bigmaps.+runContract+  :: forall cp st m. (HasTezosRpc m, T.ParameterScope cp, T.StorageScope st)+  => RunContractParameters cp st -> m (AsRPC (T.Value st))+runContract RunContractParameters{..} = do+  headConstants <- getBlockConstants HeadId+  let args = RunCode+        { rcScript = toExpression rcpContract+        , rcStorage = toExpression rcpStorage+        , rcInput = toExpression rcpParameter+        , rcAmount = TezosMutez rcpAmount+        , rcBalance = TezosMutez rcpBalance+        , rcChainId = bcChainId headConstants+        , rcSource = rcpSender+        , rcPayer = rcpSource+        }+  res <- runCode args+  throwLeft @_ @FromExpressionError $ pure $+    fromExpression @(AsRPC (T.Value st)) (rcrStorage res)+      \\ rpcStorageScopeEvi @st+      \\ rpcHasNoBigMapEvi @st++-- | Function for relatively safe getting password from stdin.+-- After reading bytes are converted to @ScrubbedBytes@, thus it's harder+-- to accidentally leak them.+readScrubbedBytes :: MonadIO m => m ScrubbedBytes+readScrubbedBytes = convert <$> liftIO BS.getLine++-- | Convert @ScrubbedBytes@ to @String@, so that it can be passed to @tezos-client@+-- as a stdin+scrubbedBytesToString :: ScrubbedBytes -> String+scrubbedBytesToString = decodeUtf8 . convert @ScrubbedBytes @ByteString
+ src/Morley/Util/Batching.hs view
@@ -0,0 +1,106 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Morley.Util.Batching+  ( BatchingM+  , runBatching+  , unsafeRunBatching+  , submitThenParse++  , BatchingError (..)+  ) where++import Control.Monad.Except (Except, runExcept, throwError)+import Fmt (Buildable(..), pretty)++-- | Errors that can occur during batching, usually because the+-- underlying function that performs batch operation returns output+-- that does not match the provided input.+data BatchingError e+  -- | The function that executes the batch returned less elements in+  -- output than were provided at input.+  = InsufficientOutput+  -- | The function that executes the batch returned more elements in+  -- output than were provided at input.+  | ExtraOutput+  -- | User-provided parsing method failed.+  -- Usually this means that output does not correspond to provided input.+  | UnexpectedElement e++instance Buildable e => Buildable (BatchingError e) where+  build = \case+    InsufficientOutput ->+      "Too few elements in output of batch operation"+    ExtraOutput ->+      "Too many elements in output of batch operation"+    UnexpectedElement e ->+      "Unexpected element: " <> build e++-- | Records operations to be executed in batch.+--+-- Chronologically, this works in 3 steps:+--+-- * Form the list of input items @i@;+-- * Perform the batch operation;+-- * Parse output items @o@ into result @a@, maybe producing error @e@.+--+-- However in code we usually want steps 1 and 3 to be grouped+-- and step 2 to be delayed - 'BatchingM' facilitates this separation.+--+-- Note that 'BatchingM' is fundamentally not a monad, rather just an applicative,+-- because within a batch you cannot use result of one operation in another+-- operation.+data BatchingM i o e a = BatchingM+  { bInput :: Endo [i]+    -- ^ All the provided input, in some sort of DList+  , bParseOutput :: StateT [o] (Except (BatchingError e)) a+    -- ^ Parser for output when it is available+  } deriving stock Functor++instance Applicative (BatchingM i o e) where+  pure a = BatchingM+    { bInput = mempty, bParseOutput = pure a }+  b1 <*> b2 = BatchingM+    { bInput = bInput b1 <> bInput b2+    , bParseOutput = bParseOutput b1 <*> bParseOutput b2+    }++-- | Run recorded operations sequence using the given batch executor.+runBatching+  :: (Functor m)+  => ([i] -> m (r, [o]))+  -> BatchingM i o e a+  -> m (r, Either (BatchingError e) a)+runBatching execBatch BatchingM{..} =+    second parseResult <$> execBatch (appEndo bInput [])+  where+    parseResult output =+      runExcept (runStateT bParseOutput output) >>= \case+        (a, []) -> pure a+        _ -> throwError ExtraOutput++-- | Similar to 'runBatching', for cases when the given batch executor+-- is guaranteed to return the output respective to the provided input.+unsafeRunBatching+  :: (Functor m, Buildable e)+  => ([i] -> m (r, [o]))+  -> BatchingM i o e a+  -> m (r, a)+unsafeRunBatching =+  fmap (second $ either (error . pretty) id) ... runBatching++-- | This is the basic primitive for all actions in 'BatchingM'.+--+-- It records that given input item should be put to batch, and once operation+-- is actually performed, the result should be parsed with given method.+submitThenParse :: i -> (o -> Either e a) -> BatchingM i o e a+submitThenParse inp parse = BatchingM+  { bInput = Endo (inp :)+  , bParseOutput = StateT $ \case+      [] -> throwError InsufficientOutput+      (o : os) -> case parse o of+        Left e -> throwError $ UnexpectedElement e+        Right x -> pure (x, os)+  }+infix 1 `submitThenParse`
+ test/Ingredients.hs view
@@ -0,0 +1,18 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Ingredients that we use in our test suite.++module Ingredients+  ( ourIngredients+  ) where++import Test.Tasty.Ingredients (Ingredient, composeReporters)+import Test.Tasty.Ingredients.Basic (consoleTestReporter, listingTests)+import Test.Tasty.Runners.AntXML (antXMLRunner)++-- | This is the default set of ingredients extended with the+-- 'antXMLRunner' which is used to generate xml reports for CI.+ourIngredients :: [Ingredient]+ourIngredients = [listingTests, antXMLRunner `composeReporters` consoleTestReporter]
+ test/Main.hs view
@@ -0,0 +1,15 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main+  ( main+  ) where++import Test.Tasty (defaultMainWithIngredients)++import Ingredients (ourIngredients)+import Tree (tests)++main :: IO ()+main = tests >>= defaultMainWithIngredients ourIngredients
+ test/Test/AsRPC.hs view
@@ -0,0 +1,658 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-star-is-type #-}++module Test.AsRPC+  ( unit_Renames_constructors_fields_and_generic_metadata+  , unit_Can_derive_many_instances_at_once+  , unit_Supports_higher_kinded_types+  , unit_Can_derive_instances_with_newtype+  , unit_Can_derive_many_instances_with_newtypes+  , unit_Can_derive_many_instances_with_type_aliases+  ) where++import Data.Typeable ((:~:)(Refl))+import GHC.Generics+import qualified Language.Haskell.TH.Syntax as TH+import Test.Tasty.HUnit (Assertion)++import Lorentz (BigMap, BigMapId, IsoValue(ToT), MText, customGeneric, leftBalanced, ligoLayout)+import Morley.Client.RPC.AsRPC++import Test.Util (shouldCompileIgnoringInstance, shouldCompileTo)++data ExampleStorage a b = ExampleStorage+  { _esField1 :: Integer+  , _esField2 :: [BigMap Integer MText]+  , _esField3 :: a+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "ExampleStorage"++unit_Renames_constructors_fields_and_generic_metadata :: Assertion+unit_Renames_constructors_fields_and_generic_metadata = do+  $(deriveRPC "ExampleStorage" >>= TH.lift) `shouldCompileTo`+    [d|+      data ExampleStorageRPC a (b :: k) = ExampleStorageRPC+        { _esField1RPC :: AsRPC Integer+        , _esField2RPC :: AsRPC [BigMap Integer MText]+        , _esField3RPC :: AsRPC a+        }++      type instance AsRPC (ExampleStorage a (b :: k)) = ExampleStorageRPC a (b :: k)+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (ExampleStorageRPC a (b :: k))++      instance Generic (ExampleStorageRPC a (b :: k))+          where type Rep (ExampleStorageRPC a+                                      (b :: k)) = D1 ('MetaData "ExampleStorageRPC" "Test.AsRPC" "main" 'False)+                                                      (C1 ('MetaCons "ExampleStorageRPC" 'PrefixI 'True)+                                                          ((:*:) (S1 ('MetaSel ('Just "_esField1RPC")+                                                                              'NoSourceUnpackedness+                                                                              'NoSourceStrictness+                                                                              'DecidedStrict)+                                                                    (Rec0 (AsRPC Integer)))+                                                                ((:*:) (S1 ('MetaSel ('Just "_esField2RPC")+                                                                                      'NoSourceUnpackedness+                                                                                      'NoSourceStrictness+                                                                                      'DecidedStrict)+                                                                            (Rec0 (AsRPC ([BigMap Integer+                                                                                                  MText]))))+                                                                        (S1 ('MetaSel ('Just "_esField3RPC")+                                                                                      'NoSourceUnpackedness+                                                                                      'NoSourceStrictness+                                                                                      'DecidedStrict)+                                                                            (Rec0 (AsRPC a))))))+                from (ExampleStorageRPC v0+                                  v1+                                  v2) = M1 (M1 ((:*:) (M1 (K1 v0)) ((:*:) (M1 (K1 v1)) (M1 (K1 v2)))))+                to (M1 (M1 ((:*:) (M1 (K1 v0))+                                  ((:*:) (M1 (K1 v1)) (M1 (K1 v2)))))) = ExampleStorageRPC v0 v1 v2+    |]++data Ex1 = Ex1 Integer Ex1Inner+  deriving stock Generic+  deriving anyclass IsoValue+data Ex1Inner = Ex1Inner Integer+  deriving stock Generic+  deriving anyclass IsoValue++data Ex2 = Ex2 Integer+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "Ex2"++data Ex3 = Ex3 Integer+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++data Ex4 a = Ex4 a+  deriving stock Generic+  deriving anyclass IsoValue++data ExampleMany = ExampleMany+  { _emField1 :: Integer+  , _emField2 :: Ex1+  , _emField3 :: Ex2+  , _emField4 :: [BigMap Ex3 (Ex4 MText)]+  }+  deriving stock Generic+  deriving anyclass IsoValue++-- Check that the declarations generated by `deriveManyRPC` actually compile.+deriveManyRPC "ExampleMany" []++unit_Can_derive_many_instances_at_once :: Assertion+unit_Can_derive_many_instances_at_once = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveManyRPC "ExampleMany" ["Ex3"] >>= TH.lift)+    [d|+      data ExampleManyRPC = ExampleManyRPC+        {_emField1RPC :: AsRPC Integer+        , _emField2RPC :: AsRPC Ex1+        , _emField3RPC :: AsRPC Ex2+        , _emField4RPC :: AsRPC [BigMap Ex3 (Ex4 MText)]+        }+      type instance AsRPC ExampleMany = ExampleManyRPC+      deriving anyclass instance IsoValue ExampleManyRPC++      -- An instance is generated for Ex1+      data Ex1RPC = Ex1RPC (AsRPC Integer) (AsRPC Ex1Inner)+      type instance AsRPC Ex1 = Ex1RPC+      deriving anyclass instance IsoValue Ex1RPC++      -- An instance is generated for Ex1's fields' types+      data Ex1InnerRPC = Ex1InnerRPC (AsRPC Integer)+      type instance AsRPC Ex1Inner = Ex1InnerRPC+      deriving anyclass instance IsoValue Ex1InnerRPC++      -- No instance is generated for Ex2, because one already exists++      -- No instance is generated for Ex3, because we explicitly said we don't want one++      -- An instance is generated for BigMap's concrete type arguments+      data Ex4RPC a = Ex4RPC (AsRPC a)+      type instance AsRPC (Ex4 a) = Ex4RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Ex4RPC a)+    |]++----------------------------------------------------------------------------+-- AsRPC type family+----------------------------------------------------------------------------++checkLaws :: ToT (AsRPC t) :~: AsRPC (ToT t) -> ()+checkLaws Refl = ()++----------------------------------------------------------------------------+-- Examples data types:+--+-- Simple data type+----------------------------------------------------------------------------++data Simple = Simple Integer Integer [Integer]+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "Simple"++data ExpectedSimpleRPC = ExpectedSimpleRPC Integer Integer [Integer]+  deriving stock Generic+  deriving anyclass IsoValue++_checkSimple :: ToT SimpleRPC :~: ToT ExpectedSimpleRPC+_checkSimple = Refl++_checkSimpleLaws :: ()+_checkSimpleLaws = checkLaws @Simple Refl++----------------------------------------------------------------------------+-- Simple record data type+----------------------------------------------------------------------------++data SimpleRecord = SimpleRecord+  { _simpleRecordField1 :: Integer+  , _simpleRecordField2 :: Integer+  , _simpleRecordField3 :: [Integer]+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "SimpleRecord"++data ExpectedSimpleRecordRPC = ExpectedSimpleRecordRPC+  { eSimpleRecordField1 :: Integer+  , eSimpleRecordField2 :: Integer+  , eSimpleRecordField3 :: [Integer]+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkSimpleRecord :: ToT SimpleRecordRPC :~: ToT ExpectedSimpleRecordRPC+_checkSimpleRecord = Refl++_checkSimpleRecordLaws :: ()+_checkSimpleRecordLaws = checkLaws @SimpleRecord Refl++----------------------------------------------------------------------------+-- Data type with bigmap fields+----------------------------------------------------------------------------++data WithBigMap = WithBigMap+  { _wbmField1 :: Integer+  , _wbmField2 :: BigMap Integer Integer+  , _wbmField3 :: [BigMap Integer Integer]+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "WithBigMap"++data ExpectedWithBigMapRPC = ExpectedWithBigMapRPC+  { expectedWbmField1 :: Integer+  , expectedWbmField2 :: BigMapId Integer Integer+  , expectedWbmField3 :: [BigMapId Integer Integer]+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithBigMap :: ToT WithBigMapRPC :~: ToT ExpectedWithBigMapRPC+_checkWithBigMap = Refl++_checkWithBigMapLaws :: ()+_checkWithBigMapLaws = checkLaws @WithBigMap Refl++----------------------------------------------------------------------------+-- Data type with custom generic strategy+----------------------------------------------------------------------------++data WithGenericStrategy+  = WithGenericStrategy_1 Integer Integer Integer+  | WithGenericStrategy_2 Integer Integer Integer+  | WithGenericStrategy_3 Integer Integer Integer+  | WithGenericStrategy_4 Integer Integer Integer++deriving anyclass instance IsoValue WithGenericStrategy+customGeneric "WithGenericStrategy" leftBalanced+deriveRPCWithStrategy "WithGenericStrategy" leftBalanced++_checkWithGenericStrategy :: ToT WithGenericStrategyRPC :~: ToT WithGenericStrategy+_checkWithGenericStrategy = Refl++_checkWithGenericStrategyLaws :: ()+_checkWithGenericStrategyLaws = checkLaws @WithGenericStrategy Refl++----------------------------------------------------------------------------+-- Data type with reordered fields+----------------------------------------------------------------------------++data WithReordered = WithRedordered+  { _wrField1 :: Integer+  , _wrField3 :: MText+  , _wrField2 :: [Integer]+  }++deriving anyclass instance IsoValue WithReordered+customGeneric "WithReordered" ligoLayout+deriveRPCWithStrategy "WithReordered" ligoLayout++_checkWithReordered :: ToT WithReorderedRPC :~: ToT WithReordered+_checkWithReordered = Refl++_checkWithReorderedLaws :: ()+_checkWithReorderedLaws = checkLaws @WithReordered Refl++----------------------------------------------------------------------------+-- Data type with type variables+----------------------------------------------------------------------------++data WithTypeVariables a = WithTypeVariables+  { _wtvField1 :: a+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "WithTypeVariables"++data ExpectedWithTypeVariablesRPC = ExpectedWithTypeVariablesRPC+  { expectedWtvField1 :: BigMapId Integer MText+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithTypeVariables :: ToT (WithTypeVariablesRPC (BigMap Integer MText)) :~: ToT ExpectedWithTypeVariablesRPC+_checkWithTypeVariables = Refl++_checkWithTypeVariablesLaws :: ()+_checkWithTypeVariablesLaws = checkLaws @(WithTypeVariables (BigMap Integer MText)) Refl++----------------------------------------------------------------------------+-- Data type with nested data types and type variables+----------------------------------------------------------------------------++data WithNested a = WithNested+  { _wnField1 :: WithNested2 a+  , _wnField2 :: [WithNested2 a]+  , _wnField3 :: WithNested2 [a]+  }+  deriving stock Generic+deriving anyclass instance IsoValue a => IsoValue (WithNested a)++data WithNested2 a = WithNested2+  { _wn2Field1 :: a+  , _wn2Field2 :: [a]+  }+  deriving stock Generic+  deriving anyclass IsoValue++deriveManyRPC "WithNested" []++data ExpectedWithNestedRPC = ExpectedWithNestedRPC+  { expectedWnField1 :: ExpectedWithNested2RPC+  , expectedWnField2 :: [ExpectedWithNested2RPC]+  , expectedWnField3 :: ExpectedWithNested2RPC'+  }+  deriving stock Generic+  deriving anyclass IsoValue++data ExpectedWithNested2RPC = ExpectedWithNested2RPC+  { expectedWn2Field1 :: BigMapId Integer MText+  , expectedWn2Field2 :: [BigMapId Integer MText]+  }+  deriving stock Generic+  deriving anyclass IsoValue++data ExpectedWithNested2RPC' = ExpectedWithNested2RPC'+  { expectedWn2Field1' :: [BigMapId Integer MText]+  , expectedWn2Field2' :: [[BigMapId Integer MText]]+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithNested2 :: ToT (WithNested2RPC (BigMap Integer MText)) :~: ToT ExpectedWithNested2RPC+_checkWithNested2 = Refl++_checkWithNested :: ToT (WithNestedRPC (BigMap Integer MText)) :~: ToT ExpectedWithNestedRPC+_checkWithNested = Refl++_checkWithNestedLaws :: ()+_checkWithNestedLaws = checkLaws @(WithNested (BigMap Integer MText)) Refl++_checkWithNested2Laws :: ()+_checkWithNested2Laws = checkLaws @(WithNested2 (BigMap Integer MText)) Refl++----------------------------------------------------------------------------+-- Data type with phantom type variables+----------------------------------------------------------------------------++data WithPhantom a b c = WithPhantom+  { _wpField1 :: Integer+  , _wpField2 :: b+  }+  deriving stock Generic+  deriving anyclass IsoValue+deriveRPC "WithPhantom"++data ExpectedWithPhantomRPC = ExpectedWithPhantomRPC+  { expectedWpField1 :: Integer+  , expectedWpField2 :: MText+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithPhantom :: ToT (WithPhantomRPC Integer MText (BigMap Integer Integer)) :~: ToT ExpectedWithPhantomRPC+_checkWithPhantom = Refl++_checkWithPhantomLaws :: ()+_checkWithPhantomLaws = checkLaws @(WithPhantom Integer MText (BigMap Integer Integer)) Refl++----------------------------------------------------------------------------+-- Data type with higher-kinded type variables+----------------------------------------------------------------------------++data WithHigherKind f = WithHigherKind+  { _whkField1 :: WithHigherKindNested f+  }+  deriving stock Generic+deriving anyclass instance (IsoValue (f Integer MText)) => IsoValue (WithHigherKind f)++data WithHigherKindNested f = WithHigherKindNested+  { _whknField1 :: f Integer MText+  }+  deriving stock Generic+deriving anyclass instance (IsoValue (f Integer MText)) => IsoValue (WithHigherKindNested f)++deriveManyRPC "WithHigherKind" []++unit_Supports_higher_kinded_types :: Assertion+unit_Supports_higher_kinded_types = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveManyRPC "WithHigherKind" [] >>= TH.lift)+    [d|+      data WithHigherKindRPC (f :: * -> * -> *) = WithHigherKindRPC+        { _whkField1RPC :: AsRPC (WithHigherKindNested f)+        }+      type instance AsRPC (WithHigherKind (f :: * -> * -> *))+        = WithHigherKindRPC (f :: * -> * -> *)+      deriving anyclass instance IsoValue (AsRPC (WithHigherKindNested f))+        => IsoValue (WithHigherKindRPC (f :: * -> * -> *))++      data WithHigherKindNestedRPC (f :: * -> * -> *) = WithHigherKindNestedRPC+        { _whknField1RPC :: AsRPC (f Integer MText)+        }+      type instance AsRPC (WithHigherKindNested (f :: * -> * -> *))+        = WithHigherKindNestedRPC (f :: * -> * -> *)+      deriving anyclass instance IsoValue (AsRPC (f Integer MText))+        => IsoValue (WithHigherKindNestedRPC (f :: * -> * -> *))+    |]++data ExpectedWithHigherKindRPC = ExpectedWithHigherKindRPC+  { expectedWhkField1 :: ExpectedWithHigherKindNestedRPC+  }+  deriving stock Generic+  deriving anyclass IsoValue++data ExpectedWithHigherKindNestedRPC = ExpectedWithHigherKindNestedRPC+  { expectedWhknField1 :: Map Integer MText+  }+  deriving stock Generic+  deriving anyclass IsoValue++_checkWithHigherKindNested :: ToT (WithHigherKindNestedRPC Map) :~: ToT ExpectedWithHigherKindNestedRPC+_checkWithHigherKindNested = Refl++_checkWithHigherKind :: ToT (WithHigherKindRPC Map) :~: ToT ExpectedWithHigherKindRPC+_checkWithHigherKind = Refl++_checkWithHigherKindLaws :: ()+_checkWithHigherKindLaws = checkLaws @(WithHigherKind Map) Refl++_checkWithHigherKindNestedLaws :: ()+_checkWithHigherKindNestedLaws = checkLaws @(WithHigherKindNested Map) Refl++----------------------------------------------------------------------------+-- Newtypes allowed with deriveRPC and in deriveManyRPC+----------------------------------------------------------------------------++data Data1 b = Data1 b+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++deriveRPC "Data1"++newtype Nt1 a b = Nt1 [Data1 a]+  deriving stock (Generic, Eq, Ord)+deriving anyclass instance IsoValue a => IsoValue (Nt1 a b)++deriveRPC "Nt1"++unit_Can_derive_instances_with_newtype :: Assertion+unit_Can_derive_instances_with_newtype = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveRPC "Nt1" >>= TH.lift)+    [d|+      newtype Nt1RPC a (b :: k) = Nt1RPC (AsRPC ([Data1 a]))+      type instance AsRPC (Nt1 a (b :: k)) = Nt1RPC a (b :: k)+      deriving anyclass instance IsoValue (AsRPC ([Data1 a])) => IsoValue (Nt1RPC a (b :: k))+    |]++newtype Nt2 = Nt2 { _nt2field :: Integer }+  deriving stock Generic+  deriving anyclass IsoValue++newtype Nt3 a = Nt3 a+  deriving stock Generic+  deriving anyclass IsoValue++newtype Nt4 a b = Nt4 (BigMap Integer MText)+  deriving stock Generic+  deriving anyclass IsoValue++newtype Nt5 a = Nt5 a+  deriving stock Generic+  deriving anyclass IsoValue++newtype Nt6 a = Nt6 (Nt5 a)+  deriving stock Generic+deriving anyclass instance IsoValue a => IsoValue (Nt6 a)++data Data2 a = Data2 (Nt6 a)+  deriving stock Generic+deriving anyclass instance IsoValue a => IsoValue (Data2 a)++data ExampleWithNewtypes = ExampleWithNewtypes+  { _ewnField1 :: Nt3 Nt2+  , _ewnField2 :: Nt4 MText Integer+  , _ewnField3 :: Data2 Integer+  }+  deriving stock Generic+  deriving anyclass IsoValue++deriveManyRPC "ExampleWithNewtypes" []++unit_Can_derive_many_instances_with_newtypes :: Assertion+unit_Can_derive_many_instances_with_newtypes = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveManyRPC "ExampleWithNewtypes" [] >>= TH.lift)+    [d|+      data ExampleWithNewtypesRPC = ExampleWithNewtypesRPC+        {_ewnField1RPC :: (AsRPC (Nt3 Nt2))+        , _ewnField2RPC :: (AsRPC (Nt4 MText Integer))+        , _ewnField3RPC :: (AsRPC (Data2 Integer))+        }++      type instance AsRPC ExampleWithNewtypes = ExampleWithNewtypesRPC+      deriving anyclass instance IsoValue ExampleWithNewtypesRPC++      newtype Nt3RPC a = Nt3RPC (AsRPC a)+      type instance AsRPC (Nt3 a) = Nt3RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Nt3RPC a)++      newtype Nt2RPC = Nt2RPC {_nt2fieldRPC :: (AsRPC Integer)}+      type instance AsRPC Nt2 = Nt2RPC+      deriving anyclass instance IsoValue Nt2RPC++      newtype Nt4RPC (a :: k) (b :: k) = Nt4RPC (AsRPC (BigMap Integer MText))+      type instance AsRPC (Nt4 (a :: k) (b :: k)) = Nt4RPC (a :: k) (b :: k)+      deriving anyclass instance IsoValue (Nt4RPC (a :: k) (b :: k))++      data Data2RPC a = Data2RPC (AsRPC (Nt6 a))+      type instance AsRPC (Data2 a) = Data2RPC a+      deriving anyclass instance IsoValue (AsRPC (Nt6 a)) => IsoValue (Data2RPC a)++      newtype Nt6RPC a = Nt6RPC (AsRPC (Nt5 a))+      type instance AsRPC (Nt6 a) = Nt6RPC a+      deriving anyclass instance IsoValue (AsRPC (Nt5 a)) => IsoValue (Nt6RPC a)++      newtype Nt5RPC a = Nt5RPC (AsRPC a)+      type instance AsRPC (Nt5 a) = Nt5RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Nt5RPC a)+    |]++----------------------------------------------------------------------------+-- Type aliases allowed with deriveManyRPC+----------------------------------------------------------------------------++type Ty1 = Integer++type Ty2 k v = BigMap k v++type Ty3 phantom = Ty1++data Dt1 = Dt1 Integer+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++data Dt2 a = Dt2 a+  deriving stock Generic+  deriving anyclass IsoValue++type Ty4 = Dt1++type Ty5 a = Dt2 a++data Dt3 k v = Dt3 k v+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++type Ty6 v = Dt3 Integer v++data Dt4 v = Dt4 (Ty6 v)+  deriving stock (Generic, Eq, Ord)+deriving anyclass instance IsoValue v => IsoValue (Dt4 v)++data Dt5 a = Dt5 a+  deriving stock Generic+  deriving anyclass IsoValue++type Ty7 (f :: Type -> Type) = (f Integer)++data Dt6 = Dt6 Integer+  deriving stock (Generic, Eq, Ord)+  deriving anyclass IsoValue++data Dt7 a b = Dt7 a b+  deriving stock Generic+  deriving anyclass IsoValue++data Dt8 = Dt8 [BigMap Integer MText]+  deriving stock Generic+  deriving anyclass IsoValue++type Ty8 (f :: Type -> Type -> Type) a = f a Dt6+type Ty9 (f :: Type -> Type -> Type) a = Ty8 f a+type Ty10 (f :: Type -> Type -> Type) a = Ty9 f a++data ExampleTypeAliasMany = ExampleTypeAliasMany+  { _etamField1 :: Ty1+  , _etamField2 :: Ty2 Integer MText+  , _etamField3 :: Ty3 Integer+  , _etamField4 :: Ty4+  , _etamField5 :: Ty5 Integer+  , _etamField6 :: Ty6 MText+  , _etamField7 :: Ty7 Dt5+  , _etamField8 :: Ty10 Dt7 Dt8+  , _etamField9 :: Dt4 Integer+  }+  deriving stock Generic+  deriving anyclass IsoValue++-- Check that the declarations generated by `deriveManyRPC` actually compile.+deriveManyRPC "ExampleTypeAliasMany" []++unit_Can_derive_many_instances_with_type_aliases :: Assertion+unit_Can_derive_many_instances_with_type_aliases = do+  shouldCompileIgnoringInstance ''Generic+    $(deriveManyRPC "ExampleTypeAliasMany" [] >>= TH.lift)+    [d|+      data ExampleTypeAliasManyRPC = ExampleTypeAliasManyRPC+        { _etamField1RPC :: AsRPC Ty1+        , _etamField2RPC :: AsRPC (Ty2 Integer MText)+        , _etamField3RPC :: AsRPC (Ty3 Integer)+        , _etamField4RPC :: AsRPC Ty4+        , _etamField5RPC :: AsRPC (Ty5 Integer)+        , _etamField6RPC :: AsRPC (Ty6 MText)+        , _etamField7RPC :: AsRPC (Ty7 Dt5)+        , _etamField8RPC :: AsRPC (Ty10 Dt7 Dt8)+        , _etamField9RPC :: AsRPC (Dt4 Integer)+        }+      type instance AsRPC ExampleTypeAliasMany = ExampleTypeAliasManyRPC+      deriving anyclass instance IsoValue ExampleTypeAliasManyRPC++      -- An instance is generated for Dt1+      data Dt1RPC = Dt1RPC (AsRPC Integer)+      type instance AsRPC Dt1 = Dt1RPC+      deriving anyclass instance IsoValue Dt1RPC++      -- An instance is generated for Dt2+      data Dt2RPC a = Dt2RPC (AsRPC a)+      type instance AsRPC (Dt2 a) = Dt2RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Dt2RPC a)++      -- An instance is generated for Dt3+      data Dt3RPC k v = Dt3RPC (AsRPC k) (AsRPC v)+      type instance AsRPC (Dt3 k v) = Dt3RPC k v+      deriving anyclass instance (IsoValue (AsRPC k), IsoValue (AsRPC v)) => IsoValue (Dt3RPC k v)++      -- An instance is generated for Dt5+      data Dt5RPC a = Dt5RPC (AsRPC a)+      type instance AsRPC (Dt5 a) = Dt5RPC a+      deriving anyclass instance IsoValue (AsRPC a) => IsoValue (Dt5RPC a)++      -- An instance is generated for Dt6+      data Dt6RPC = Dt6RPC (AsRPC Integer)+      type instance AsRPC Dt6 = Dt6RPC+      deriving anyclass instance IsoValue Dt6RPC++      -- An instance is generated for Dt7+      data Dt7RPC a b = Dt7RPC (AsRPC a) (AsRPC b)+      type instance AsRPC (Dt7 a b) = Dt7RPC a b+      deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (Dt7RPC a b)++      -- An instance is generated for Dt8+      data Dt8RPC = Dt8RPC (AsRPC ([BigMap Integer MText]))+      type instance AsRPC Dt8 = Dt8RPC+      deriving anyclass instance IsoValue Dt8RPC++      -- An instance is generated for Dt4+      data Dt4RPC v = Dt4RPC (AsRPC (Ty6 v))+      type instance AsRPC (Dt4 v) = Dt4RPC v+      deriving anyclass instance IsoValue (AsRPC (Ty6 v)) => IsoValue (Dt4RPC v)+    |]
+ test/Test/BigMapGet.hs view
@@ -0,0 +1,105 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.BigMapGet+  ( test_BigMapGetUnit+  ) where++import Data.Map (fromList, lookup)+import Test.HUnit (Assertion, assertFailure)+import Test.Hspec.Expectations (shouldThrow)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L+import Lorentz.Pack (expressionToScriptExpr)+import Morley.Micheline (decodeExpression)+import Morley.Tezos.Crypto (encodeBase58Check)++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 Test.Util+import TestM++bigMapGetHandlers :: Handlers TestM+bigMapGetHandlers = defaultHandlers+  { hGetContractBigMap = \blkId addr GetBigMap{..} -> do+      assertHeadBlockId blkId+      st <- get+      case lookup addr (msContracts st) of+        Nothing -> throwM $ UnknownContract $ AddressResolved addr+        Just ContractState{..} -> case csContractData of+          ImplicitContractData _ -> throwM $ UnexpectedImplicitContract addr+          ContractData _ mbBigMap -> case mbBigMap of+            Nothing -> throwM $ ContractDoesntHaveBigMap addr+            Just ContractStateBigMap{..} -> case lookup (encodeBase58Check $ expressionToScriptExpr bmKey) csbmMap of+              Nothing -> pure GetBigMapNotFound+              Just serializedValue -> pure $ GetBigMapResult $ decodeExpression serializedValue+  }++mockStateWithBigMapContract+  :: MockState+mockStateWithBigMapContract = defaultMockState+  { msContracts = fromList $+    [ (genesisAddress1, dumbContractState+        { csContractData = (csContractData dumbContractState) & \case+            ContractData os _ -> ContractData os $ Just $+              mapToContractStateBigMap @Integer @Integer bigMapId $ fromList [(2, 3), (3, 5)]+            implicitData -> implicitData+        })+    , (genesisAddress2, dumbContractState)+    ]+  }+  where+    bigMapId :: BigMapId Integer Integer+    bigMapId = BigMapId 123++test_BigMapGetUnit :: TestTree+test_BigMapGetUnit = testGroup "Mock test big map getter"+  [ testCase "Successful big map get" $ handleSuccessfulGet $+    runMockTest bigMapGetHandlers mockStateWithBigMapContract $+      readContractBigMapValue @'TInt @'TInt genesisAddress1 $+        L.toVal (3 :: Integer)+  , testCase "Value not found in big map" $ handleValueNotFound $+    runMockTest bigMapGetHandlers mockStateWithBigMapContract $+      readContractBigMapValue @'TInt @'TInt genesisAddress1 $+        L.toVal (4 :: Integer)+  , testCase "Contract without big map" $ handleContractWithoutBigMap $+    runMockTest bigMapGetHandlers mockStateWithBigMapContract $+      readContractBigMapValue @'TInt @'TInt genesisAddress2 $+        L.toVal (2 :: Integer)+  , testCase "Big map get for unknown contract" $ handleUnknownContract $+    runMockTest bigMapGetHandlers mockStateWithBigMapContract $+      readContractBigMapValue @'TInt @'TInt genesisAddress3 $+        L.toVal (2 :: Integer)+  ]+  where+    handleSuccessfulGet :: Either SomeException a -> Assertion+    handleSuccessfulGet (Right _) = pass+    handleSuccessfulGet (Left e) = assertFailure $ displayException e++    handleUnknownContract :: Either SomeException a -> Assertion+    handleUnknownContract (Right _) =+      assertFailure "Big map get unexpectedly didn't fail."+    handleUnknownContract (Left e) =+      shouldThrow (throwM e) $ \case+                                 UnknownContract _ -> True+                                 _ -> False++    handleValueNotFound :: Either SomeException a -> Assertion+    handleValueNotFound (Right _) =+      assertFailure "Big map get unexpectedly didn't fail."+    handleValueNotFound (Left e) =+      shouldThrow (throwM e) $ \case ValueNotFound -> True++    handleContractWithoutBigMap :: Either SomeException a -> Assertion+    handleContractWithoutBigMap (Right _) =+      assertFailure "Big map get unexpectedly didn't fail."+    handleContractWithoutBigMap (Left e) =+      shouldThrow (throwM e) $ \case+                                 ContractDoesntHaveBigMap _ -> True+                                 _ -> False
+ test/Test/Fees.hs view
@@ -0,0 +1,107 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Fees+  ( test_Fees_comp_iterations+  ) where++import Data.Map (fromList)+import Test.HUnit ((@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L+import Morley.Client.Action.Origination+import Morley.Client.Action.Transaction+import Morley.Client.RPC.Types+import Morley.Client.TezosClient+import Morley.Michelson.Runtime.GState (genesisAddress1, genesisAddress2)+import Morley.Michelson.Untyped.Entrypoints+import Morley.Tezos.Core (toMutez)+import Test.Util+import TestM++mockState+  :: MockState+mockState = defaultMockState+  { msContracts = fromList $+    [ (genesisAddress1, dumbImplicitContractState)+    , (genesisAddress2, dumbContractState)+    ]+  }++countForgesHandlers :: Handlers $ TestT (State Word)+countForgesHandlers = chainOperationHandlers+  { hForgeOperation = \blkId op -> do+      assertHeadBlockId blkId+      liftToMockTest $ modify (+1)+      hForgeOperation chainOperationHandlers blkId op++  , hRunOperation = \blkId RunOperation{..} -> do+      assertHeadBlockId blkId+      originatedContracts <- handleRunOperationInternal roOperation+      return RunOperationResult+        { rrOperationContents =+          one $ OperationContent $ RunMetadata+            { rmOperationResult = OperationApplied $+              -- Real-life numbers+              AppliedResult+                { arConsumedGas = 10100+                , arStorageSize = 250+                , arPaidStorageDiff = 250+                , arOriginatedContracts = originatedContracts+                , arAllocatedDestinationContracts = 0+                }+            , rmInternalOperationResults = []+            }+        }+  }++runForgesCountingTest :: HasCallStack => TestT (State Word) a -> Word+runForgesCountingTest action = do+  let (res, count) =+        usingState 0 $ runMockTestT countForgesHandlers mockState action+  case res of+    Left e -> error . toText $ "Test action failed: " <> displayException e+    Right _ -> count++averageContract :: L.Contract () () ()+averageContract = L.mkContractWith L.intactCompilationOptions $+  L.unpair L.# L.drop L.#+  foldl' (L.#) L.nop (replicate 100 (L.push () L.# L.drop)) L.#+  L.nil L.# L.pair++-- | For small contracts we would like to find proper fees in+-- one hop since fees evaluation requires RPC calls+-- (though lightweight ones like forgeOperation).+--+-- In case this test fails, it would be nice to adjust initial fees+-- so that we again need only one iteration. If that is impossible,+-- update/remove this test.+test_Fees_comp_iterations :: [TestTree]+test_Fees_comp_iterations =+  [ testCase "One transaction" $+      let forgeCalls =+            runForgesCountingTest $+              lTransfer genesisAddress1 genesisAddress2+                (toMutez 10) DefEpName () Nothing+      in forgeCalls @?= sum+          [ 2  -- for fees adjustment+          , 1  -- check on fees being on par+          , 0  -- forging the entire batch - reusing the previously forged op+          ]++  , testCase "One origination"+      let forgeCalls =+            runForgesCountingTest $+              lOriginateContract True "c"+                (AddressResolved genesisAddress1) (toMutez 10)+                averageContract () Nothing+      in forgeCalls @?= sum+          [ 2  -- for fees adjustment+          , 1  -- check on fees being on par+          , 0  -- forging the entire batch - reusing the previously forged op+          ]++  ]
+ test/Test/KeyRevealing.hs view
@@ -0,0 +1,101 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.KeyRevealing+  ( test_keyRevealing+  ) where++import Test.HUnit (Assertion, assertFailure)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L+import Morley.Client+import Morley.Michelson.Runtime.GState (genesisAddress1)+import Morley.Michelson.Typed+import Morley.Tezos.Core (toMutez)+import Test.Util+import TestM++mockState :: MockState+mockState = defaultMockState+  { msContracts = one ( genesisAddress1+                      , dumbImplicitContractState+                          { csContractData = ImplicitContractData $ Just dumbManagerKey }+                      )+  }++test_keyRevealing :: TestTree+test_keyRevealing = testGroup "Mock test key revealing"+  [ testCase "Manager key for new address is revealed only once for transfer" $ handleSuccess $+    runMockTest chainOperationHandlers mockState $ do+      senderAddress <- genKey $ AnAlias "sender"+      dummyTransfer genesisAddress1 senderAddress+      mbManagerKey <- getManagerKey senderAddress++      when (isJust mbManagerKey) $+        fail "Manager key was expected not to be revealed, but it's revealed."++      dummyTransfer senderAddress genesisAddress1+      mbManagerKey' <- getManagerKey senderAddress++      when (isNothing mbManagerKey') $+        fail "Manager key was expected to be revealed, but it's not revealed."++      local+        (const noRevealHandlers)+        (dummyTransfer senderAddress genesisAddress1)++  , testCase "Manager key for new address is revealed only once for origination" $ handleSuccess $+    runMockTest chainOperationHandlers mockState $ do+      originatorAddress <- genKey $ AnAlias "originator"+      dummyTransfer genesisAddress1 originatorAddress++      mbManagerKey <- getManagerKey originatorAddress++      when (isJust mbManagerKey) $+        fail "Manager key was expected not to be revealed, but it's revealed."++      originateDummy originatorAddress++      mbManagerKey' <- getManagerKey originatorAddress+      when (isNothing mbManagerKey') $+        fail "Manager key was expected to be revealed, but it's not revealed."++      local+        (const noRevealHandlers)+        (originateDummy originatorAddress)++  , testCase "Transfer from contract fails with proper error message, without details about revealing" $+    (runMockTest chainOperationHandlers mockState $ do+      (_, addr) <- originateDummy genesisAddress1+      dummyTransfer addr genesisAddress1)+    &+    \case+      (Left err) ->+        case fromException @TezosClientError err of+          Just (ContractSender _ "transfer") -> pass+          _ -> assertFailure $ "Test failed with unexpected error: " <> displayException err+      (Right _)  -> assertFailure "Test expected to fail, but it passed"+  ]+  where+    dummyTransfer from to =+      void $ transfer from to (toMutez 10) DefEpName (toVal ()) Nothing++    originateDummy addr =+      lOriginateContract True "dummy" (AddressResolved addr) (toMutez 10)+      dumbLorentzContract () Nothing++-- | Handlers which don't allow to reveal key.+noRevealHandlers :: (Monad m) => TestHandlers m+noRevealHandlers = TestHandlers $ chainOperationHandlers+  { hRevealKey = \_ _ -> throwM $ UnexpectedClientCall "revealKey" }++dumbLorentzContract :: L.Contract Integer () ()+dumbLorentzContract = L.defaultContract $+  L.drop L.# L.unit L.# L.nil L.# L.pair++handleSuccess :: Either SomeException a -> Assertion+handleSuccess (Left err) = assertFailure $ displayException err+handleSuccess (Right _)  = pass
+ test/Test/Origination.hs view
@@ -0,0 +1,57 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Origination+  ( test_lRunTransactionsUnit+  ) where++import Data.Map (fromList)+import Test.HUnit (Assertion, assertFailure)+import Test.Hspec.Expectations (shouldThrow)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L+import Morley.Client+import Morley.Michelson.Runtime.GState (genesisAddress1, genesisAddress2, genesisAddress3)+import Morley.Tezos.Core+import Test.Util+import TestM++mockState+  :: MockState+mockState = defaultMockState+  { msContracts = fromList $+    [ (genesisAddress1, dumbImplicitContractState)+    , (genesisAddress2, dumbContractState)+    ]+  }++dumbLorentzContract :: L.Contract Integer () ()+dumbLorentzContract = L.defaultContract $+  L.drop L.# L.unit L.# L.nil L.# L.pair++test_lRunTransactionsUnit :: TestTree+test_lRunTransactionsUnit = testGroup "Mock test transaction sending"+  [ testCase "Successful origination" $ handleSuccess $+    runMockTest chainOperationHandlers mockState $+      lOriginateContract True "dummy" (AddressResolved genesisAddress1) (toMutez 100500)+      dumbLorentzContract () Nothing+  , testCase "Originator doesn't exist" $ handleUnknownContract $+    runMockTest chainOperationHandlers mockState $+      lOriginateContract True "dummy" (AddressResolved genesisAddress3) (toMutez 100500)+      dumbLorentzContract () Nothing+  ]+  where+    handleSuccess :: Either SomeException a -> Assertion+    handleSuccess (Right _) = pass+    handleSuccess (Left e) = assertFailure $ displayException e++    handleUnknownContract :: Either SomeException a -> Assertion+    handleUnknownContract (Right _) =+      assertFailure "Origination unexpectedly didn't fail."+    handleUnknownContract (Left e) =+      shouldThrow (throwM e) $ \case+        UnknownContract _ -> True+        _ -> False
+ test/Test/ParameterTypeGet.hs view
@@ -0,0 +1,86 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.ParameterTypeGet+  ( test_parameterTypeGetUnit+  ) where++import Data.Map as Map (empty, fromList)+import Test.HUnit (Assertion, assertEqual, assertFailure)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L++import Morley.Client+import Morley.Client.RPC.Getters+import Morley.Client.RPC.Types+import Morley.Micheline+import Morley.Michelson.Runtime.GState (genesisAddress1)+import Morley.Michelson.TypeCheck.TypeCheck (SomeParamType, unsafeMkSomeParamType)+import Morley.Michelson.Typed+import qualified Morley.Michelson.Untyped as U+import Morley.Tezos.Address+import Test.Util+import TestM++testContract :: L.NiceParameterFull param => L.Contract param () ()+testContract = L.defaultContract $+  L.cdr L.# L.nil L.# L.pair++buildSmartContractState+  :: Alias -> L.Contract param () () -> ContractState+buildSmartContractState alias contract = ContractState+  { csCounter = 100500+  , csAlias = alias+  , csContractData = ContractData+      OriginationScript { osCode = toExpression contract, osStorage = toExpression $ toVal () }+      Nothing+  }++contractHash1, contractHash2, contractHash3 :: ContractHash+contractHash1 = ContractHash "lol"+contractHash2 = ContractHash "kek"+contractHash3 = ContractHash "mda"++smartContractAddr1, smartContractAddr2, smartContractAddr3 :: Address+smartContractAddr1 = ContractAddress contractHash1+smartContractAddr2 = ContractAddress contractHash2+smartContractAddr3 = ContractAddress contractHash3++mockStateWithSmartContracts+  :: MockState+mockStateWithSmartContracts = defaultMockState+  { msContracts = fromList $+    [ (smartContractAddr1, buildSmartContractState "lol" (testContract @Natural))+    , (smartContractAddr2, buildSmartContractState "kek" (testContract @Bool))+    , (genesisAddress1, dumbImplicitContractState)+    ]+  }++test_parameterTypeGetUnit :: TestTree+test_parameterTypeGetUnit = testGroup "Mock test big map getter"+  [ testCase "Only parameters for smart contracts are extracted" $ expectContractMap+    (runMockTest chainOperationHandlers mockStateWithSmartContracts $+      getContractsParameterTypes+      [genesisAddress1, smartContractAddr1, smartContractAddr2]+    ) $ fromList+    [ (contractHash1, unsafeMkSomeParamType $ U.ParameterType (U.Ty U.TNat U.noAnn) U.noAnn)+    , (contractHash2, unsafeMkSomeParamType $ U.ParameterType (U.Ty U.TBool U.noAnn) U.noAnn)+    ]+  , testCase "Parameter type for nonexistent smart contract is not extracted" $+    expectContractMap+    (runMockTest chainOperationHandlers mockStateWithSmartContracts $+      getContractsParameterTypes+      [smartContractAddr3]+    ) $ Map.empty+  ]+  where+    expectContractMap+      :: Either SomeException (Map ContractHash SomeParamType)+      -> Map ContractHash SomeParamType+      -> Assertion+    expectContractMap (Right found) expected =+      assertEqual "unexpected smart contract map" found expected+    expectContractMap (Left e) _ = assertFailure $ displayException e
+ test/Test/Parser.hs view
@@ -0,0 +1,55 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Parser+  ( test_bakerFeeParser+  , test_secretKeyEncriptionParser+  ) where++import Test.Hspec.Expectations (shouldBe, shouldSatisfy)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Morley.Client.TezosClient.Parser+import Morley.Client.TezosClient.Types (SecretKeyEncryption(..))+import Morley.Micheline+import Morley.Tezos.Core++test_bakerFeeParser :: TestTree+test_bakerFeeParser = testGroup "tezos-client baker fee parser"+  [ testCase "resulted fee is multiplied by 1e6" $+    parseBakerFeeFromOutput "Fee to the baker: ꜩ0.056008\n" 1 `shouldBe`+    Right [TezosMutez $ toMutez 56008]+  , testCase "multiples fees can be parsed" $+    parseBakerFeeFromOutput "Fee to the baker: ꜩ0.056008\n Fee to the baker: ꜩ0.056008\n" 2 `shouldBe`+    Right (replicate 2 $ TezosMutez $ toMutez 56008)+  , testCase "no valid baker fee in the output" $+    parseBakerFeeFromOutput "Notfee to the baker: ꜩ0.056008\n" 1 `shouldSatisfy`+    isLeft+  ]++test_secretKeyEncriptionParser :: TestTree+test_secretKeyEncriptionParser = testGroup "tezos-client baker fee parser"+  [ testCase "unencrypted type can be parsed" $+    parseSecretKeyEncryption+    "Secret Key: unencrypted:edsk4TybjbpfhcQ81R5FnxkoZy14ZyXRUzfbXrmPgqKRpcGPJanAgY" `shouldBe`+    Right UnencryptedKey+  , testCase "encrypted type can be parsed" $+    parseSecretKeyEncryption+    "Secret Key: encrypted:edesk1a9cTRUMXf6L5cZXMqojELRRfTEoLXc4JzT9B3PqnhWweJnuWgcSk93NBHXYGFxf1uKHFPihBgVzJNwUVHR"+    `shouldBe`+    Right EncryptedKey+  , testCase "ledger type can be parsed" $+    parseSecretKeyEncryption+    "Secret Key: ledger://live-fossa-eager-walrus/bip25519/0h/0h" `shouldBe`+    Right LedgerKey+  , testCase "nonsense cannot be parsed 1" $+    parseSecretKeyEncryption+    "Secret Key: kek://live-fossa-eager-walrus/bip25519/0h/0h" `shouldSatisfy`+    isLeft+  , testCase "nonsense cannot be parsed 2" $+    parseSecretKeyEncryption+    "Not a secret Key: ledger://live-fossa-eager-walrus/bip25519/0h/0h" `shouldSatisfy`+    isLeft+  ]
+ test/Test/ReadBigMapValue.hs view
@@ -0,0 +1,75 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.ReadBigMapValue+  ( test_ReadBigMapValueUnit+  , test_ReadBigMapValueMaybeUnit+  ) where++import Data.Map (fromList)+import Test.HUnit (Assertion, assertFailure)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Morley.Client.RPC.Getters+import Morley.Michelson.Runtime.GState (genesisAddress1)+import Morley.Michelson.Typed (BigMapId(..))+import Test.Util+import TestM++bigMapGetHandlers :: Handlers TestM+bigMapGetHandlers = defaultHandlers+  { hGetBigMapValue = handleGetBigMapValue+  }++mockStateWithBigMapContract+  :: MockState+mockStateWithBigMapContract = defaultMockState+  { msContracts = fromList $+    [ (genesisAddress1, dumbContractState+         { csContractData = (csContractData dumbContractState) & \case+             ContractData os _ -> ContractData os $ Just $+               mapToContractStateBigMap @Integer @Integer validBigMapId $ fromList [(2, 3), (3, 5)]+             implicitData -> implicitData+         }+      )+    ]+  }++validBigMapId :: BigMapId Integer Integer+validBigMapId = BigMapId 123++invalidBigMapId :: BigMapId Integer Integer+invalidBigMapId = BigMapId 456++resultShouldBe :: (HasCallStack, Eq a, Show a) => a -> Either SomeException a -> Assertion+resultShouldBe expected = \case+  Left e -> assertFailure $ displayException e+  Right actual -> actual @?= expected++test_ReadBigMapValueUnit :: TestTree+test_ReadBigMapValueUnit =+  testGroup "readBigMapValue"+    [ testCase "Retrieves existing value" $+        resultShouldBe 5 $+          runMockTest bigMapGetHandlers mockStateWithBigMapContract $+            readBigMapValue validBigMapId (3 :: Integer)+    ]++test_ReadBigMapValueMaybeUnit :: TestTree+test_ReadBigMapValueMaybeUnit =+  testGroup "readBigMapValueMaybe"+    [ testCase "Retrieves existing value" $+        resultShouldBe (Just 5) $+          runMockTest bigMapGetHandlers mockStateWithBigMapContract $+            readBigMapValueMaybe validBigMapId (3 :: Integer)+    , testCase "Returns Nothing when contract does not exist" $+        resultShouldBe Nothing $+          runMockTest bigMapGetHandlers mockStateWithBigMapContract $+            readBigMapValueMaybe invalidBigMapId (3 :: Integer)+    , testCase "Returns Nothing when key does not exist" $+        resultShouldBe Nothing $+          runMockTest bigMapGetHandlers mockStateWithBigMapContract $+            readBigMapValueMaybe validBigMapId (9 :: Integer)+    ]
+ test/Test/Transaction.hs view
@@ -0,0 +1,57 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Transaction+  ( test_lRunTransactionsUnit+  ) where++import Data.Map (fromList)+import Test.HUnit (Assertion, assertFailure)+import Test.Hspec.Expectations (shouldThrow)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Morley.Client.Action.Transaction+import Morley.Michelson.Runtime.GState (genesisAddress1, genesisAddress2, genesisAddress3)+import Morley.Michelson.Untyped.Entrypoints+import Morley.Tezos.Core (toMutez)+import Test.Util+import TestM++mockState+  :: MockState+mockState = defaultMockState+  { msContracts = fromList $+    [ (genesisAddress1, dumbImplicitContractState)+    , (genesisAddress2, dumbContractState)+    ]+  }++test_lRunTransactionsUnit :: TestTree+test_lRunTransactionsUnit = testGroup "Mock test transaction sending"+  [ testCase "Successful transaction" $ handleSuccess $+    runMockTest chainOperationHandlers mockState $+      lTransfer genesisAddress1 genesisAddress2+        (toMutez 10) DefEpName () Nothing+  , testCase "Sender doesn't exist" $ handleUnknownContract $+    runMockTest chainOperationHandlers mockState $+      lTransfer genesisAddress3 genesisAddress2+        (toMutez 10) DefEpName () Nothing+  , testCase "Destination doesn't exist" $ handleUnknownContract $+    runMockTest chainOperationHandlers mockState $+      lTransfer genesisAddress1 genesisAddress3+        (toMutez 10) DefEpName () Nothing+  ]+  where+    handleSuccess :: Either SomeException a -> Assertion+    handleSuccess (Right _) = pass+    handleSuccess (Left e) = assertFailure $ displayException e++    handleUnknownContract :: Either SomeException a -> Assertion+    handleUnknownContract (Right _) =+      assertFailure "Transaction sending unexpectedly didn't fail."+    handleUnknownContract (Left e) =+      shouldThrow (throwM e) $ \case+        UnknownContract _ -> True+        _ -> False
+ test/Test/Util.hs view
@@ -0,0 +1,426 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Module with various helpers that are used in morley-client mock tests.+module Test.Util+  ( chainOperationHandlers+  , dumbContractState+  , dumbImplicitContractState+  , dumbManagerKey+  , mapToContractStateBigMap+  , handleGetBigMapValue++    -- * TemplateHaskell test helpers+  , shouldCompileTo+  , shouldCompileIgnoringInstance+    -- * Internals+  , handleRunOperationInternal+  , assertHeadBlockId+  ) where++import Prelude hiding (Type)++import Control.Exception.Safe (throwString)+import Control.Lens (at, (?~))+import Data.Aeson (encode)+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteString.Lazy as LBS (toStrict)+import qualified Data.Generics as SYB+import Data.Map as Map (elems, fromList, insert, lookup, toList)+import Data.Singletons (demote)+import Fmt ((+|), (|+))+import Language.Haskell.TH (pprint)+import Language.Haskell.TH.Syntax+  (Dec(..), Name, Q, TyVarBndr(..), Type(..), mkName, nameBase, runQ)+import Network.HTTP.Types.Status (status404)+import Network.HTTP.Types.Version (http20)+import Servant.Client.Core+  (BaseUrl(..), ClientError(..), RequestF(..), ResponseF(..), Scheme(..), defaultRequest)+import Test.Tasty.HUnit (Assertion, (@?=))+import Text.Hex (encodeHex)+import qualified Text.Show (show)++import Lorentz as L (compileLorentz, drop)+import Lorentz.Constraints+import Lorentz.Pack+import Morley.Client.RPC.Types+import Morley.Client.TezosClient.Types+import Morley.Micheline+import Morley.Michelson.Typed+import Morley.Tezos.Address+import Morley.Tezos.Core+import Morley.Tezos.Crypto+import qualified Morley.Tezos.Crypto.Ed25519 as Ed25519+import Morley.Util.ByteString+import TestM++-- | Function to convert given map to big map representation+-- used in mock state.+mapToContractStateBigMap+  :: forall k v. (NicePackedValue k, NicePackedValue v)+  => BigMapId k v -> Map k v -> ContractStateBigMap+mapToContractStateBigMap (BigMapId bigMapId) map' = ContractStateBigMap+  { csbmKeyType = toExpression $ demote @(ToT k)+  , csbmValueType = toExpression $ demote @(ToT v)+  , csbmMap = fromList $+    map (bimap (encodeBase58Check . valueToScriptExpr) lEncodeValue) $+    Map.toList map'+  , csbmId = bigMapId+  }++-- | Initial simple contract mock state.+dumbContractState :: ContractState+dumbContractState = ContractState+  { csCounter = 100500+  , csAlias = "genesis2"+  , csContractData = ContractData+      OriginationScript+        { osCode    = toExpression $ compileLorentz L.drop+        , osStorage = toExpression $ toVal ()+        }+      Nothing+  }++dumbImplicitContractState :: ContractState+dumbImplicitContractState = ContractState+  { csCounter = 100500+  , csAlias = "genesis1"+  , csContractData = ImplicitContractData Nothing+  }++-- | Mock handlers used for transaction sending and contract origination.+chainOperationHandlers :: Monad m => Handlers (TestT m)+chainOperationHandlers = defaultHandlers+  { hGetBlockHash = handleGetBlockHash+  , hGetCounter = handleGetCounter+  , hGetBlockConstants = handleGetBlockConstants+  , hGetProtocolParameters = handleGetProtocolParameters+  , hRunOperation = handleRunOperation+  , hPreApplyOperations = mapM . handlePreApplyOperation+  , hForgeOperation = \blkId arg -> do+      assertHeadBlockId blkId+      pure . HexJSONByteString . LBS.toStrict . encode $ arg+  , hInjectOperation = pure . OperationHash . (<> "_injected") . encodeHex . unHexJSONByteString+  , hGetContractScript = handleGetContractScript+  , hSignBytes =+    \_ _ -> pure . SignatureEd25519 . Ed25519.sign testSecretKey+  , hWaitForOperation = const pass+  , hGetAlias = handleGetAlias+  , hResolveAddressMaybe = handleResolveAddressMaybe+  , hRememberContract = handleRememberContract+  , hCalcTransferFee = \_ _ _ _ -> pure $ [TezosMutez $ toMutez 100500]+  , hCalcOriginationFee = \_ -> pure $ TezosMutez $ toMutez 100500+  , hGetKeyPassword = \_ -> pure Nothing+  , hGenKey = handleGenKey+  , hGetManagerKey = handleGetManagerKey+  , hRevealKey = handleRevealKey+  }+  where+    testSecretKey :: Ed25519.SecretKey+    testSecretKey = Ed25519.detSecretKey "\001\002\003\004"++mkRunOperationResult :: [Address] -> RunOperationResult+mkRunOperationResult originatedContracts = RunOperationResult+  { rrOperationContents =+    one $ OperationContent $ RunMetadata+      { rmOperationResult = OperationApplied $+        AppliedResult 100500 100500 100500 originatedContracts 0+      , rmInternalOperationResults = []+      }+  }++handleGetBlockHash :: Monad m => BlockId -> TestT m Text+handleGetBlockHash blkId = do+  assertHeadBlockId blkId+  MockState{..} <- get+  pure $ msHeadBlock++handleGetCounter+  :: ( MonadState MockState m+     , MonadThrow m+     )+  => BlockId -> Address -> m TezosInt64+handleGetCounter blk addr = do+  assertHeadBlockId blk+  MockState{..} <- get+  case lookup addr msContracts of+    Nothing -> throwM $ UnknownContract $ AddressResolved addr+    Just ContractState{..} -> pure $ csCounter++handleGetBlockConstants+  :: MonadState MockState m+  => anything -> m BlockConstants+handleGetBlockConstants _ = do+  MockState{..} <- get+  pure $ msBlockConstants++handleGetProtocolParameters+  :: (MonadState MockState m, MonadThrow m)+  => BlockId -> m ProtocolParameters+handleGetProtocolParameters blk = do+  assertHeadBlockId blk+  MockState{..} <- get+  pure $ msProtocolParameters++handleRunOperation :: Monad m => BlockId -> RunOperation -> TestT m RunOperationResult+handleRunOperation blk RunOperation{..} = do+  assertHeadBlockId blk+  MockState{..} <- get+  -- Ensure that passed chain id matches with one that mock state has+  unless (roChainId == bcChainId msBlockConstants) (throwM $ InvalidChainId)+  originatedContracts <- handleRunOperationInternal roOperation+  pure $ mkRunOperationResult originatedContracts++handlePreApplyOperation :: Monad m => BlockId -> PreApplyOperation -> TestT m RunOperationResult+handlePreApplyOperation blk PreApplyOperation{..} = do+  assertHeadBlockId blk+  MockState{..} <- get+  -- Ensure that passed protocol matches with one that mock state has+  unless (paoProtocol == bcProtocol msBlockConstants) (throwM $ InvalidProtocol)+  originatedContracts <- concatMapM handleTransactionOrOrigination paoContents+  pure $ mkRunOperationResult originatedContracts++handleRunOperationInternal :: Monad m => RunOperationInternal -> TestT m [Address]+handleRunOperationInternal RunOperationInternal{..} = do+  concatMapM handleTransactionOrOrigination roiContents++handleTransactionOrOrigination+  :: Monad m => Either TransactionOperation OriginationOperation -> TestT m [Address]+handleTransactionOrOrigination op = do+  MockState{..} <- get+  case op of+    -- Ensure that transaction sender exists+    Left TransactionOperation{..} -> case lookup codSource msContracts of+      Nothing -> throwM $ UnknownContract $ AddressResolved codSource+      Just ContractState{..} -> do+        -- Ensure that sender counter matches+        unless (csCounter + 1 == codCounter) (throwM CounterMismatch)+        case lookup toDestination msContracts of+          Nothing -> throwM $ UnknownContract $ AddressResolved toDestination+          Just _ -> pure []+      where+        CommonOperationData{..} = toCommonData+    -- Ensure that originator exists+    Right OriginationOperation{..} -> case lookup codSource msContracts of+      Nothing -> throwM $ UnknownContract $ AddressResolved codSource+      Just ContractState{..} -> do+        -- Ensure that originator counter matches+        unless (csCounter + 1 == codCounter) (throwM CounterMismatch)+        pure [dummyContractAddr]+      where+        CommonOperationData{..} = ooCommonData+        dummyContractAddr = unsafeParseAddress "KT1LZwEZqbqtLYhwzaidBp6So9LgYDpkpEv7"++-- We don't pass non-head block anywhere in @morley-client@, this feature+-- exists only for external users.+assertHeadBlockId :: MonadThrow m => BlockId -> m ()+assertHeadBlockId blockId = unless (blockId == HeadId) $+  throwString "Accessing non-head block is not supported in tests"++handleGetContractScript+  :: ( MonadState MockState m+     , MonadThrow m+     )+  => BlockId+  -> Address+  -> m OriginationScript+handleGetContractScript blockId addr = do+  assertHeadBlockId blockId+  MockState{..} <- get+  case lookup addr msContracts of+    Nothing -> throwM $ err404 path+    Just ContractState{..} -> case csContractData of+      ImplicitContractData _ -> throwM $ UnexpectedImplicitContract addr+      ContractData script _ -> pure script+  where+    path = "/chains/main/blocks/head/context/contracts/" <> formatAddress addr <> "/script"++handleGetBigMapValue :: Monad m => BlockId -> Natural -> Text -> TestT m Expression+handleGetBigMapValue blockId bigMapId scriptExpr = do+  assertHeadBlockId blockId+  st <- get++  let allBigMaps :: [ContractStateBigMap] =+        catMaybes $+          Map.elems (msContracts st) <&> \cs -> case (csContractData cs) of+            ContractData _ bigMapMaybe -> bigMapMaybe+            ImplicitContractData _ -> Nothing++  -- Check if a big_map with the given ID exists and, if so, check+  -- whether the giv en key exists.+  case find (\bigMap -> csbmId bigMap == bigMapId) allBigMaps of+    Nothing -> throwM $ err404 path+    Just bigMap ->+      case lookup scriptExpr (csbmMap bigMap ) of+        Nothing -> throwM $ err404 path+        Just serializedValue -> pure $ decodeExpression serializedValue+  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+  let+    cs = dumbContractState { csAlias = alias }+    remember addr' cs' MockState{..} =+      modify $ \s -> s { msContracts = insert addr' cs' msContracts }++  st@MockState{..} <- get+  case lookup addr msContracts of+    Nothing -> remember addr cs st+    _       -> bool pass (remember addr cs st) replaceExisting++handleGenKey :: Monad m => AliasOrAliasHint -> TestT m Address+handleGenKey (getAlias -> alias) = do+  let+    addr = detGenKeyAddress (encodeUtf8 $ unsafeGetAliasText alias)+    newContractState = dumbImplicitContractState { csAlias =  alias }+  modify $ \s ->+    s & msContractsL . at addr ?~ newContractState+  pure addr++handleGetAlias :: Monad m => AddressOrAlias -> TestT m Alias+handleGetAlias = \case+  AddressAlias alias -> pure alias+  AddressResolved addr -> do+    MockState{..} <- get+    case lookup addr msContracts of+      Nothing                -> throwM $ UnknownContract $ AddressResolved addr+      Just ContractState{..} -> pure $ csAlias++handleGetManagerKey :: (Monad m) => BlockId -> Address -> TestT m (Maybe PublicKey)+handleGetManagerKey blk addr = do+  assertHeadBlockId blk+  s <- get+  let mbCs = s ^. msContractsL . at addr+  case mbCs of+    Just ContractState{..} -> case csContractData of+      ImplicitContractData mbManagerKey -> pure mbManagerKey+      ContractData _ _ -> throwString "Only implicit account can have a manager key"+    Nothing -> throwM $ UnknownContract $ AddressResolved addr++-- In scenarios where the system under test checks for 404 errors, we+-- use this function to mock and simulate those errors.+err404 :: Text -> ClientError+err404 path = FailureResponse+  (defaultRequest { requestBody = Nothing, requestPath = (baseUrl , "") })+  response+  where+    baseUrl = BaseUrl+      { baseUrlScheme = Http+      , baseUrlHost = "localhost"+      , baseUrlPort = 8732+      , baseUrlPath = toString path+      }+    response = Response+      { responseStatusCode = status404+      , responseHeaders = mempty+      , responseHttpVersion = http20+      , responseBody = "Contract with given address not found"+      }++handleResolveAddressMaybe :: Monad m => AddressOrAlias -> TestT m (Maybe Address)+handleResolveAddressMaybe = \case+  AddressResolved addr -> pure (Just addr)+  AddressAlias alias -> do+    MockState{..} <- get+    case find checkAlias $ Map.toList msContracts of+      Just (addr, _) -> pure (Just addr)+      Nothing -> pure Nothing+    where+      checkAlias (_, ContractState { csAlias = alias' }) = alias == alias'++handleRevealKey :: Monad m => Alias -> Maybe ScrubbedBytes -> TestT m ()+handleRevealKey alias _ = do+  contracts <- gets (Map.toList . msContracts)+  let contracts' = filter (\(_, ContractState{..}) -> csAlias == alias) contracts+  case contracts' of+    []  -> throwM $ UnknownContract $ AddressAlias alias+    [(addr, cs@ContractState{..})] ->+      case (addr, csContractData) of+        (ContractAddress _, ContractData _ _) ->+          throwM $ CantRevealContract addr+        (KeyAddress _, ImplicitContractData (Just _)) ->+          throwM $ AlreadyRevealed addr+        (KeyAddress _, ImplicitContractData Nothing) ->+            -- We don't care about the public key itself, but only its presence.+            let newContractState = cs { csContractData = ImplicitContractData $ Just dumbManagerKey }+            in modify $ \s -> s & msContractsL . at addr ?~ newContractState+        _ -> error "Inconsitent mock state. This most likely a bug in tests."+    _   ->+      error $ "Multiple contracts have alias '" +| alias |++        "'. This is most likely a bug in tests."++-- | Dummy public key used in mock tests.+dumbManagerKey :: PublicKey+dumbManagerKey = fromRight (error "impossible") $ parsePublicKey+  "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"++----------------------------------------------------------------------------+-- TemplateHaskell test helpers+----------------------------------------------------------------------------++shouldCompileTo :: HasCallStack => [Dec] -> Q [Dec] -> Assertion+shouldCompileTo actualDecs expectedQ = do+  expectedDecs <- runQ expectedQ+  PrettyDecs (normalizeDecs actualDecs) @?= PrettyDecs (normalizeDecs expectedDecs)++-- | Same as 'shouldCompileTo', but ignores instance declarations of the given class.+shouldCompileIgnoringInstance :: HasCallStack => Name -> [Dec] -> Q [Dec] -> Assertion+shouldCompileIgnoringInstance className actualDecs expectedQ = do+  expectedDecs <- runQ expectedQ+  let actualDecs' = filter (not . isInstance) actualDecs+  PrettyDecs (normalizeDecs actualDecs') @?= PrettyDecs (normalizeDecs expectedDecs)++  where+    isInstance :: Dec -> Bool+    isInstance = \case+      InstanceD _ _ (ConT t `AppT` _) _ | t == className -> True+      _ -> False++-- | Normalize ASTs to make them comparable.+--+-- By default, quoted ASTs and ASTs with names created using 'newName' will have+-- names with unique IDs.+-- For example:+--+-- > decs <- runQ [d|data D = D { f :: Int } |]+-- > putStrLn $ pprint decs+-- >+-- > -- Will generate this AST:+-- > data D_0 = D_1 { f_2 :: Int }+--+-- To be able to check if two ASTs are equivalent, we have to scrub the unique IDs off all names.+--+-- For convenience, to make the output easier to read, we also erase kind annotations when the kind is '*'.+normalizeDecs :: [Dec] -> [Dec]+normalizeDecs decs =+    SYB.everywhere+      (SYB.mkT fixName . SYB.mkT simplifyType . SYB.mkT simplifyTyVar)+      decs+  where+    fixName :: Name -> Name+    fixName = mkName . nameBase++    simplifyType :: Type -> Type+    simplifyType = \case+      SigT t StarT -> t+      t -> t++    simplifyTyVar :: TyVarBndr -> TyVarBndr+    simplifyTyVar = \case+     KindedTV name StarT -> PlainTV name+     tv -> tv++newtype PrettyDecs = PrettyDecs [Dec]+  deriving newtype Eq++instance Show PrettyDecs where+  show (PrettyDecs decs) = pprint decs
+ test/TestM.hs view
@@ -0,0 +1,336 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Module that defines some basic infrastructure+-- for mocking tezos-node RPC interaction.+module TestM+  ( ContractData (..)+  , ContractState (..)+  , ContractStateBigMap (..)+  , Handlers (..)+  , MockState (..)+  , TestError (..)+  , TestHandlers (..)+  , TestM+  , TestT+  , defaultHandlers+  , defaultMockState+  , runMockTest+  , runMockTestT+  , liftToMockTest++  -- * Lens+  , msContractsL+  ) where++import Colog.Core.Class (HasLog(..))+import Colog.Message (Message)+import Control.Lens (makeLensesFor)+import Control.Monad.Catch.Pure (CatchT(..))+import Data.ByteArray (ScrubbedBytes)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)++import Morley.Client+import Morley.Client.Logging (ClientLogAction)+import Morley.Client.RPC+import Morley.Client.TezosClient (CalcOriginationFeeData, CalcTransferFeeData, TezosClientConfig)+import Morley.Micheline+import Morley.Michelson.Typed.Scope (UntypedValScope)+import Morley.Tezos.Address+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++-- | Reader environment to interact with the mock state.+data Handlers m = Handlers+  { -- HasTezosRpc+    hGetBlockHash :: BlockId -> m Text+  , hGetCounter :: BlockId -> Address -> m TezosInt64+  , hGetBlockHeader :: BlockId -> m BlockHeader+  , hGetBlockConstants :: BlockId -> m BlockConstants+  , hGetBlockOperations :: BlockId -> m [[BlockOperation]]+  , hGetProtocolParameters :: BlockId -> m ProtocolParameters+  , hRunOperation :: BlockId -> RunOperation -> m RunOperationResult+  , hPreApplyOperations :: BlockId -> [PreApplyOperation] -> m [RunOperationResult]+  , hForgeOperation :: BlockId -> ForgeOperation -> m HexJSONByteString+  , hInjectOperation :: HexJSONByteString -> m OperationHash+  , hGetContractScript :: BlockId -> Address -> m OriginationScript+  , hGetContractBigMap :: BlockId -> Address -> GetBigMap -> m GetBigMapResult+  , hGetBigMapValue :: BlockId -> Natural -> Text -> m Expression+  , hGetBigMapValues :: BlockId -> Natural -> Maybe Natural -> Maybe Natural -> m Expression+  , hGetBalance :: BlockId -> Address -> m Mutez+  , hRunCode :: BlockId -> RunCode -> m RunCodeResult+  , hGetChainId :: m ChainId+  , hGetManagerKey :: BlockId -> Address -> m (Maybe PublicKey)+  , hGetDelegateAtBlock :: BlockId -> Address -> m (Maybe KeyHash)++  -- HasTezosClient+  , hSignBytes :: AddressOrAlias -> Maybe ScrubbedBytes -> ByteString -> m Signature+  , hGenKey :: AliasOrAliasHint -> m Address+  , hGenFreshKey :: AliasOrAliasHint -> m Address+  , hRevealKey :: Alias -> Maybe ScrubbedBytes -> m ()+  , hWaitForOperation :: OperationHash -> m ()+  , hRememberContract :: Bool -> Address -> AliasOrAliasHint -> m ()+  , hImportKey :: Bool -> AliasOrAliasHint -> SecretKey -> m ()+  , hResolveAddressMaybe :: AddressOrAlias -> m (Maybe Address)+  , hGetAlias :: AddressOrAlias -> m Alias+  , hGetPublicKey :: AddressOrAlias -> m PublicKey+  , 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 ()++  -- HasLog+  , hLogAction :: ClientLogAction m+  }++defaultHandlers :: Monad m => Handlers (TestT m)+defaultHandlers = Handlers+  { hGetBlockHash = \_ -> throwM $ UnexpectedRpcCall "getHeadBlock"+  , hGetCounter = \_ _ -> throwM $ UnexpectedRpcCall "getCounter"+  , hGetBlockHeader = \_ -> throwM $ UnexpectedRpcCall "getBlockHeader"+  , hGetBlockConstants = \_ -> throwM $ UnexpectedRpcCall "getBlockConstants"+  , hGetBlockOperations = \_ -> throwM $ UnexpectedRpcCall "getBlockOperations"+  , hGetProtocolParameters = \_ -> throwM $ UnexpectedRpcCall "getProtocolParameters"+  , hRunOperation = \_ _ -> throwM $ UnexpectedRpcCall "runOperation"+  , hPreApplyOperations = \_ _ -> throwM $ UnexpectedRpcCall "preApplyOperations"+  , hForgeOperation = \_ _ -> throwM $ UnexpectedRpcCall "forgeOperation"+  , hInjectOperation = \_ -> throwM $ UnexpectedRpcCall "injectOperation"+  , hGetContractScript = \_ _ -> throwM $ UnexpectedRpcCall "getContractScript"+  , hGetContractBigMap = \_ _ _ -> throwM $ UnexpectedRpcCall "getContractBigMap"+  , hGetBigMapValue = \_ _ _ -> throwM $ UnexpectedRpcCall "getBigMapValue"+  , hGetBigMapValues = \_ _ _ _ -> throwM $ UnexpectedRpcCall "getBigMapValues"+  , hGetBalance = \_ _ -> throwM $ UnexpectedRpcCall "getBalance"+  , hRunCode = \_ _ -> throwM $ UnexpectedRpcCall "runCode"+  , hGetChainId = throwM $ UnexpectedRpcCall "getChainId"+  , hGetManagerKey = \_ _ -> throwM $ UnexpectedRpcCall "getManagerKey"+  , hGetDelegateAtBlock = \_ _ -> throwM $ UnexpectedRpcCall "getDelegateAtBlock"++  , hSignBytes = \_ _ _ -> throwM $ UnexpectedClientCall "signBytes"+  , hGenKey = \_ -> throwM $ UnexpectedClientCall "genKey"+  , hGenFreshKey = \_ -> throwM $ UnexpectedRpcCall "genFreshKey"+  , hRevealKey = \_ _ -> throwM $ UnexpectedClientCall "revealKey"+  , hWaitForOperation = \_ -> throwM $ UnexpectedRpcCall "waitForOperation"+  , hRememberContract = \_ _ _ -> throwM $ UnexpectedClientCall "hRememberContract"+  , hImportKey = \_ _ _ -> throwM $ UnexpectedClientCall "importKey"+  , hResolveAddressMaybe = \_ -> throwM $ UnexpectedRpcCall "resolveAddressMaybe"+  , hGetAlias = \_ -> throwM $ UnexpectedRpcCall "getAlias"+  , hGetPublicKey = \_ -> throwM $ UnexpectedRpcCall "getPublicKey"+  , hGetTezosClientConfig = throwM $ UnexpectedClientCall "getTezosClientConfig"+  , hCalcTransferFee = \_ _ _ _ -> throwM $ UnexpectedClientCall "calcTransferFee"+  , hCalcOriginationFee = \_ -> throwM $ UnexpectedClientCall "calcOriginationFee"+  , hGetKeyPassword = \_ -> throwM $ UnexpectedClientCall "getKeyPassword"+  , hRegisterDelegate = \_ _ -> throwM $ UnexpectedClientCall "registerDelegate"++  , hLogAction = mempty+  }++-- | Type to represent contract state in the @MockState@.+-- This type can represent both implicit accounts and contracts.+data ContractState = ContractState+  { csCounter :: TezosInt64+  , csAlias :: Alias+  , csContractData :: ContractData+  }++data ContractData+  = ContractData OriginationScript (Maybe ContractStateBigMap)+  | ImplicitContractData (Maybe PublicKey)++-- | Type to represent big_map in @ContractState@.+data ContractStateBigMap = ContractStateBigMap+  { csbmKeyType :: Expression+  , csbmValueType :: Expression+  , csbmMap :: Map Text ByteString+  -- ^ Real tezos bigmap also has deserialized keys and values+  , csbmId :: Natural+  -- ^ The big_map's ID+  }++newtype TestHandlers m = TestHandlers {unTestHandlers :: Handlers (TestT m)}++-- | Type to represent chain state in mock tests.+data MockState = MockState+  { msContracts :: Map Address ContractState+  , msHeadBlock :: Text+  , msBlockConstants :: BlockConstants+  , msProtocolParameters :: ProtocolParameters+  }++defaultMockState :: MockState+defaultMockState = MockState+  { msContracts = mempty+  , msHeadBlock = "HEAD"+  , msBlockConstants = BlockConstants+    { bcProtocol = "PROTOCOL"+    , bcChainId = "CHAIN_ID"+    , bcHeader = BlockHeaderNoHash+      { bhnhTimestamp = posixSecondsToUTCTime 0+      , bhnhLevel = 0+      , bhnhPredecessor = BlockHash "PREV_HASH"+      }+    , bcHash = BlockHash "HASH"+    }+  , msProtocolParameters = ProtocolParameters 257 1040000 60000 15+                                              (TezosMutez $ unsafeMkMutez 250)+  }++type TestT m = StateT MockState (ReaderT (TestHandlers m) (CatchT m))++type TestM = TestT Identity++runMockTestT+  :: forall a m. Monad m =>+     Handlers (TestT m) -> MockState -> TestT m a -> m (Either SomeException a)+runMockTestT handlers mockState action =+  runCatchT $ runReaderT (evalStateT action mockState) (TestHandlers handlers)++runMockTest+  :: forall a. Handlers TestM -> MockState -> TestM a -> Either SomeException a+runMockTest =+  runIdentity ... runMockTestT++getHandler :: Monad m => (Handlers (TestT m) -> fn) -> TestT m fn+getHandler fn = fn . unTestHandlers <$> ask++liftToMockTest :: Monad m => m a -> TestT m a+liftToMockTest = lift . lift . lift++-- | Various mock test errors.+data TestError+  = AlreadyRevealed Address+  | UnexpectedRpcCall Text+  | UnexpectedClientCall Text+  | UnknownContract AddressOrAlias+  | UnexpectedImplicitContract Address+  | ContractDoesntHaveBigMap Address+  | CantRevealContract Address+  | InvalidChainId+  | InvalidProtocol+  | CounterMismatch+  deriving stock Show++instance Exception TestError++instance HasLog (TestHandlers m) Message (TestT m) where+  getLogAction = hLogAction . unTestHandlers+  setLogAction action (TestHandlers handlers) =+    TestHandlers $ handlers { hLogAction = action }++instance Monad m => HasTezosClient (TestT m) where+  signBytes alias mbPassword op = do+    h <- getHandler hSignBytes+    h alias mbPassword op+  genKey alias = do+    h <- getHandler hGenKey+    h alias+  genFreshKey alias = do+    h <- getHandler hGenFreshKey+    h alias+  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+  importKey replaceExisting alias key = do+    h <- getHandler hImportKey+    h replaceExisting alias key+  resolveAddressMaybe addr = do+    h <- getHandler hResolveAddressMaybe+    h addr+  getAlias originator = do+    h <- getHandler hGetAlias+    h originator+  getPublicKey alias = do+    h <- getHandler hGetPublicKey+    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 origData+  getKeyPassword addr = do+    h <- getHandler hGetKeyPassword+    h addr+  registerDelegate kh pw = do+    h <- getHandler hRegisterDelegate+    h kh pw++instance Monad m => HasTezosRpc (TestT m) where+  getBlockHash block = do+    h <- getHandler hGetBlockHash+    h block+  getCounterAtBlock block addr = do+    h <- getHandler hGetCounter+    h block addr+  getBlockHeader block = do+    h <- getHandler hGetBlockHeader+    h block+  getBlockConstants block = do+    h <- getHandler hGetBlockConstants+    h block+  getBlockOperations block = do+    h <- getHandler hGetBlockOperations+    h block+  getProtocolParametersAtBlock block = do+    h <- getHandler hGetProtocolParameters+    h block+  runOperationAtBlock block op = do+    h <- getHandler hRunOperation+    h block op+  preApplyOperationsAtBlock block ops = do+    h <- getHandler hPreApplyOperations+    h block ops+  forgeOperationAtBlock block op = do+    h <- getHandler hForgeOperation+    h block op+  injectOperation op = do+    h <- getHandler hInjectOperation+    h op+  getContractScriptAtBlock block addr = do+    h <- getHandler hGetContractScript+    h block addr+  getContractStorageAtBlock blockId addr = do+    h <- getHandler hGetContractScript+    osStorage <$> h blockId addr+  getContractBigMapAtBlock block addr getBigMap = do+    h <- getHandler hGetContractBigMap+    h block addr getBigMap+  getBigMapValueAtBlock blockId bigMapId scriptExpr = do+    h <- getHandler hGetBigMapValue+    h blockId bigMapId scriptExpr+  getBigMapValuesAtBlock blockId bigMapId mbOffset mbLength = do+    h <- getHandler hGetBigMapValues+    h blockId bigMapId mbOffset mbLength+  getBalanceAtBlock block addr = do+    h <- getHandler hGetBalance+    h block addr+  runCodeAtBlock block r = do+    h <- getHandler hRunCode+    h block r+  getChainId = join (getHandler hGetChainId)+  getManagerKeyAtBlock block addr = do+    h <- getHandler hGetManagerKey+    h block addr+  getDelegateAtBlock block addr = do+    h <- getHandler hGetDelegateAtBlock+    h block addr++makeLensesFor [("msContracts", "msContractsL")] ''MockState
+ test/Tree.hs view
@@ -0,0 +1,5 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-}