diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,22 @@ +Unreleased +========== + + +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. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/app/REPL.hs b/app/REPL.hs --- a/app/REPL.hs +++ b/app/REPL.hs @@ -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 () diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -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 diff --git a/src/Michelson/Interpret.hs b/src/Michelson/Interpret.hs --- a/src/Michelson/Interpret.hs +++ b/src/Michelson/Interpret.hs @@ -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 -> "" 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 diff --git a/src/Michelson/Interpret/Pack.hs b/src/Michelson/Interpret/Pack.hs --- a/src/Michelson/Interpret/Pack.hs +++ b/src/Michelson/Interpret/Pack.hs @@ -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 -> diff --git a/src/Michelson/Interpret/Unpack.hs b/src/Michelson/Interpret/Unpack.hs --- a/src/Michelson/Interpret/Unpack.hs +++ b/src/Michelson/Interpret/Unpack.hs @@ -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 diff --git a/src/Michelson/Runtime.hs b/src/Michelson/Runtime.hs --- a/src/Michelson/Runtime.hs +++ b/src/Michelson/Runtime.hs @@ -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 diff --git a/src/Michelson/Runtime/GState.hs b/src/Michelson/Runtime/GState.hs --- a/src/Michelson/Runtime/GState.hs +++ b/src/Michelson/Runtime/GState.hs @@ -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 = diff --git a/src/Michelson/Runtime/TxData.hs b/src/Michelson/Runtime/TxData.hs --- a/src/Michelson/Runtime/TxData.hs +++ b/src/Michelson/Runtime/TxData.hs @@ -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 diff --git a/src/Michelson/TypeCheck.hs b/src/Michelson/TypeCheck.hs --- a/src/Michelson/TypeCheck.hs +++ b/src/Michelson/TypeCheck.hs @@ -4,6 +4,7 @@ module Michelson.TypeCheck ( typeCheckContract + , typeCheckContractAndStorage , typeCheckStorage , typeCheckParameter , typeVerifyStorage diff --git a/src/Michelson/TypeCheck/Instr.hs b/src/Michelson/TypeCheck/Instr.hs --- a/src/Michelson/TypeCheck/Instr.hs +++ b/src/Michelson/TypeCheck/Instr.hs @@ -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 diff --git a/src/Michelson/TypeCheck/Types.hs b/src/Michelson/TypeCheck/Types.hs --- a/src/Michelson/TypeCheck/Types.hs +++ b/src/Michelson/TypeCheck/Types.hs @@ -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) diff --git a/src/Michelson/Typed/Arith.hs b/src/Michelson/Typed/Arith.hs --- a/src/Michelson/Typed/Arith.hs +++ b/src/Michelson/Typed/Arith.hs @@ -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 diff --git a/src/Michelson/Typed/Haskell/Instr/Sum.hs b/src/Michelson/Typed/Haskell/Instr/Sum.hs --- a/src/Michelson/Typed/Haskell/Instr/Sum.hs +++ b/src/Michelson/Typed/Haskell/Instr/Sum.hs @@ -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. diff --git a/src/Michelson/Typed/Origination.hs b/src/Michelson/Typed/Origination.hs new file mode 100644 --- /dev/null +++ b/src/Michelson/Typed/Origination.hs @@ -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 diff --git a/src/Michelson/Untyped/Instr.hs b/src/Michelson/Untyped/Instr.hs --- a/src/Michelson/Untyped/Instr.hs +++ b/src/Michelson/Untyped/Instr.hs @@ -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 diff --git a/src/Morley/CLI.hs b/src/Morley/CLI.hs --- a/src/Morley/CLI.hs +++ b/src/Morley/CLI.hs @@ -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 :: diff --git a/src/Tezos/Address.hs b/src/Tezos/Address.hs --- a/src/Tezos/Address.hs +++ b/src/Tezos/Address.hs @@ -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'. -- diff --git a/src/Tezos/Crypto.hs b/src/Tezos/Crypto.hs --- a/src/Tezos/Crypto.hs +++ b/src/Tezos/Crypto.hs @@ -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 diff --git a/src/Util/IO.hs b/src/Util/IO.hs deleted file mode 100644 --- a/src/Util/IO.hs +++ /dev/null @@ -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) diff --git a/src/Util/IO/GHC.hs b/src/Util/IO/GHC.hs deleted file mode 100644 --- a/src/Util/IO/GHC.hs +++ /dev/null @@ -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 --- - --- | 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