morley 1.6.0 → 1.7.0

raw patch · 22 files changed

+380/−331 lines, 22 filesdep +with-utf8PVP ok

version bump matches the API change (PVP)

Dependencies added: with-utf8

API changes (from Hackage documentation)

Files

• CHANGES.md +20/−1
• app/Main.hs +14/−15
• app/REPL.hs +9/−9
• morley.cabal +5/−4
• src/Michelson/Interpret.hs +22/−50
• src/Michelson/Interpret/Pack.hs +4/−1
• src/Michelson/Interpret/Unpack.hs +3/−2
• src/Michelson/Runtime.hs +136/−96
• src/Michelson/Runtime/GState.hs +9/−22
• src/Michelson/Runtime/TxData.hs +0/−8
• src/Michelson/TypeCheck.hs +1/−0
• src/Michelson/TypeCheck/Instr.hs +9/−0
• src/Michelson/TypeCheck/Types.hs +13/−1
• src/Michelson/Typed/Arith.hs +1/−1
• src/Michelson/Typed/Haskell/Instr/Sum.hs +18/−0
• src/Michelson/Typed/Origination.hs +61/−0
• src/Michelson/Untyped/Instr.hs +1/−51
• src/Morley/CLI.hs +6/−0
• src/Tezos/Address.hs +42/−7
• src/Tezos/Crypto.hs +6/−1
• src/Util/IO.hs +0/−37
• src/Util/IO/GHC.hs +0/−25

@@ -1,3 +1,22 @@+Unreleased+==========+<!-- Append new entries here -->++1.7.0+=====+* [!565](https://gitlab.com/morley-framework/morley/-/merge_requests/565)+  Remove useless error entities from `Michelson.Interpret`.+* [!563](https://gitlab.com/morley-framework/morley/-/merge_requests/563)+  Fix handling of Natural numbers.+* [!554](https://gitlab.com/morley-framework/morley/-/merge_requests/554)+  Fix 'SELF' instruction packing.+* [!548](https://gitlab.com/morley-framework/morley/-/merge_requests/548)+  + The interpreter now takes a typed contract and storage value for origination operations.+  + Use binary serialization to compute operation hashes and addresses.+  + Add `typeCheckContractAndStorage` to `Michelson.TypeCheck`+  + Remove `withGlobalOperation` from `Michelson.Runtime`+  + Remove `EEIllTypedContract` and `EEIllTypedStorage` constructors from `ExecutorError'`+ 1.6.0 ===== * [!323](https://gitlab.com/morley-framework/morley/-/merge_requests/323)@@ -5,7 +24,7 @@ * [!537](https://gitlab.com/morley-framework/morley/-/merge_requests/537)   Permit `SELF %default` instruction. * [!522](https://gitlab.com/morley-framework/morley/-/merge_requests/522)-  + allow calling the interpreter with a typed transfer parameter and+  Allow calling the interpreter with a typed transfer parameter and   avoid unnecessary typechecking. * [!495](https://gitlab.com/morley-framework/morley/-/merge_requests/495)   Add source location to typed `Instr` AST.

@@ -6,8 +6,10 @@   ( main   ) where +import qualified Data.Text.Lazy.IO.Utf8 as Utf8 (writeFile) import Data.Version (showVersion) import Fmt (pretty)+import Main.Utf8 (withUtf8) import Named (arg, argF, (!)) import Options.Applicative   (command, execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long,@@ -15,7 +17,6 @@ import qualified Options.Applicative as Opt import Options.Applicative.Help.Pretty (Doc, linebreak) import Paths_morley (version)-import System.IO (utf8) import Text.Pretty.Simple (pPrint)  import Michelson.Analyzer (analyze)@@ -36,7 +37,6 @@ import Tezos.Crypto import Util.CLI (outputOption) import Util.Exception (displayUncaughtException)-import Util.IO (hSetTranslit, withEncoding, writeFileUtf8) import Util.Named  ----------------------------------------------------------------------------@@ -257,9 +257,7 @@ ----------------------------------------------------------------------------  main :: IO ()-main = displayUncaughtException $ withEncoding stdin utf8 $ do-  hSetTranslit stdout-  hSetTranslit stderr+main = displayUncaughtException $ withUtf8 $ do   cmdLnArgs <- execParser programInfo   run cmdLnArgs   where@@ -285,13 +283,13 @@             (argF #output -> mOutputFile)             (arg #singleLine -> forceSingleLine) -> do         contract <- prepareContract mInputFile-        let write = maybe putStrLn writeFileUtf8 mOutputFile+        let write = maybe putStrLn Utf8.writeFile mOutputFile         write $ printUntypedContract forceSingleLine contract       Optimize OptimizeOptions{..} -> do         untypedContract <- prepareContract optoContractFile         checkedContract <- either throwM pure $ typeCheckContract untypedContract         let optimizedContract = mapSomeContract optimize checkedContract-        let write = maybe putStrLn writeFileUtf8 optoOutput+        let write = maybe putStrLn Utf8.writeFile optoOutput         write $ printSomeContract optoSingleLine optimizedContract       Analyze AnalyzeOptions{..} -> do         untypedContract <- prepareContract aoContractFile@@ -308,14 +306,15 @@           ! #dryRun (not roWrite)       Originate OriginateOptions {..} -> do         michelsonContract <- prepareContract ooContractFile-        let origination = U.OriginationOperation-              { U.ooOriginator = ooOriginator-              , U.ooDelegate = ooDelegate-              , U.ooStorage = ooStorageValue-              , U.ooBalance = ooBalance-              , U.ooContract = michelsonContract-              }-        addr <- originateContract ooDBPath origination ! #verbose ooVerbose+        addr <-+          originateContract+            ooDBPath+            ooOriginator+            ooDelegate+            ooBalance+            ooStorageValue+            michelsonContract+            ! #verbose ooVerbose         putTextLn $ "Originated contract " <> pretty addr       Transfer TransferOptions {..} -> do         transfer toNow toMaxSteps toDBPath toDestination toTxData

@@ -16,6 +16,8 @@   ( runRepl   ) where +import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as BSL import Data.List (stripPrefix) import Data.Text (strip) import Data.Typeable (cast)@@ -23,23 +25,20 @@ import Fmt (pretty) import System.Console.Haskeline import Text.Megaparsec (parse)-import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Lazy as BSL  import Michelson.Interpret (ContractEnv(..), interpretInstr)-import qualified Michelson.Untyped as U-import qualified Michelson.Typed as T import Michelson.Macro (ParsedOp, expandList)-import Michelson.Parser (errorBundlePretty, parseExpandValue, ops, type_)+import Michelson.Parser (errorBundlePretty, ops, parseExpandValue, type_) import Michelson.Parser.Types (noLetEnv) import Michelson.Printer (printDoc, printTypedValue) import Michelson.Printer.Util (doesntNeedParens) import Michelson.Runtime.GState (genesisAddress)-import Michelson.TypeCheck.Types (HST(..), NotWellTyped(..))-import Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter) import Michelson.TypeCheck (SomeInstr(..), SomeInstrOut(..), getWTP, runTypeCheckIsolated)+import Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)+import Michelson.TypeCheck.Types (HST(..), NotWellTyped(..))+import qualified Michelson.Typed as T+import qualified Michelson.Untyped as U import Tezos.Core (Timestamp(..), dummyChainId, unsafeMkMutez)-import Util.IO  data SomeStack = forall t. Typeable t => SomeStack   { stValues :: (Rec T.Value t)@@ -116,6 +115,7 @@   , ceAmount = unsafeMkMutez 100   , ceChainId = dummyChainId   , ceOperationHash = Nothing+  , ceGlobalCounter = 0   }  printHelp :: ReplM ()@@ -170,7 +170,7 @@ dumpStackToFile fname =  lift get >>= \case   SomeStack stk hst -> case dumpStack stk hst of-    Right stkd -> liftIO $ Prelude.catch (writeFileUtf8 fname $ Aeson.encode stkd) handler+    Right stkd -> liftIO $ Prelude.catch (BSL.writeFile fname $ Aeson.encode stkd) handler     Left err -> printErr err   where     handler :: IOException -> IO ()

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: e9b0b7602aa9e3fa21558643cd50b0071708c46a024ce35930b662fbec21b73e+-- hash: eb134e14a2fe104820cbd6241dea8a67f3cd12bdc52681163d54531e450bf30c  name:           morley-version:        1.6.0+version:        1.7.0 synopsis:       Developer tools for the Michelson Language description:    A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective. category:       Language@@ -85,6 +85,7 @@       Michelson.Typed.Haskell.ValidateDescription       Michelson.Typed.Haskell.Value       Michelson.Typed.Instr+      Michelson.Typed.Origination       Michelson.Typed.Polymorphic       Michelson.Typed.Scope       Michelson.Typed.Sing@@ -125,8 +126,6 @@       Util.Fcf       Util.Generic       Util.Instances-      Util.IO-      Util.IO.GHC       Util.Label       Util.Lens       Util.Markdown@@ -192,6 +191,7 @@     , unordered-containers     , vector     , vinyl+    , with-utf8     , wl-pprint-text   mixins:       base hiding (Prelude)@@ -222,6 +222,7 @@     , pretty-simple     , text     , vinyl+    , with-utf8   mixins:       base hiding (Prelude)   default-language: Haskell2010

@@ -19,7 +19,6 @@    , mkInitStack   , fromFinalStack-  , interpretUntyped   , InterpretError (..)   , InterpretResult (..)   , EvalM@@ -40,19 +39,18 @@ import Data.Default (Default(..)) import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Singletons (Sing, demote)+import Data.Singletons (Sing) import Data.Vinyl (Rec(..), (<+>)) import Fmt (Buildable(build), Builder, genericF)  import Michelson.Interpret.Pack (packValue') import Michelson.Interpret.Unpack (UnpackError, unpackValue')-import Michelson.TypeCheck-  (SomeContract(..), SomeParamType(..), TCError, TcOriginatedContracts, TypeCheckMode(..),-  matchTypes, runTypeCheck, typeCheckContract, typeCheckValue)+import Michelson.TypeCheck (SomeParamType(..), TcOriginatedContracts, matchTypes) import Michelson.Typed import qualified Michelson.Typed as T+import Michelson.Typed.Origination (OriginationOperation(..), mkOriginationOperationHash) import qualified Michelson.Untyped as U-import Tezos.Address (Address(..), OriginationIndex(..), mkContractAddress)+import Tezos.Address (Address(..), GlobalCounter(..), OriginationIndex(..), mkContractAddress) import Tezos.Core (ChainId, Mutez, Timestamp) import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, sha256, sha512) import Util.Peano (LongerThan, Peano, SingNat(SS, SZ))@@ -84,6 +82,9 @@   , ceOperationHash :: Maybe U.OperationHash   -- ^ Hash of the currently executed operation, required for   -- correct contract address computation in 'CREATE_CONTRACT' instruction.+  , ceGlobalCounter :: GlobalCounter+  -- ^ A global counter that is used to ensure newly created+  -- contracts have unique addresses.   }  -- | Represents `[FAILED]` state of a Michelson program. Contains@@ -131,11 +132,7 @@           OpPresent -> "<value with operations>"           OpAbsent -> build (untypeValue v) -data InterpretError-  = RuntimeFailure (MichelsonFailed, MorleyLogs)-  | IllTypedContract TCError-  | IllTypedParam TCError-  | IllTypedStorage TCError+newtype InterpretError = InterpretError (MichelsonFailed, MorleyLogs)   deriving stock (Generic)  deriving stock instance Show InterpretError@@ -177,33 +174,6 @@ noMorleyLogs :: MorleyLogs noMorleyLogs = MorleyLogs [] --- | Interpret a contract without performing any side effects.--- This function uses untyped representation of contract, parameter and storage.--- Mostly used for testing.-interpretUntyped-  :: U.Contract-  -> U.Value-  -> U.Value-  -> ContractEnv-  -> Either InterpretError InterpretResult-interpretUntyped uContract@U.Contract{..} paramU initStU env = do-  SomeContract (Contract (instr :: ContractCode cp st) _ _ _)-      <- first IllTypedContract $ typeCheckContract uContract-  -- Do creates dummy scope to somehow overcome this:-  -- GHC internal error: ‘st’ is not in scope during type checking, but it passed the renamer.-  do-    let-      runTC :: forall t. SingI t => U.Value -> Either TCError (Value t)-      runTC val =-        runTypeCheck (TypeCheckValue (val, demote @t)) .-        usingReaderT def .-        typeCheckValue @t $ val--    paramV <- first IllTypedParam $ runTC @cp paramU-    initStV <- first IllTypedStorage $ runTC @st initStU-    handleContractReturn $-      interpret instr epcCallRootUnsafe paramV initStV env- type ContractReturn st =   (Either MichelsonFailed ([Operation], T.Value st), InterpreterState) @@ -211,7 +181,7 @@   :: (StorageScope st)   => ContractReturn st -> Either InterpretError InterpretResult handleContractReturn (ei, s) =-  bimap (RuntimeFailure . (, isMorleyLogs s)) (constructIR . (, s)) ei+  bimap (InterpretError . (, isMorleyLogs s)) (constructIR . (, s)) ei  interpret'   :: forall cp st arg.@@ -527,21 +497,23 @@   (VOption mbKeyHash :& VMutez m :& g :& r) = do   originator <- ceSelf <$> ask -  originationNonce <- isOriginationNonce <$> get+  originationNonce <- gets isOriginationNonce+  globalCounter <- asks ceGlobalCounter   opHash <- ceOperationHash <$> ask   modify $ \iState ->     iState { isOriginationNonce = OriginationIndex $ (unOriginationIndex $ isOriginationNonce iState) + 1 }   let ops = cCode contract   let resAddr =         case opHash of-          Just hash -> mkContractAddress hash originationNonce+          Just hash -> mkContractAddress hash originationNonce globalCounter           Nothing ->             mkContractAddress-              (U.mkOriginationOperationHash (createOrigOp originator mbKeyHash m ops g) (U.GlobalCounter 0))+              (mkOriginationOperationHash (createOrigOp originator mbKeyHash m contract g))               -- If opHash is Nothing it means that interpreter is running in some kind of test               -- context, therefore we generate dummy contract address with its own origination-              -- operation and counter set to 0.+              -- operation.               originationNonce+              globalCounter   let resEpAddr = EpAddress resAddr DefEpName   let resOp = CreateContract originator (unwrapMbKeyHash mbKeyHash) m g ops   pure $ VOp (OpCreateContract resOp)@@ -599,20 +571,20 @@   unpackValue' bs  createOrigOp-  :: (SingI param, StorageScope store)+  :: (ParameterScope param, StorageScope store)   => Address   -> Maybe (T.Value 'T.TKeyHash)   -> Mutez-  -> ContractCode param store+  -> Contract param store   -> Value' Instr store-  -> U.OriginationOperation-createOrigOp originator mbDelegate bal contract g =-  U.OriginationOperation+  -> OriginationOperation+createOrigOp originator mbDelegate bal contract storage =+  OriginationOperation     { ooOriginator = originator     , ooDelegate = unwrapMbKeyHash mbDelegate     , ooBalance = bal-    , ooStorage = untypeValue g-    , ooContract = convertContractCode contract+    , ooStorage = storage+    , ooContract = contract     }  unwrapMbKeyHash :: Maybe (T.Value 'T.TKeyHash) -> Maybe KeyHash

@@ -13,9 +13,12 @@   , packValuePrefix     -- * Serializers used in morley-client   , encodeValue'+  , encodeValue   , packNotedT'     -- * Internals   , encodeIntPayload+  , encodeKeyHashRaw+  , encodeEpAddress   ) where  import Prelude hiding (EQ, GT, LT)@@ -351,7 +354,7 @@   SELF sepc ->     case sepcName sepc of       DefEpName ->  "\x03\x49"-      epName -> "\x04\x49" <> encodeEpName epName+      epName -> encodeWithAnns [] [epNameToRefAnn epName] [] "\x03\x49"   CONTRACT ns ep | _ :: Proxy ('TOption ('TContract t) ': s) <- Proxy @out ->     encodeWithAnns [] [epNameToRefAnn ep] [] $ "\x05\x55" <> encodeNotedT' @t ns   TRANSFER_TOKENS ->

@@ -348,8 +348,9 @@       Map.fromDistinctAscList <$> ensureDistinctAsc fst es  -- | Read a numeric value.-decodeInt :: Num i => Get i-decodeInt = fromIntegral @Integer <$> loop 0 0 ? "Number"+decodeInt :: (Integral i, Bits.Bits i) => Get i+decodeInt = (Bits.toIntegralSized @Integer <$> loop 0 0 ? "Number")+            >>= maybe (fail "Value doesn't satisfy type ranges") pure   where     loop !offset !acc = do       byte <- Get.getWord8

@@ -31,8 +31,8 @@   , ExecutorM   , runExecutorM   , runExecutorMWithDB-  , withGlobalOperation   , executeGlobalOperations+  , executeGlobalOrigination   , executeOrigination   , executeTransfer @@ -45,13 +45,13 @@   , elUpdates   ) where -import Control.Lens (at, makeLenses, (+=), (.=), (<>=))+import Control.Lens (assign, at, makeLenses, (+=), (.=), (<>=)) import Control.Monad.Except (Except, liftEither, runExcept, throwError)-import qualified Data.Aeson as Aeson import Data.Binary.Put (putWord64be, runPut) import qualified Data.ByteString.Lazy as BSL import Data.Semigroup.Generic import Data.Text.IO (getContents)+import qualified Data.Text.IO.Utf8 as Utf8 (readFile) import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+)) import Named ((:!), (:?), arg, argDef, defaults, (!)) import Text.Megaparsec (parse)@@ -61,23 +61,25 @@ import Michelson.Interpret   (ContractEnv(..), InterpretError(..), InterpretResult(..), InterpreterState(..), MorleyLogs(..),   RemainingSteps(..), handleContractReturn, interpret)+import qualified Michelson.Interpret.Pack as Pack import Michelson.Macro (ParsedOp, expandContract) import qualified Michelson.Parser as P import Michelson.Runtime.GState import Michelson.Runtime.TxData-import Michelson.TypeCheck (TCError, typeVerifyParameter)+import Michelson.TypeCheck+  (SomeContractAndStorage(..), TCError, typeCheckContractAndStorage, typeVerifyParameter) import Michelson.Typed-  (CreateContract(..), EntrypointCallT, EpName, Operation'(..), SomeValue'(..), TransferTokens(..),-  convertContractCode, untypeValue)+  (CreateContract(..), EntrypointCallT, EpAddress(..), EpName, Operation'(..), ParameterScope,+  SomeValue'(..), TransferTokens(..), starNotes, starParamNotes, untypeValue) import qualified Michelson.Typed as T-import Michelson.Untyped-  (Contract, GlobalCounter(..), OperationHash(..), OriginationOperation(..),-  mkOriginationOperationHash)+import Michelson.Typed.Origination (OriginationOperation(..), mkOriginationOperationHash)+import Michelson.Untyped (Contract, OperationHash(..)) import qualified Michelson.Untyped as U import Tezos.Address (Address(..), OriginationIndex(..), mkContractAddress)-import Tezos.Core (Mutez, Timestamp(..), getCurrentTime, toMutez, unsafeAddMutez, unsafeSubMutez)-import Tezos.Crypto (blake2b, parseKeyHash)-import Util.IO (readFileUtf8)+import Tezos.Core+  (Mutez, Timestamp(..), getCurrentTime, toMutez, unMutez, unsafeAddMutez, unsafeSubMutez)+import Tezos.Crypto (KeyHash, blake2b, parseKeyHash)+import Util.Named ((.!))  ---------------------------------------------------------------------------- -- Auxiliary types@@ -113,8 +115,7 @@   } deriving stock (Show)  data ExecutorEnv = ExecutorEnv-  { _eeOperationHash :: ~OperationHash-  , _eeNow :: Timestamp+  { _eeNow :: Timestamp   }   deriving stock (Show, Generic) @@ -124,6 +125,7 @@   , _esOriginationNonce :: Int32   , _esSourceAddress :: Maybe Address   , _esLog :: ExecutorLog+  , _esOperationHash :: ~OperationHash   }   deriving stock (Show, Generic) @@ -161,10 +163,6 @@   -- ^ Sending 0tz towards an address.   | EEFailedToApplyUpdates !GStateUpdateError   -- ^ Failed to apply updates to GState.-  | EEIllTypedContract !TCError-  -- ^ A contract is ill-typed.-  | EEIllTypedStorage !TCError-  -- ^ Contract storage is ill-typed.   | EEIllTypedParameter !TCError   -- ^ Contract parameter is ill-typed.   | EEUnexpectedParameterType T.T T.T@@ -191,8 +189,6 @@       EEZeroTransaction addr ->         "Transaction of 0ꜩ towards a key address " +| addr |+ " which has no code is prohibited"       EEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""-      EEIllTypedContract err -> "The contract is ill-typed: " +| err |+ ""-      EEIllTypedStorage err -> "The contract storage is ill-typed: " +| err |+ ""       EEIllTypedParameter err -> "The contract parameter is ill-typed: " +| err |+ ""       EEUnexpectedParameterType expectedT actualT ->         "The contract parameter is well-typed, but did not match the contract's entrypoint's type.\n" <>@@ -228,7 +224,7 @@   either throwM pure $ parseContract mFilename code   where     readCode :: Maybe FilePath -> IO Text-    readCode = maybe getContents readFileUtf8+    readCode = maybe getContents Utf8.readFile  -- | Read a contract using 'readAndParseContract', expand and -- flatten. The contract is not type checked.@@ -237,14 +233,30 @@  -- | Originate a contract. Returns the address of the originated -- contract.-originateContract ::-     FilePath -> OriginationOperation -> "verbose" :! Bool -> IO Address-originateContract dbPath origination verbose =+originateContract+  :: FilePath+  -> Address+  -> Maybe KeyHash+  -> Mutez+  -> U.Value+  -> U.Contract+  -> "verbose" :! Bool+  -> IO Address+originateContract dbPath originator delegate balance uStorage uContract verbose = do+  origination <- either throwM pure $+    mkOrigination <$> typeCheckContractAndStorage uContract uStorage   -- pass 100500 as maxSteps, because it doesn't matter for origination,   -- as well as 'now'   fmap snd $ runExecutorMWithDB Nothing dbPath 100500 verbose ! defaults $ do-    withGlobalOperation (OriginateOp origination)-      $ executeOrigination origination+    executeGlobalOrigination origination+  where+    mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation+      { ooOriginator = originator+      , ooDelegate = delegate+      , ooBalance = balance+      , ooStorage = storage+      , ooContract = contract+      }  -- | Run a contract. The contract is originated first (if it's not -- already) and then we pretend that we send a transaction to it.@@ -254,18 +266,19 @@   -> Mutez   -> FilePath   -> U.Value-  -> Contract+  -> U.Contract   -> TxData   -> "verbose" :! Bool   -> "dryRun" :! Bool   -> IO ()-runContract maybeNow maxSteps initBalance dbPath storageValue contract txData+runContract maybeNow maxSteps initBalance dbPath uStorage uContract txData   verbose (arg #dryRun -> dryRun) = do+  origination <- either throwM pure $+    mkOrigination <$> typeCheckContractAndStorage uContract uStorage   void $ runExecutorMWithDB maybeNow dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do     -- Here we are safe to bypass executeGlobalOperations for origination,     -- since origination can't generate more operations.-    addr <- withGlobalOperation (OriginateOp origination)-      $ executeOrigination origination+    addr <- executeGlobalOrigination origination     let transferOp = TransferOp addr txData     executeGlobalOperations [transferOp]   where@@ -277,11 +290,11 @@     delegate =       either (error . mappend "runContract can't parse delegate: " . pretty) id $       parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"-    origination = OriginationOperation+    mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation       { ooOriginator = genesisAddress       , ooDelegate = Just delegate       , ooBalance = initBalance-      , ooStorage = storageValue+      , ooStorage = storage       , ooContract = contract       } @@ -313,7 +326,7 @@ -- | Run some executor action, returning its result and final executor state in 'ExecutorRes'. -- -- The action has access to the hash of currently executed global operation, in order to construct--- addresses of originated contracts. It is expected that the action uses 'withGlobalOperation'+-- addresses of originated contracts. It is expected that the action uses @#isGlobalOp .! True@ -- to specify this hash. Otherwise it is initialized with 'error'. runExecutorM   :: Timestamp@@ -324,7 +337,7 @@ runExecutorM now remainingSteps gState action =   fmap preResToRes     $ runExcept-    $ runStateT (runReaderT action $ ExecutorEnv initialOpHash now)+    $ runStateT (runReaderT action $ ExecutorEnv now)       initialState   where     initialOpHash = error "Initial OperationHash touched"@@ -335,6 +348,7 @@       , _esOriginationNonce = 0       , _esSourceAddress = Nothing       , _esLog = mempty+      , _esOperationHash = initialOpHash       }      preResToRes :: (a, ExecutorState) -> (ExecutorRes, a)@@ -393,54 +407,45 @@         mapM_ putTextLn logs       putTextLn "" -- extra break line to separate logs from two sequence contracts --- | Run some executor action in a context of global operation.------ Use this function to execute one global operation, potentially with its internal--- suboperations.-withGlobalOperation-  :: ExecutorOp-  -> ExecutorM a-  -> ExecutorM a-withGlobalOperation op action = do-  counter <- use $ esGState . gsCounterL-  -- Reset nonce and source address before executing a global operation.-  esOriginationNonce .= 0-  esSourceAddress .= Nothing-  local (set eeOperationHash $ mkExecutorOpHash op $ GlobalCounter counter)-    $ action---- | Execute a list of global operation, discarding their results.------ Uses 'withGlobalOperation' internally.+-- | Execute a list of global operations, discarding their results. executeGlobalOperations   :: [ExecutorOp]   -> ExecutorM () executeGlobalOperations = mapM_ $ \op ->-  withGlobalOperation op $ executeMany [op]+  executeMany (#isGlobalOp .! True) [op]   where     -- | Execute a list of operations and additional operations they return, until there are none.-    executeMany :: [ExecutorOp] -> ExecutorM ()-    executeMany = \case+    executeMany :: "isGlobalOp" :! Bool -> [ExecutorOp] -> ExecutorM ()+    executeMany isGlobalOp = \case         [] -> pass         (op:opsTail) -> do           case op of-            OriginateOp origination -> void $ executeOrigination origination+            OriginateOp origination -> void $ executeOrigination isGlobalOp origination             TransferOp addr txData -> do-              moreOps <- executeTransfer addr txData-              -- TODO why does opsTail go before moreOps?-              executeMany $ opsTail <> moreOps+              moreOps <- executeTransfer isGlobalOp addr txData+              executeMany (#isGlobalOp .! False) $ opsTail <> moreOps +-- | Execute a global origination operation.+executeGlobalOrigination :: OriginationOperation -> ExecutorM Address+executeGlobalOrigination = executeOrigination ! #isGlobalOp True+ -- | Execute an origination operation. executeOrigination-  :: OriginationOperation+  :: "isGlobalOp" :! Bool+  -> OriginationOperation   -> ExecutorM Address-executeOrigination origination = do-  opHash <- view eeOperationHash+executeOrigination (arg #isGlobalOp -> isGlobalOp) origination = do+  when isGlobalOp $ do+    beginGlobalOperation+    assign esOperationHash $ mkOriginationOperationHash origination++  opHash <- use esOperationHash+   gs <- use esGState   originationNonce <- use esOriginationNonce--  contractState <- liftEither $ mkContractState EEIllTypedContract EEIllTypedStorage-    (ooBalance origination, ooContract origination, ooStorage origination)+  let contractState =+        case origination of+          OriginationOperation _ _ bal st contract -> ContractState bal contract st   let originatorAddress = ooOriginator origination   originatorBalance <- case gsAddresses gs ^. at originatorAddress of     Nothing -> throwError (EEUnknownManager originatorAddress)@@ -452,7 +457,7 @@         -- precondition in guard.         return $ oldBalance `unsafeSubMutez` ooBalance origination   let-    address = mkContractAddress opHash $ OriginationIndex originationNonce+    address = mkContractAddress opHash (OriginationIndex originationNonce) (gsCounter gs)     updates =       [ GSAddAddress address (ASContract contractState)       , GSSetBalance originatorAddress originatorBalance@@ -471,16 +476,19 @@  -- | Execute a transfer operation. executeTransfer-  :: Address+  :: "isGlobalOp" :! Bool+  -> Address   -> TxData   -> ExecutorM [ExecutorOp]-executeTransfer addr txData = do+executeTransfer (arg #isGlobalOp -> isGlobalOp) addr txData = do+    when isGlobalOp $+      beginGlobalOperation+     now <- view eeNow     gs <- use esGState     remainingSteps <- use esRemainingSteps     mSourceAddr <- use esSourceAddress -    opHash <- view eeOperationHash     let addresses = gsAddresses gs     let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr     let senderAddr = tdSenderAddress txData@@ -525,18 +533,6 @@           -- can't overflow if global state is correct (because we can't           -- create money out of nowhere)           newBalance = csBalance `unsafeAddMutez` tdAmount txData-          contractEnv = ContractEnv-            { ceNow = now-            , ceMaxSteps = remainingSteps-            , ceBalance = newBalance-            , ceContracts = existingContracts-            , ceSelf = addr-            , ceSource = sourceAddr-            , ceSender = senderAddr-            , ceAmount = tdAmount txData-            , ceChainId = gsChainId gs-            , ceOperationHash = Just opHash-            }           epName = tdEntrypoint txData          T.MkEntrypointCallRes _ (epc :: EntrypointCallT cp epArg)@@ -556,6 +552,36 @@               liftEither $ first EEIllTypedParameter $                 typeVerifyParameter @epArg existingContracts untypedVal +        -- I'm not entirely sure why we need to pattern match on `()` here,+        -- but, if we don't, we get a compiler error that I suspect is somehow related+        -- to the existential types we're matching on a few lines above.+        --+        -- • Couldn't match type ‘a0’+        --                  with ‘(InterpretResult, RemainingSteps, [Operation], [GStateUpdate])’+        --     ‘a0’ is untouchable inside the constraints: StorageScope st1+        () <- when isGlobalOp $+          esOperationHash .= mkTransferOperationHash+            addr+            typedParameter+            (tdEntrypoint txData)+            (tdAmount txData)++        opHash <- use esOperationHash+        let+          contractEnv = ContractEnv+            { ceNow = now+            , ceMaxSteps = remainingSteps+            , ceBalance = newBalance+            , ceContracts = existingContracts+            , ceSelf = addr+            , ceSource = sourceAddr+            , ceSender = senderAddr+            , ceAmount = tdAmount txData+            , ceChainId = gsChainId gs+            , ceOperationHash = Just opHash+            , ceGlobalCounter = gsCounter gs+            }+         iur@InterpretResult           { iurOps = sideEffects           , iurNewStorage = newValue@@ -596,19 +622,21 @@ -- Simple helpers ---------------------------------------------------------------------------- -mkExecutorOpHash :: ExecutorOp -> GlobalCounter -> OperationHash-mkExecutorOpHash (OriginateOp op) counter = mkOriginationOperationHash op counter-mkExecutorOpHash (TransferOp addr txData) counter = mkTransferOperationHash addr txData counter---- TODO [#235] replace JSON-based encoding of transfer operation hash with--- one more close to reference Tezos implementation.-mkTransferOperationHash :: Address -> TxData -> GlobalCounter -> OperationHash-mkTransferOperationHash addr txData (GlobalCounter counter) =-  OperationHash $ blake2b-  $ BSL.toStrict-  $ Aeson.encode addr <> Aeson.encode txData <> runPut (putWord64be counter)+mkTransferOperationHash :: ParameterScope t => Address -> T.Value t -> EpName -> Mutez -> OperationHash+mkTransferOperationHash to param epName amount =+  OperationHash $ blake2b packedOperation+  where+    -- In Tezos, transfer operations are encoded as 4-tuple of+    -- (amount, destination, entrypoint, value)+    --+    -- See https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L275-282+    packedOperation =+      BSL.toStrict $+        (runPut $ putWord64be $ unMutez amount)+        <> Pack.encodeEpAddress (EpAddress to epName)+        <> Pack.encodeValue param --- The argument is the address of the contract that generation this operation.+-- The argument is the address of the contract that generated this operation. convertOp :: Address -> T.Operation -> Maybe ExecutorOp convertOp interpretedAddr =   \case@@ -629,7 +657,19 @@             { ooOriginator = ccOriginator cc             , ooDelegate = ccDelegate cc             , ooBalance = ccBalance cc-            , ooStorage = untypeValue (ccStorageVal cc)-            , ooContract = convertContractCode (ccContractCode cc)+            , ooStorage = ccStorageVal cc+            , ooContract =+                T.Contract+                  { cCode = ccContractCode cc+                  , cParamNotes = starParamNotes+                  , cStoreNotes = starNotes+                  , cEntriesOrder = U.canonicalEntriesOrder+                  }             }        in Just (OriginateOp origination)++-- | Reset nonce and source address before executing a global operation.+beginGlobalOperation :: ExecutorM ()+beginGlobalOperation = do+  esOriginationNonce .= 0+  esSourceAddress .= Nothing

@@ -8,7 +8,6 @@   (     -- * Auxiliary types     ContractState (..)-  , mkContractState   , AddressState (..)   , asBalance @@ -57,13 +56,12 @@ import System.IO.Error (IOError, isDoesNotExistError)  import Michelson.TypeCheck-  (SomeContract(..), SomeParamType(..), TCError(..), TcOriginatedContracts, typeCheckContract,-  typeCheckStorage)-import Michelson.Typed (SomeValue'(..))+  (SomeContractAndStorage(..), SomeParamType(..), TcOriginatedContracts,+  typeCheckContractAndStorage) import qualified Michelson.Typed as T import Michelson.Typed.Scope-import Michelson.Untyped (Contract, Value, contractStorage)-import Tezos.Address (Address(..), ContractHash)+import Michelson.Untyped (Contract, Value)+import Tezos.Address (Address(..), ContractHash, GlobalCounter(..)) import Tezos.Core (ChainId, Mutez, divModMutezInt, dummyChainId) import Tezos.Crypto import Util.Aeson@@ -82,18 +80,6 @@  deriving stock instance Show ContractState -mkContractState-  :: (TCError -> err)-  -> (TCError -> err)-  -> (Mutez, Contract, Value)-  -> Either err ContractState-mkContractState liftContractErr liftStorageErr (balance, uContract, uStorage) = do-  SomeContract (contract@T.Contract{} :: T.Contract cp st) <- first liftContractErr $ typeCheckContract uContract-  SomeValue (storage :: T.Value st') <- first liftStorageErr $ typeCheckStorage (contractStorage uContract) uStorage-  case eqT @st @st' of-    Just Refl -> pure $ ContractState balance contract storage-    _ -> Left $ liftStorageErr (TCContractError "Storage type does not match the contract in runtime state" Nothing)- instance ToJSON ContractState where   toJSON ContractState{..} =     object@@ -111,8 +97,9 @@       (balance :: Mutez) <- o .: "balance"       (uStorage :: Value) <- o .: "storage"       (uContract :: Contract) <- o .: "contract"-      case mkContractState id id (balance, uContract, uStorage) of-        Right r -> return r+      case typeCheckContractAndStorage uContract uStorage of+        Right (SomeContractAndStorage contract storage) ->+          pure $ ContractState balance contract storage         Left err -> fail $ "Unable to parse `ContractState`: " <> (show err)  instance Buildable ContractState where@@ -152,7 +139,7 @@   -- ^ Identifier of chain.   , gsAddresses :: Map Address AddressState   -- ^ All known addresses and their state.-  , gsCounter :: Word64+  , gsCounter :: GlobalCounter   -- ^ Ever increasing operation counter.   } deriving stock (Show) @@ -215,7 +202,7 @@                     ?: error "Number of genesis addresses is 0"     , genesis <- toList genesisAddresses     ]-  , gsCounter = 0+  , gsCounter = GlobalCounter 0   }  data GStateParseError =

@@ -14,8 +14,6 @@        ) where  import Control.Lens (makeLensesWith)-import Data.Aeson (ToJSON(toJSON))-import Data.Aeson.TH (deriveToJSON)  import Michelson.Typed (ParameterScope) import qualified Michelson.Typed as T@@ -23,7 +21,6 @@ import qualified Michelson.Untyped as U import Tezos.Address (Address) import Tezos.Core (Mutez)-import Util.Aeson (morleyAesonOptions) import Util.Lens (postfixLFields)  -- | A parameter associated with a particular transaction.@@ -33,10 +30,6 @@  deriving stock instance Show TxParam -instance ToJSON TxParam where-  toJSON (TxTypedParam val) = toJSON $ T.untypeValue val-  toJSON (TxUntypedParam val) = toJSON val- -- | Data associated with a particular transaction. data TxData = TxData   { tdSenderAddress :: Address@@ -46,4 +39,3 @@   } deriving stock Show  makeLensesWith postfixLFields ''TxData-deriveToJSON morleyAesonOptions ''TxData

@@ -4,6 +4,7 @@  module Michelson.TypeCheck   ( typeCheckContract+  , typeCheckContractAndStorage   , typeCheckStorage   , typeCheckParameter   , typeVerifyStorage

@@ -30,6 +30,7 @@ -- (error is thrown otherwise). module Michelson.TypeCheck.Instr     ( typeCheckContract+    , typeCheckContractAndStorage     , typeCheckValue     , typeCheckList     , typeVerifyStorage@@ -60,6 +61,14 @@  import qualified Michelson.Untyped as U import Michelson.Untyped.Annotation (VarAnn)++-- | Type check a contract and verify that the given storage+-- is of the type expected by the contract.+typeCheckContractAndStorage :: U.Contract -> U.Value -> Either TCError SomeContractAndStorage+typeCheckContractAndStorage uContract uStorage = do+  SomeContract (contract@Contract{} :: Contract cp st) <- typeCheckContract uContract+  storage <- typeVerifyStorage @st uStorage+  Right $ SomeContractAndStorage contract storage  typeCheckContract   :: U.Contract

@@ -10,6 +10,7 @@     , SomeInstrOut (..)     , SomeInstr (..)     , SomeContract (..)+    , SomeContractAndStorage (..)     , BoundVars (..)     , TcExtFrames     , NotWellTyped (..)@@ -27,7 +28,7 @@ import Prelude hiding (EQ, GT, LT) import qualified Text.Show -import Michelson.Typed (Notes(..), T(..), SingT(..), notesT, starNotes)+import Michelson.Typed (ParameterScope, StorageScope, Notes(..), T(..), SingT(..), notesT, starNotes) import Michelson.Typed.Haskell.Value (WellTyped) import qualified Michelson.Typed as T import Michelson.Typed.Instr@@ -179,6 +180,17 @@ mapSomeContract f (SomeContract fc) = SomeContract $ mapContractCode f fc  deriving stock instance Show SomeContract++-- | Represents a typed contract & a storage value of the type expected by the contract.+data SomeContractAndStorage where+  SomeContractAndStorage+    :: forall cp st.+       (StorageScope st, ParameterScope cp)+       => Contract cp st+       -> T.Value st+       -> SomeContractAndStorage++deriving stock instance Show SomeContractAndStorage  -- | Set of variables defined in a let-block. data BoundVars = BoundVars (Map Var Type) (Maybe SomeHST)

@@ -265,7 +265,7 @@ instance ArithOp And 'TInt 'TNat where   type ArithRes And 'TInt 'TNat = 'TNat   convergeArith _ _ n2 = Right n2-  evalOp _ (VInt i) (VNat j) = Right $ VNat ((fromInteger i) .&. j)+  evalOp _ (VInt i) (VNat j) = Right $ VNat (fromInteger (i .&. toInteger j)) instance ArithOp And 'TNat 'TNat where   type ArithRes And 'TNat 'TNat = 'TNat   convergeArith _ n1 n2 = converge n1 n2

@@ -7,9 +7,11 @@ -- | Instructions working on sum types derived from Haskell ones. module Michelson.Typed.Haskell.Instr.Sum   ( InstrWrapC+  , InstrWrapOneC   , InstrCaseC   , InstrUnwrapC   , instrWrap+  , instrWrapOne   , hsWrap   , instrCase   , (//->)@@ -290,11 +292,27 @@   gInstrWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))                          @(LnrFieldType (GetNamed name dt)) +-- | Like 'instrWrap' but only works for contructors with a single field.+-- Results in a type error if a constructor with no field is used instead.+instrWrapOne+  :: forall dt name st.+     InstrWrapOneC dt name+  => Label name+  -> Instr (ToT (CtorOnlyField name dt) ': st) (ToT dt ': st)+instrWrapOne _ =+  gInstrWrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))+                         @(LnrFieldType (GetNamed name dt))+ type InstrWrapC dt name =   ( GenericIsoValue dt   , GInstrWrap (G.Rep dt)       (LnrBranch (GetNamed name dt))       (LnrFieldType (GetNamed name dt))+  )++type InstrWrapOneC dt name =+  ( InstrWrapC dt name+  , GetCtorField dt name ~ 'OneField (CtorOnlyField name dt)   )  -- | Wrap a haskell value into a constructor with the given name.

@@ -0,0 +1,61 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Michelson.Typed.Origination+  ( OriginationOperation(..)+  , mkOriginationOperationHash+  ) where++import Data.Binary.Put (putWord64be, runPut)+import qualified Data.ByteString.Lazy as BSL++import Michelson.Interpret.Pack (encodeKeyHashRaw, encodeValue', packCode')+import Michelson.Typed.Aliases (Value)+import Michelson.Typed.Instr (Contract(..), cCode)+import Michelson.Typed.Scope (ParameterScope, StorageScope)+import Tezos.Address (Address, OperationHash(..))+import Tezos.Core (Mutez(..))+import Tezos.Crypto (KeyHash, blake2b)++-- | Data necessary to originate a contract.+data OriginationOperation =+  forall cp st.+  (StorageScope st, ParameterScope cp) =>+  OriginationOperation+  { ooOriginator :: Address+  -- ^ Originator of the contract.+  , ooDelegate :: Maybe KeyHash+  -- ^ Optional delegate.+  , ooBalance :: Mutez+  -- ^ Initial balance of the contract.+  , ooStorage :: Value st+  -- ^ Initial storage value of the contract.+  , ooContract :: Contract cp st+  -- ^ The contract itself.+  }++deriving stock instance Show OriginationOperation++-- | Construct 'OperationHash' for an 'OriginationOperation'.+mkOriginationOperationHash :: OriginationOperation -> OperationHash+mkOriginationOperationHash OriginationOperation{..} =+  OperationHash $ blake2b packedOperation+  where+    -- In Tezos OriginationOperation is encoded as 4-tuple of+    -- (balance, optional delegate, code, storage)+    --+    -- See https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L314+    -- and https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/script_repr.ml#L68+    packedOperation =+      BSL.toStrict (runPut $ putWord64be $ unMutez ooBalance)+      <> packMaybe (BSL.toStrict . encodeKeyHashRaw) ooDelegate+      <> packCode' (cCode ooContract)+      <> encodeValue' ooStorage++    -- "optional" encoding in Tezos.+    --+    -- See https://gitlab.com/nomadic-labs/data-encoding/-/blob/2c2b795a37e7d76e3eaa861da9855f2098edc9b9/src/binary_writer.ml#L278-283+    packMaybe :: (a -> ByteString) -> Maybe a -> ByteString+    packMaybe _ Nothing = "\255"+    packMaybe f (Just a) = "\0" <> f a

@@ -12,17 +12,11 @@    -- * Contract's address   , OperationHash (..)-  , OriginationOperation (..)-  , GlobalCounter (..)-  , mkOriginationOperationHash   ) where  import Prelude hiding (EQ, GT, LT) -import qualified Data.Aeson as Aeson import Data.Aeson.TH (deriveJSON)-import Data.Binary.Put (putWord64be, runPut)-import qualified Data.ByteString.Lazy as BSL import Data.Data (Data(..)) import Fmt (Buildable(build), (+|), (|+)) import Generics.SYB (everywhere, mkT)@@ -39,9 +33,7 @@ import Michelson.Untyped.Ext (ExtInstrAbstract) import Michelson.Untyped.Type (Type) import Michelson.Untyped.Value (Value'(..))-import Tezos.Address (Address(..), OperationHash(..))-import Tezos.Core (Mutez)-import Tezos.Crypto (KeyHash, blake2b)+import Tezos.Address (OperationHash(..)) import Util.Aeson  -------------------------------------@@ -316,50 +308,8 @@     mi -> buildRenderDoc mi  ------------------------------------------------------------------------------- Operation hash computation--------------------------------------------------------------------------------- | Data necessary to originate a contract.-data OriginationOperation = OriginationOperation-  { ooOriginator :: Address-  -- ^ Originator of the contract.-  , ooDelegate :: Maybe KeyHash-  -- ^ Optional delegate.-  , ooBalance :: Mutez-  -- ^ Initial balance of the contract.-  , ooStorage :: Value' ExpandedOp-  -- ^ Initial storage value of the contract.-  , ooContract :: Contract' ExpandedOp-  -- ^ The contract itself.-  } deriving stock (Show, Eq, Generic)--newtype GlobalCounter = GlobalCounter { unGlobalCounter :: Word64 }-  deriving stock (Show, Eq, Generic)-  deriving anyclass (NFData)---- | Construct 'OperationHash' for an 'OriginationOperation'.------ In Tezos each operation has a special field called @counter@, see here:--- https://gitlab.com/tezos/tezos/-/blob/master/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L113-120------ This counter seems to be a part of global state of Tezos network. In fact, it may be observed--- in raw JSON representation of the operation in the network explorer.------ This counter is increased at each operation and thus ensures that origination of identical--- contracts with identical metadata will result in different addresses.------ Our counter is represented as 'Word64', while in Tezos it is unbounded. We believe that--- for our interpreter it should not matter.-mkOriginationOperationHash :: OriginationOperation -> GlobalCounter -> OperationHash-mkOriginationOperationHash op (GlobalCounter counter) =-  -- TODO [#235] This should use the same encoding as used in Tezos.-  -- Using JSON is easier for now, however.-  OperationHash $ blake2b $ BSL.toStrict $ Aeson.encode op <> runPut (putWord64be counter)------------------------------------------------------------------------------ -- JSON serialization ----------------------------------------------------------------------------  deriveJSON morleyAesonOptions ''ExpandedOp deriveJSON morleyAesonOptions ''InstrAbstract-deriveJSON morleyAesonOptions ''OriginationOperation

@@ -16,6 +16,7 @@   , dbPathOption   , txDataOption   , keyHashOption+  , secretKeyOption   , valueOption   , mutezOption   , addressOption@@ -127,6 +128,11 @@ keyHashOption ::   Maybe KeyHash -> "name" :! String -> "help" :! String -> Opt.Parser KeyHash keyHashOption = mkCLOptionParser++-- | Generic parser to read an option of 'SecretKey' type.+secretKeyOption ::+  Maybe SecretKey -> "name" :! String -> "help" :! String -> Opt.Parser SecretKey+secretKeyOption = mkCLOptionParser  -- | Generic parser to read an option of 'U.Value' type. valueOption ::

@@ -12,6 +12,7 @@    , OperationHash (..)   , OriginationIndex (..)+  , GlobalCounter(..)   , mkContractAddress   , mkContractHashHack @@ -33,7 +34,7 @@ import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encoding as Aeson import qualified Data.Aeson.Types as AesonTypes-import Data.Binary.Put (putInt32be, runPut)+import Data.Binary.Put (putInt32be, putWord64be, runPut) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Fmt (Buildable(build), hexF, pretty)@@ -82,39 +83,73 @@   deriving stock (Show, Eq, Ord, Generic)   deriving anyclass (NFData) +-- | Represents the network's global counter.+--+-- When a new contract is created (either via a "global" origination operation or+-- via a @CREATE_CONTRACT@ instruction), this counter is used to create a new address for it+-- (see 'mkContractAddress').+--+-- The counter is incremented after every operation, and thus ensures that these+-- addresses are unique (i.e. origination of identical contracts with identical metadata will+-- result in different addresses.)+--+-- In Tezos each operation has a special field called @counter@, see here:+-- https://gitlab.com/tezos/tezos/-/blob/397dd233a10cc6df0df959e2a624c7947997dd0c/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L113-120+--+-- This counter seems to be a part of global state of Tezos network. In fact, it may be observed+-- in raw JSON representation of the operation in the network explorer.+--+-- Our counter is represented as 'Word64', while in Tezos it is unbounded. We believe that+-- for our interpreter it should not matter.+newtype GlobalCounter = GlobalCounter { unGlobalCounter :: Word64 }+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)+  deriving newtype (ToJSON, FromJSON, Num)++-- | When a transfer operation triggers multiple @CREATE_CONTRACT@+-- instructions, using 'GlobalCounter' to compute those contracts' addresses+-- is not enough to ensure their uniqueness.+--+-- For that reason, we also keep track of an 'OriginationIndex' that starts out as 0+-- when a transfer is initiated, and is incremented every time a @CREATE_CONTRACT@+-- instruction is interpreted.+--+-- See 'mkContractAddress'. newtype OriginationIndex = OriginationIndex { unOriginationIndex :: Int32 }   deriving stock (Show, Eq, Ord, Generic)   deriving anyclass (NFData) --- | Compute address of a contract from its origination operation and origination index.+-- | Compute address of a contract from its origination operation, origination index and global counter. -- -- However, in real Tezos encoding of the operation is more than just 'OriginationOperation'. -- There an Operation has several more meta-fields plus a big sum-type of all possible operations. ----- See here: https://gitlab.com/tezos/tezos/-/blob/master/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L78+-- See here: https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L78 -- -- What is important is that one (big) Operation may lead to origination of multiple contracts. That -- is why contract address is constructed from hash of the operation that originated and of index -- of the contract's origination in the execution of that operation. -- -- In other words, contract hash is calculated as the blake2b160 (20-byte) hash of--- origination operation hash + int32 origination index.+-- origination operation hash + int32 origination index + word64 global counter. -- -- In Morley we do not yet support full encoding of Tezos Operations, therefore we choose -- to generate contract addresses in a simplified manner. ----- Namely, we encode 'OriginationOperation' as we can and concat it with the origination index.+-- Namely, we encode 'OriginationOperation' as we can and concat it with the origination index+-- and the global counter. -- Then we take 'blake2b160' hash of the resulting bytes and consider it to be the contract's -- address. mkContractAddress   :: OperationHash   -> OriginationIndex+  -> GlobalCounter   -> Address-mkContractAddress (OperationHash opHash) (OriginationIndex idx) =+mkContractAddress (OperationHash opHash) (OriginationIndex idx) (GlobalCounter counter) =   ContractAddress   $ ContractHash   $ blake2b160-  $ opHash <> BSL.toStrict (runPut $ putInt32be idx)+  $ opHash <> BSL.toStrict (runPut $ putInt32be idx >> putWord64be counter)  -- | Create a dummy 'ContractHash' value by hashing given 'ByteString'. --

@@ -137,6 +137,11 @@  instance NFData SecretKey +instance HasCLReader SecretKey where+  getReader = eitherReader (first pretty . parseSecretKey . toText)+  getMetavar = "SECRET_KEY"++ -- | Deterministicaly generate a secret key from seed. -- Type of the key depends on seed length. detSecretKey :: HasCallStack => ByteString -> SecretKey@@ -350,7 +355,7 @@     ])  formatSecretKey :: SecretKey -> Text-formatSecretKey = \case+formatSecretKey key = "unencrypted:" <> case key of   SecretKeyEd25519 sig -> Ed25519.formatSecretKey sig   SecretKeySecp256k1 sig -> Secp256k1.formatSecretKey sig   SecretKeyP256 sig -> P256.formatSecretKey sig

@@ -1,37 +0,0 @@--- SPDX-FileCopyrightText: 2020 Tocqueville Group------ SPDX-License-Identifier: LicenseRef-MIT-TQ--module Util.IO-  ( readFileUtf8-  , writeFileUtf8-  , appendFileUtf8-  , withEncoding-  , hSetTranslit-  ) where--import Data.Text.IO (hGetContents)-import System.IO (TextEncoding, hGetEncoding, hSetBinaryMode, hSetEncoding, utf8)--import Util.IO.GHC (hSetTranslit)---readFileUtf8 :: FilePath -> IO Text-readFileUtf8 name =-  openFile name ReadMode >>= \h -> hSetEncoding h utf8 >> hGetContents h--writeFileUtf8 :: Print text => FilePath -> text -> IO ()-writeFileUtf8 name txt =-  withFile name WriteMode $ \h -> hSetEncoding h utf8 >> hPutStr h txt--appendFileUtf8 :: Print text => FilePath -> text -> IO ()-appendFileUtf8 name txt =-  withFile name AppendMode $ \h -> hSetEncoding h utf8 >> hPutStr h txt--withEncoding :: Handle -> TextEncoding -> IO () -> IO ()-withEncoding handle encoding action = do-  mbInitialEncoding <- hGetEncoding handle-  bracket-    (hSetEncoding handle encoding)-    (\_ -> maybe (hSetBinaryMode handle True) (hSetEncoding handle) mbInitialEncoding)-    (\_ -> action)

@@ -1,25 +0,0 @@--- SPDX-FileCopyrightText: 2002 The University Court of the University of Glasgow------ SPDX-License-Identifier: LicenseRef-BSD-3-Clause-GHC--module Util.IO.GHC-  ( hSetTranslit-  ) where--import GHC.IO.Encoding (textEncodingName)-import System.IO (hGetEncoding, hSetEncoding, mkTextEncoding)----- This function was copied (with slight modifications) from--- <https://gitlab.haskell.org/ghc/ghc/blob/7105fb66a7bacf822f7f23028136f89ff5737d0e/libraries/ghc-boot/GHC/HandleEncoding.hs>---- | Change the character encoding of the given Handle to transliterate--- on unsupported characters instead of throwing an exception.-hSetTranslit :: Handle -> IO ()-hSetTranslit h = do-    menc <- hGetEncoding h-    case fmap textEncodingName menc of-        Just name | '/' `notElem` name -> do-            enc' <- mkTextEncoding $ name ++ "//TRANSLIT"-            hSetEncoding h enc'-        _ -> pass