diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 797dee1e42b2cdbd28d2d47f72cbc2ec31fd59eb..b4765a038a74cf4e7003027b16f929a40db7b11b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -183,26 +183,11 @@ integration:basic.sh: script: - dune build @src/bin_client/runtest_basic.sh -integration:contracts.sh: - <<: *integration_definition - script: - - dune build @src/bin_client/runtest_contracts.sh - -integration:contracts_opcode.sh: - <<: *integration_definition - script: - - dune build @src/bin_client/runtest_contracts_opcode.sh - integration:contracts_macros.sh: <<: *integration_definition script: - dune build @src/bin_client/runtest_contracts_macros.sh -integration:contracts_mini_scenarios.sh: - <<: *integration_definition - script: - - dune build @src/bin_client/runtest_contracts_mini_scenarios.sh - integration:multinode.sh: <<: *integration_definition script: @@ -287,6 +272,12 @@ integration:contract_baker: - pytest tests_python/tests/test_contract_baker.py stage: test +integration:contract_opcodes: + <<: *integration_definition + script: + - pytest tests_python/tests/test_contract_opcodes.py + stage: test + integration:cors: <<: *integration_definition script: diff --git a/docs/Makefile b/docs/Makefile index 5309877c71702873c8a264fe9743a430dc9b35f7..76cc6cf08c899386fccfb11e205dca1431cd7a08 100644 --- a/docs/Makefile +++ b/docs/Makefile @@ -30,11 +30,19 @@ $(DOCGENDIR)/p2p_doc.exe: api/p2p.rst: $(DOCGENDIR)/p2p_doc.exe api/p2p_usage.rst.inc @dune exec $(DOCGENDIR)/p2p_doc.exe < api/p2p_usage.rst.inc > api/p2p.rst +../_opam/bin/ott: + opam pin --yes add ott https://gitlab.com/nomadic-labs/ott.git#json + +.PHONY: whitedoc/michelson_reference.html +whitedoc/michelson_reference.html: ../_opam/bin/ott + @cd doc_gen/michelson_reference/ && make docs/michelson_reference.html + cp doc_gen/michelson_reference/docs/michelson_reference.html $@ + .PHONY: help Makefile # Catch-all target: route all unknown targets to Sphinx using the new # "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). -html: Makefile api/errors.rst api/rpc.rst api/p2p.rst +html: Makefile api/errors.rst api/rpc.rst api/p2p.rst whitedoc/michelson_reference.html @$(SPHINXBUILD) -b html "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) clean: diff --git a/docs/README.rst b/docs/README.rst index 8c1463d42285ae485891ffb9342ffefa2cdd9e0b..8575e1e527b46b58c5cf48cdf4f16d1da5901eab 100644 --- a/docs/README.rst +++ b/docs/README.rst @@ -62,3 +62,31 @@ per public library and generates an ``index.html`` file in each sub-directory. The documentation is not installed on the system by Tezos. It is meant to be read locally while developing and then published on the www when releasing packages. + +Michelson reference +------------------- + +A michelson reference is generated automatically from its +formalization in ott. The dependencies necessary to generate this +reference can be installed thus: + +.. code:: bash + + sudo apt install python3-jinja2 python3-docutils python3-pygments + +or, using pip: + +.. code:: bash + + pip3 install -r < requirements.txt + +The michelson reference also require a patched version of ott that is +available in `tezos/src/vendors/ott/`. To build it: + +.. code:: bash + + cd ../ + opam install vendors/ott + +TODO: I suppose this is not the correct way to wire up this +dependency. Advice welcome. diff --git a/docs/doc_gen/michelson_reference/.gitignore b/docs/doc_gen/michelson_reference/.gitignore new file mode 100644 index 0000000000000000000000000000000000000000..276cc98405c4f1f512ad401a3639f5db1e80532a --- /dev/null +++ b/docs/doc_gen/michelson_reference/.gitignore @@ -0,0 +1,4 @@ +/docs/index.html +/docs/michelson_reference.html +/michelson.json +/michelson_embed.tex diff --git a/docs/doc_gen/michelson_reference/Makefile b/docs/doc_gen/michelson_reference/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..763145fb6f06d96e5fa27e87ed6a23a59c1926f3 --- /dev/null +++ b/docs/doc_gen/michelson_reference/Makefile @@ -0,0 +1,40 @@ +python=python3 +tezos_client=tezos-client +ott=ott + +all: docs/index.html +# rule_images + +rule_images: michelson.ott + $(python) pp-latex-rules.py + cd rules; ./convert_all.sh + +%.json: %.ott ../../../_opam/bin/ott + $(ott) -i $< -o $@ + +michelson_embed.tex: michelson.ott + $(ott) -tex_wrap false -coq_expand_list_types false -i $< -o $@ + +michelson.tex: michelson.ott + $(ott) -coq_expand_list_types false -i $< -o $@ + +DOC_DEPS=generate.py michelson.json michelson-meta.yaml generate.py $(shell find templates -iname \*.html) + +docs/index.html: ${DOC_DEPS} $(shell find static -iname \*.js -or -iname \*.css) + mkdir -p docs/static/ + cp -rv static/* docs/static/ + $(python) generate.py > $@ + +docs/michelson_reference.html: ${DOC_DEPS} + $(python) generate.py --standalone > $@ + +examples_typecheck: + for i in `ls example-contracts/*.tz`; do tezos-client typecheck script $$i; done + +examples_verify: + $(python) examples-verify.py + +test_lexer: + ./test-lexer.sh + +test: examples_verify test_lexer diff --git a/docs/doc_gen/michelson_reference/README.org b/docs/doc_gen/michelson_reference/README.org new file mode 100644 index 0000000000000000000000000000000000000000..b33d7356a5a2e63353b8d0b33717f18f9573026a --- /dev/null +++ b/docs/doc_gen/michelson_reference/README.org @@ -0,0 +1,117 @@ +* Installation + +Install dependencies + +#+BEGIN_SRC bash +sudo apt install python3-jinja2 python3-docutils python3-pygments python3-jsonschema +#+END_SRC + +or, using pip: + +#+BEGIN_SRC bash +pip3 install -r < requirements.txt +#+END_SRC + +The reference also require a patched version of ott available in +=tezos/src/vendors/ott/=. To build it: + +#+BEGIN_SRC bash +cd ../ +opam install vendors/ott +#+END_SRC + +TODO: I suppose this is not the correct way to wire up this +dependency. Advice welcome. + +* Usage + +Generates a standalone michelson reference in =docs/index.html=: + +#+BEGIN_SRC bash +make docs/index.html +#+END_SRC + +Generates a version intended for integration in existing tezos +developer documentation (currently the same as the standalone +version): + +#+BEGIN_SRC bash +make docs/michelson_reference.html +#+END_SRC + + +* Format of =michelson-meta.yaml= + + +The format of =michelson-meta.yaml= is verified against the schema +described in =michelson-meta-schema.yaml=. All fields are required +unless marked (optional) + +#+BEGIN_VERBATIM +# A dictionary of categories +categories: + # format [category]: [category_description] + # e.g. + core: Set of core operations + +# A dictionary where each entry is the meta data for one michelson +# instruction. The key must be the constructor of that instruction as +# defined in michelson.ott. Typically, this is simply the name of the +# instruction. +instructions: + # instruction opcode: + ADD: + # the category of the instruction. a string that must be the key of one of the + # string: categories defined above, e.g. core / domain / etc. + category: core + # string: a short documentation, one phrase. can use rst markup. + documentation_short: Adds two numerical values. + # (optional), string: longer documentation, focus on intuitions. can use rst markup. + documentation: "Adds numerical values. This instruction is polymorphic and accepts..." + # (optional), string: if omitted, will be synthesized as described below. + stack_effect: 'int : int : [] — int : []' + # (optional) a list of examples, each of which is a dictionary with the following properties + examples: + - # (optional), string: name of the example + name: Sum of integers + # string: description of the example. can use rst markup. + description: Sums up the integers. + # string: path to the example, relative to src/bin_client/test/contracts/ + path: opcodes/add.tz + # by supplying an example input / initial_storage and + # final_storage, the coherency of the example can be verified by + # running ``make examples_verify``. i.e, if the example is run + # with ``initial_storage`` and ``input`` then the final storage + # is ``final_storage`` + # string: the example parameter + input: '(pair 2 2)' + # string: the example initial storage + initial_storage: 'None' + # string: the example final storage + final_storage: 'Some 4' + # (optional) boolean. if True, then the information about input/initial_storage/final_storage + is not visible in the generated doc. this is useful for examples whose input/output is not interesting. + hide_final_storage: False +#+END_VERBATIM + +* Stack effect + +The stack effect is an intuitive (non-formal) summary of the effect of +a primitive on the stack, giving the state of the stack before and +after executing the primitive. For instance, for `ADD` the stack +effect could be `nz1 : nz2 : S` -- `(nz1 + nz2) : S`. + +Currently, the stack effect of the operations is synthesized by +taking the conclusion of the first rule (in order of appearance) of +the semantics of the operation. For `ADD`, the rule is: + + ----- :: ADD + ADD / nz1 : nz2 : S => (nz1 + nz2) : S + +From which we extract the stack effect given above. + +For some instructions , this procedure generates unhelpful stack +effects (e.g. `Right d : S` -- `d : S` for `LOOP_LEFT`). For others, +it is hard to conceive of any helpful stack effect (e.g. `SEQ`). In +such cases, a stack effect can be given manually by filling out the +`stack_effect` field of the instruction in `michelson-meta.yaml`. diff --git a/docs/doc_gen/michelson_reference/deploy.sh b/docs/doc_gen/michelson_reference/deploy.sh new file mode 100755 index 0000000000000000000000000000000000000000..eed319f1ceb9ddf81732d728174e2662928f1ecb --- /dev/null +++ b/docs/doc_gen/michelson_reference/deploy.sh @@ -0,0 +1,3 @@ +#!/bin/bash + +rsync -azuv docs/* arvidj.eu:/var/www/arvidj.eu/michelson/ diff --git a/docs/doc_gen/michelson_reference/docs/images/rules/.gitignore b/docs/doc_gen/michelson_reference/docs/images/rules/.gitignore new file mode 100644 index 0000000000000000000000000000000000000000..e33609d251c814ccd3a30337c965a875645c2117 --- /dev/null +++ b/docs/doc_gen/michelson_reference/docs/images/rules/.gitignore @@ -0,0 +1 @@ +*.png diff --git a/docs/doc_gen/michelson_reference/docs/static/michelson.js b/docs/doc_gen/michelson_reference/docs/static/michelson.js new file mode 100644 index 0000000000000000000000000000000000000000..607bb4792cd5adba5cdcd65d5bb6ec2076e8b885 --- /dev/null +++ b/docs/doc_gen/michelson_reference/docs/static/michelson.js @@ -0,0 +1,61 @@ +function addTypemap(pre, typemap) { + var cl = pre.clone(); + + $(pre).find('span').each(function () { + var tgt = $(this); + var code = pre.text(); + var idx = $(this).parent('pre').children().index(tgt); + + // find point corresponding to the beginning of this primitive + var ch = $(cl.children().get(idx)) + var origText = ch.text() + ch.text('<>') + var idxTxt = cl.text().indexOf("<>") + ch.text(origText) + + // find the most specific type in the typemap for this point, e.g. + // the type assigned to the location with smallest distance between + // start and end. + var min = false; + var title = false; + typemap.forEach(function (el) { + // console.log('el', el); + var len = el.location.location.stop.point - el.location.location.start.point; + if (el.location.location.start.point <= idxTxt && + idxTxt <= el.location.location.stop.point && + (min === false || len < min)) { + var before = el.before.length ? el.before.join(' : ') + ' : []' : '[]'; + var after = el.after.length ? el.after.join(' : ') + ' : []' : '[]'; + title = before + ' → ' + after; + min = len; + } + }); + if (title) { + tgt.attr('title', title) + } + }) +} + +$(function () { + $('.highlight > pre').hover(function (e) { + var pre = $(this) + var code = pre.text(); + if (!pre.is('.type-checked')) { + pre.addClass('type-checked'); + $.ajax({ + url: "https://tezos-lang-server.tzalpha.net/typecheck_code", + type: 'POST', + dataType: 'json', + contentType: 'application/json', + processData: false, + data: JSON.stringify({code: code}), + success: function (typemap) { + addTypemap(pre, typemap) + }, + error: function(){ + console.log('error', arguments); + } + }); + } + }); +}); diff --git a/docs/doc_gen/michelson_reference/docs/static/ref.css b/docs/doc_gen/michelson_reference/docs/static/ref.css new file mode 100644 index 0000000000000000000000000000000000000000..791147f5edeb1fbe4ee40b6bcc5560b9802c801c --- /dev/null +++ b/docs/doc_gen/michelson_reference/docs/static/ref.css @@ -0,0 +1,100 @@ + +.check { background-color: #9e9; } +.cross { background-color: #e99; } + +#toc{ + display: none; +} + +@media (min-width: 550px) { /*Skeletons default grid-activation width*/ + #toc { + display: block; + margin-top: 5%; + width: 400px; + } +} + +#toc ul { list-style: none; margin-left: 1.5rem; } +#toc > ul { list-style: none; margin-left: 0; } + + +/* *** */ +html { + height: 100%; + font-family: sans-serif; +} +body { + height: 100%; + overflow: hidden; + margin: 0px; + display: flex; +} +.fl-column { + height: 100%; + display: flex; + flex-direction: column; +} +#left { + flex-shrink: 0; +} +#right { +} +.top-left { + flex-shrink: 0; + padding: 20px; +} +.top-right { + display: inline-flex; + flex-shrink: 0; + padding: 20px; +} +.bottom { + flex-grow: 1; + overflow-y: auto; + padding: 20px; +} +.top-right ul{ + display: inline-flex; + list-style: none; + margin: 0; +} +.top-right li{ + margin-right: 20px; +} + +.three-quarter.column { + width: 960px; +} + + +/** Try it examples */ + +.example { + position: relative; +} + +.example .try-it { + position: absolute; + top: 10px; + right: 10px; +} + +/** Tables */ +td.check, td.cross { + text-align: center; +} + + +.types-table th:last-child, +.types-table td:last-child { + padding: 12px 15px; +} + + +/** types */ + +dt { font-weight: bold; } + +.inline-list > li { + display: inline; +} diff --git a/docs/doc_gen/michelson_reference/docs/static/ref.js b/docs/doc_gen/michelson_reference/docs/static/ref.js new file mode 100644 index 0000000000000000000000000000000000000000..a766792037d4240f480a1023081eb582a0c9ce6f --- /dev/null +++ b/docs/doc_gen/michelson_reference/docs/static/ref.js @@ -0,0 +1,22 @@ +jQuery(function ($) { + var toc = $('#toc'); + var els = toc.find('.type, .instr'); + toc.find('#toc-search').on("keyup", function() { + var value = $(this).val(); + var caseSensitiveMatch = (value !== value.toLowerCase()); + value = value.replace('--', '—'); + + if (value != '') { + els.each(function() { + var match = caseSensitiveMatch ? + ($(this).text().indexOf(value) > -1) : + ($(this).text().toLowerCase().indexOf(value.toLowerCase()) > -1); + $(this).toggle(match); + $(this).parents('details').attr('open', match ? 'open' : 'close'); + }); + } else { + els.toggle(true); + toc.find('details').removeAttr('open'); + } + }); +}); diff --git a/docs/doc_gen/michelson_reference/examples-verify.py b/docs/doc_gen/michelson_reference/examples-verify.py new file mode 100644 index 0000000000000000000000000000000000000000..6ef19588f1a65c1fbe11d2dbcd2ca776678618f2 --- /dev/null +++ b/docs/doc_gen/michelson_reference/examples-verify.py @@ -0,0 +1,58 @@ +import os +from language_def import LanguageDefinition +import subprocess + + + + +def main(): + ldef = LanguageDefinition(False) + for instr in ldef.get_instructions(): + if not 'examples' in instr: + # print("No examples for " + instr) + continue + + for ex in instr['examples']: + if not 'path' in ex: + continue + if not 'input' in ex: + print(f"Missing initial input for example: {ex}") + sys.exit(1) + + cmd = ['tezos-client', + 'run', 'script', str(ex['path']), + 'on', 'storage', str(ex['initial_storage']), + 'and', 'input', str(ex['input'])] + out = subprocess.Popen( + cmd, + stdout = subprocess.PIPE, + stderr = subprocess.STDOUT) + + stdout,stderr = out.communicate() + stdout = stdout.decode("utf-8").split("\n") + + error = None + try: + # print(stdout) + idx1 = list(map(lambda s: s.strip(), stdout)).index("storage") + idx2 = list(map(lambda s: s.strip(), stdout)).index("emitted operations") + expected = str(ex['final_storage']) + # print(stdout[idx]) + # print(stdout[idx+1]) + obtained = ("".join(stdout[(idx1+1):idx2])).strip() + if expected != obtained: + error = f"Final storage is `{obtained}`, expected `{expected}` " + except ValueError: + error = f'Could not find final storage, script error?' + + if error != None: + print(" ✗ " + ex['path']) + print(" => " + error) + print(" => command: " + (" ".join(cmd))) + else: + print(" ✔ " + ex['path']) + + + +if __name__ == '__main__': + main() diff --git a/docs/doc_gen/michelson_reference/generate.py b/docs/doc_gen/michelson_reference/generate.py new file mode 100644 index 0000000000000000000000000000000000000000..b60efb44f04af6207ddd9162c54c59073c3006fc --- /dev/null +++ b/docs/doc_gen/michelson_reference/generate.py @@ -0,0 +1,62 @@ +#!/usr/bin/env python + +from jinja2 import Environment, FileSystemLoader, select_autoescape, Markup, StrictUndefined +from docutils.core import publish_parts +from language_def import LanguageDefinition +import re + +import argparse + +from pygments import highlight +from pygments.lexers import PythonLexer +from pygments.formatters import HtmlFormatter +from pygments_michelson import MichelsonLexer + +try_michelson_url = "https://try-michelson.tzalpha.net" + + +def rst_filter(s): + return Markup(publish_parts(source=s, writer_name='html')['body']) + +def rst_inline_filter(s): + if s == '': + return Markup('') + s = publish_parts(source=s, writer_name='html')['body'] + m = re.match(r'

(.*)

', s) + return Markup(m.group(1)) + +def pp_michelson_filter(code): + return Markup(highlight(code, MichelsonLexer(), HtmlFormatter())) + +# generates the documentation +env = Environment( + loader=FileSystemLoader('templates'), + autoescape=select_autoescape(['html', 'xml']), + undefined=StrictUndefined +) +env.filters['rst'] = rst_filter +env.filters['rst_inline'] = rst_inline_filter +env.filters['pp_michelson'] = pp_michelson_filter + +def main(): + parser = argparse.ArgumentParser(description='Generates michelson instruction reference from ott.') + parser.add_argument( + '--strict', dest='strict', action='store_const', + const=True, default=False, + help='terminate on undocumented instructions') + parser.add_argument( + '--standalone', dest='template_file', action='store_const', + const='body.html', default='index.html', + help='generate standalone reference: intended for embedding in michelson documentation') + args = parser.parse_args() + + lang_def = LanguageDefinition(strict=args.strict) + template = env.get_template(args.template_file) + print(template.render( + pygments_css=HtmlFormatter().get_style_defs('.highlight'), + lang_def=lang_def, + try_michelson_url=try_michelson_url + )) + +if __name__ == '__main__': + main() diff --git a/docs/doc_gen/michelson_reference/language_def.py b/docs/doc_gen/michelson_reference/language_def.py new file mode 100644 index 0000000000000000000000000000000000000000..81d45519d98b28baab89d4a6a46335836ed52661 --- /dev/null +++ b/docs/doc_gen/michelson_reference/language_def.py @@ -0,0 +1,199 @@ +import yaml +import json +import sys +import re +import os.path +from jsonschema import validate + +example_path = '../../../src/bin_client/test/contracts/' + +def synthesize_stack_effect(instr): + def ty_rule_to_stack_effect(r): + se = list(map(lambda s: s.strip(), + re.split(r'[-=]>', r['conclusion'].split("::")[1]))) + assert len(se) == 2 + return se + return list(map(ty_rule_to_stack_effect, instr['ty'])) + + +class LanguageDefinition(): + + default_instruction_meta = {'category': 'core', 'documentation_short': '--'} + default_type_meta = {'documentation_short': '--', + 'comparable': False, + 'pushable': False, + 'passable': False, + 'storable': False, + 'packable': False, + 'unpackable': False, + 'examples': [], + 'insertions': [] + } + + def __init__(self, + language_meta_file = 'michelson-meta.yaml', + language_meta_schema_file = 'michelson-meta-schema.json', + language_definition_file = 'michelson.json', + example_path = '../../../src/bin_client/test/contracts/', + strict=False): + self.strict = strict + + self.language_meta_file = language_meta_file + self.language_meta_schema_file = language_meta_schema_file + self.language_definition_file = language_definition_file + self.example_path = example_path + + self.instructions = False + self.instructions_by_category = False + self.types = False + self.categories = False + + self.load_language_def() + + def opt_error(self, msg): + msg = ("Error: " if self.strict else "Warning: ") + msg + print(msg, file=sys.stderr) + if self.strict: + sys.exit(1) + + def get_instructions(self): + if not self.instructions: + self.load_language_def() + return self.instructions + + def get_instructions_by_category(self, cat): + if not self.instructions_by_category: + self.load_language_def() + return self.instructions_by_category[cat] + + def get_types(self): + if not self.types: + self.load_language_def() + return self.types + + def get_type_attributes(self): + return [ + ('comparable', 'Comparable', 'C', 'Can be compared'), + ('passable', 'Passable', 'PM', 'Can be taken as parameter'), + ('storable', 'Storable', 'S', 'Can be put in storage'), + ('pushable', 'Pushable', 'PU', 'Can be pushed'), + ('packable', 'Packable', 'PA', 'Can be packed'), + ('big_map_value', 'big_map value', 'B', 'Can be stored in big_maps') + ] + + def get_categories(self): + if not self.categories: + self.load_language_def() + return self.categories + + def load_instructions(self, lang_def, lang_meta): + + self.instructions = [] + for op, instr in lang_def['instructions'].items(): + # Load meta information + if not op in lang_meta['instructions']: + self.opt_error("The instruction {} is undocumented".format(op)) + meta = LanguageDefinition.default_instruction_meta + else: + meta = lang_meta['instructions'][op] + instr = {**instr, **meta} + + # Check rules + if not len(instr['ty']): + self.opt_error(f"The instruction {op} has no typing rules") + if not len(instr['semantics']): + self.opt_error(f"The instruction {op} has no semantics rules") + + # Synthesize stack effet from typing rule + if not 'stack_effect' in instr and len(instr['ty']): + instr['stack_effect'] = synthesize_stack_effect(instr) + if not 'stack_effect' in instr or not len(instr['ty']): + print("Warning: The instruction {} has no stack effect, nor could it be inferred from typing rules" + .format(op), file=sys.stderr) + instr['stack_effect'] = False + + # Load examples + if 'examples' in instr: + for idxe, ex in enumerate(instr['examples']): + # Load from file if path is given + assert 'path' in ex, f'missing path in example {ex}' + + instr['examples'][idxe]['path'] = os.path.join(self.example_path, ex['path']) + + if os.path.exists(instr['examples'][idxe]['path']): + f = open(instr['examples'][idxe]['path']) + instr['examples'][idxe]['code'] = f.read() + f.close() + else: + print(f"Error: Could not find the file {instr['examples'][idxe]['path']}") + sys.exit(1) + + if not 'hide_final_storage' in ex: + instr['examples'][idxe]['hide_final_storage'] = False + else: + instr['examples'] = [] + + # Fill out optional properties + if not 'documentation' in instr: + instr['documentation'] = False + + # Verify category + assert (instr['category'] in lang_meta['categories']),\ + f"Ill-formed michelson-meta.yaml: instruction {op} has non-existant category {instr['category']}" + + self.instructions.append(instr) + + self.instructions.sort(key=lambda i: i['op']) + + self.instructions_by_category = {} + self.categories = lang_meta['categories'] + for cat in lang_meta['categories']: + self.instructions_by_category[cat] = [ i for i in self.instructions if i['category'] == cat ] + + + def load_types(self, lang_def, lang_meta): + self.types = [] + print("load types", file=sys.stderr) + for ty, ty_descr in lang_def['types'].items(): + if not ty in lang_meta['types']: + self.opt_error("The type {} is undocumented".format(ty)) + meta = {} + else: + meta = lang_meta['types'][ty] + meta = { **LanguageDefinition.default_type_meta, **meta } + + # Load examples + if 'examples' in meta: + for idxe, ex in enumerate(meta['examples']): + # if type is not given explicitely for the + # example, then the type is not parametric. + if type(ex) is not list: + meta['examples'][idxe] = (ex, ty_descr['ty']) + + # if polymorphic type, add some instantiations from + # examples. these are used in tests + if ty_descr['ty'] != ty_descr['ty_args'] and 'examples' in meta: + insertions = [ ty for (val, ty) in meta['examples'] ] + else: + insertions = [ ty_descr['ty'] ] + meta['insertions'] = meta['insertions'] + insertions + + self.types.append({**ty_descr, **meta}) + self.types.sort(key=lambda i: i['ty']) + + def load_language_def(self): + """Loads the michelson language definition. + + Uses michelson.json and michelson-meta.yaml. If strict is True, + fails if any instructions are undocumented. + """ + + # load and validate meta data + lang_meta = yaml.safe_load(open(self.language_meta_file, 'r')) + lang_def = json.load(open(self.language_definition_file)) + lang_meta_schema = json.load(open(self.language_meta_schema_file, 'r')) + validate(lang_meta, schema=lang_meta_schema) + + # collate meta and language definition for instruction + self.load_instructions(lang_def, lang_meta) + self.load_types(lang_def, lang_meta) diff --git a/docs/doc_gen/michelson_reference/michelson-meta-schema.json b/docs/doc_gen/michelson_reference/michelson-meta-schema.json new file mode 100644 index 0000000000000000000000000000000000000000..0184e48fd551f396ff99c57ef2859d3d81649781 --- /dev/null +++ b/docs/doc_gen/michelson_reference/michelson-meta-schema.json @@ -0,0 +1,119 @@ +{ + "$schema": "http://json-schema.org/draft-06/schema#", + "$ref": "#/definitions/MichelsonLanguage", + "definitions": { + "MichelsonLanguage": { + "type": "object", + "additionalProperties": false, + "properties": { + "categories": { + "$ref": "#/definitions/Categories" + }, + "instructions": { + "$ref": "#/definitions/Instructions" + }, + "types": { + "$ref": "#/definitions/Types" + } + }, + "required": [ + "categories", + "instructions" + ], + "title": "MichelsonLanguage" + }, + "Categories": { + "type": "object", + "additionalProperties": true, + "title": "Categories", + "patternProperties": { + ".*": { + "type": "string" + } + } + }, + "Instructions": { + "type": "object", + "additionalProperties": true, + "title": "Instruction", + "patternProperties": { + ".*": { "$ref": "#/definitions/Instruction" } + } + }, + "Types": { + "type": "object", + "additionalProperties": true, + "title": "Types", + "patternProperties": { + ".*": { "$ref": "#/definitions/Type" } + } + }, + "Instruction": { + "type": "object", + "additionalProperties": false, + "properties" : { + "category": { "type" : "string" }, + "documentation_short": { "type" : "string" }, + "documentation": { "type": "string" }, + "stack_effect": { "type": "string" }, + "examples": { + "type": "array", + "items": { + "$ref": "#/definitions/Example" + } + } + }, + "required": [ + "category", + "documentation_short" + ] + }, + "Example": { + "type": "object", + "additionalProperties": false, + "properties": { + "name": {"type": "string"}, + "description": {"type": "string"}, + "path": {"type": "string"}, + "input": {"type": "string"}, + "initial_storage": {"type": "string"}, + "final_storage": {"type": "string"}, + "hide_final_storage": {"type": "boolean"} + }, + "required": [ + "description", + "final_storage", + "initial_storage", + "input", + "path" + ] + }, + "Type": { + "type": "object", + "additionalProperties": false, + "properties": { + "documentation_short": { "type": "string" }, + "documentation": { "type": "string" }, + "comparable": { "type": "boolean" }, + "passable": { "type": "boolean" }, + "packable": { "type": "boolean" }, + "pushable": { "type": "boolean" }, + "unpackable": { "type": "boolean" }, + "storable": { "type": "boolean" }, + "big_map_value": { "type": "boolean" }, + "literal": { "type": "boolean" }, + "examples": { "type": "array" }, + "insertions": { "type": "array" } + }, + "required": [ + "documentation_short", + "comparable", + "pushable", + "passable", + "packable", + "storable", + "big_map_value" + ] + } + } +} diff --git a/docs/doc_gen/michelson_reference/michelson-meta.yaml b/docs/doc_gen/michelson_reference/michelson-meta.yaml new file mode 100644 index 0000000000000000000000000000000000000000..0ac41b24474b3a7d114c5732e7f285859f68e492 --- /dev/null +++ b/docs/doc_gen/michelson_reference/michelson-meta.yaml @@ -0,0 +1,1404 @@ +categories: + core: Core instructions + domain: Domain specific instructions + deprecated: Deprecated instructions +instructions: + ADD: + category: core + documentation_short: Adds two numerical values + documentation: | + Adds numerical values. + This instruction is polymorphic and accepts any combination of natural numbers and integers as operands. + The return value is a natural number if both operands are natural. Otherwise, it is an integer. + + Furthermore, integers can be added to timestamps in which case + the return value is a timestamp offset with the integer number + of seconds. + + Finally, a ``mutez`` can be added to a ``mutez``, in which case the return value is a ``mutez``. + + examples: + - name: Various additions + description: This example demonstrates the addition of different types of numbers and domain specific types. + path: opcodes/add.tz + input: 'Unit' + initial_storage: 'Unit' + final_storage: 'Unit' + hide_final_storage: True + ADDRESS: + category: core + documentation_short: Push the address of a contract + documentation: | + This instruction consumes a contract value and produces the address of that contract. + + examples: + - name: Address examples + description: This demonstrates takes a contract by parameter, and then stores its address. + path: opcodes/address.tz + input: '"tz1b7tUupMgCNw2cCLpKTkSD1NZzB5TkP2sv"' + initial_storage: 'None' + final_storage: '(Some "tz1b7tUupMgCNw2cCLpKTkSD1NZzB5TkP2sv")' + + LOOP_LEFT: + category: core + documentation_short: Loop with accumulator + documentation: | + The ``LOOP_LEFT body`` instruction executes ``body`` as long + as the top element of the stack is ``(Left a)``. The ``body`` + of the loop must consume a value of type ``a`` and produce a + value of type ``(or a b)``. + + If the top element is ``(Right b)``, at the beginning of the loop or at + the end of an iteration, then the loop is terminated and this value is + left on the top of the stack. + + examples: + - name: Sum list + description: This contract reverses the list of strings passed by parameter and stores it. + path: opcodes/loop_left.tz + input: '{ "a" ; "b" ; "c" }' + initial_storage: '{}' + final_storage: '{ "c" ; "b" ; "a" }' + CDR: + category: core + documentation_short: Access the right part of a pair + examples: + - name: Store right parameter + description: | + This contract takes a pair as parameter. It selects the right + part of the parameter and stores it. + + path: opcodes/cdr.tz + input: '(Pair 15 9)' + initial_storage: '0' + final_storage: '9' + CAR: + category: core + documentation_short: Access the left part of a pair + examples: + - name: Store left parameter + description: | + This contract takes a pair as parameter. It selects the left + part of the parameter and stores it. + + path: opcodes/car.tz + input: '(Pair 15 9)' + initial_storage: '0' + final_storage: '15' + CHAIN_ID: + category: core + documentation_short: Push the chain identifier + examples: + - name: Push the chain identifier. + description: | + This contract pushes and then stores the chain identifier. + + path: opcodes/chain_id_store.tz + input: 'Unit' + initial_storage: 'None' + final_storage: '(Some 0x7a06a770)' + hide_final_storage: True + PAIR: + category: core + documentation_short: Build a pair from the stack’s top two elements + DIP: + category: core + documentation_short: Runs code protecting the top of the stack + documentation: | + ``DIP n code`` runs ``code`` protecting the ``n`` topmost + elements of the stack. In particular, ``DIP 0 code`` is + equivalent to ``code`` and ``DIP 1 code`` is equivalent to ``DIP + code``. + + + examples: + - description: | + This examples takes a pair of integers ``(a, b)`` as parameter, + and stores ``(a, a + b)`` + + path: opcodes/dip.tz + input: '(Pair 15 9)' + initial_storage: '(Pair 0 0)' + final_storage: '(Pair 15 24)' + DUP: + category: core + documentation_short: Duplicate the top of the stack + + DROP: + category: core + documentation_short: Drop the top ``n`` elements of the stack + documentation: | + ``DROP n`` drops the `n` topmost elements of the stack. In + particular, ``DROP 0`` is a noop and ``DROP 1`` is equivalent to + ``DROP``. + + FAILWITH: + category: core + documentation_short: Explicitly abort the current program + + IF: + category: core + documentation_short: Conditional branching + documentation: | + The ``IF bt bf`` instruction consumes a stack ``b : S`` of type + ``bool : A``. I.e., ``b`` is a ``boolean`` and the trailing + stack ``S`` has any stack type ``A``. + + This instruction executes the ``bt`` branch if ``b`` is + ``True``, and the ``bf`` branch otherwise. + + Note that both branches must return a stack of the same type. + + IF_CONS: + category: core + documentation_short: Inspect a list + documentation: | + The ``IF_CONS bt bf`` instruction consumes a stack ``l : S`` of type + ``list ty1 : A``. I.e., ``l`` is a ``list ty1`` and the trailing + stack ``S`` has any stack type ``A``. + + It consumes the list ``l``. If it has at least one element + ``hd`` followed by (a possibly empty) list ``tl``, then the + ``bt`` branch is executed with the stack ``hd : tl : S``. + Otherwise, the ``bf`` branch is executed with the stack ``A``. + + Note that both branches must return a stack of the same type. + + IF_SOME: + category: core + documentation_short: Inspect an optional value + documentation: | + The ``IF_SOME bt bf`` instruction consumes a stack ``v : S`` of type + ``option ty1 : A``. I.e., ``v`` is a ``option ty1`` and the trailing + stack ``S`` has any stack type ``A``. + + If the optional value ``v`` is ``Some x``, then the ``bt`` + branch is executed with the stack ``x : A``. If ``v`` is + ``None``, then the ``bf`` branch is executed with the stack + ``A``. + + Note that both branches must return a stack of the same type. + + IF_NONE: + category: core + documentation_short: Inspect an optional value (symmetric with ``IF_SOME``) + documentation: | + The ``IF_NONE bt bf`` instruction consumes a stack ``v : S`` of type + ``option ty1 : A``. I.e., ``v`` is a ``option ty1`` and the trailing + stack ``S`` has any stack type ``A``. + + If the optional value ``v`` is ``None``, then the ``bt`` + branch is executed with the stack ``A``. If ``v`` is + ``Some x``, then the ``bf`` branch is executed with the stack + ``x : A``. + + Note that both branches must return a stack of the same type. + + IF_LEFT: + category: core + documentation_short: Inspect a value of a union + documentation: | + The ``IF_LEFT bt bf`` instruction consumes a stack ``v : S`` of type + ``or ty1 ty2 : A``. I.e., ``v`` is a ``or ty1 ty2`` and the trailing + stack ``S`` has any stack type ``A``. + + If the union ``v`` stack is ``Left x``, then the ``bt`` branch + is executed with the stack ``x : A``. If it is ``Right y``, + then the ``bf`` branch is executed with the stack ``y : A``. + + Note that both branches must return a stack of the same type. + + IF_RIGHT: + category: core + documentation_short: Inspect a value of a union (symmetric with ``IF_LEFT``) + documentation: | + The ``IF_RIGHT bt bf`` instruction consumes a stack ``v : S`` of type + ``or ty1 ty2 : A``. I.e., ``v`` is a ``or ty1 ty2`` and the trailing + stack ``S`` has any stack type ``A``. + + If the union ``v`` stack is ``Right y``, then the ``bt`` branch + is executed with the stack ``y : A``. If it is ``Left x``, then + the ``bf`` branch is executed with the stack ``x : A``. + + Note that both branches must return a stack of the same type. + + LEFT: + category: core + documentation_short: Pack a value in a union (left case) + NOOP: + category: core + documentation_short: Empty instruction sequence + PAIR: + category: core + documentation_short: "Build a pair from the stack's top two elements" + PUSH: + category: core + documentation_short: Push a constant value of a given type onto the stack + RIGHT: + category: core + documentation_short: Pack a value in a union (right case) + SEQ: + category: core + documentation_short: Instruction sequence + SWAP: + category: core + documentation_short: Exchange the top two elements of the stack + PACK: + category: core + documentation_short: Serialize data + documentation: | + Serializes any value of packable type to its optimized binary representation, of type ``bytes``. + + examples: + - name: "``PACK`` -- ``UNPACK``" + description: | + This example packs the left part of the parameter, and + asserts that it is equal to the right part of the parameter. + It then verifies that the right part unpacks to a valid + Michelson value. + + path: opcodes/packunpack.tz + input: '(Pair (Pair (Pair "toto" {3;7;9;1}) {1;2;3}) 0x05070707070100000004746f746f020000000800030007000900010200000006000100020003)' + initial_storage: 'Unit' + final_storage: 'Unit' + UNPACK: + category: core + documentation_short: Deserializes a piece of data, if valid + documentation: | + Serialize a value of type ``bytes`` into the corresponding Michelson value of type ``ty1``. + If the top of the stack is not the serialization of a Michelson value of type ``ty1``, then ``None`` is pushed. + Otherwise, ``Some v`` is pushed, where ``v`` is the unserialized value. + + examples: [] + examples: + - name: "``UNPACK`` reverses ``PACK``" + description: | + This example takes a tuple with a member of each comparable + type, packs and unpacks each member and asserts that the + resulting value is unchanged. + + path: opcodes/packunpack_rev.tz + input: '(Pair -1 (Pair 1 (Pair "foobar" (Pair 0x00AABBCC (Pair 1000 (Pair False (Pair "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" (Pair "2019-09-09T08:35:33Z" "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5"))))))))' + initial_storage: 'Unit' + final_storage: 'Unit' + BLAKE2B: + category: core + documentation_short: Compute a Blake2B cryptographic hash + documentation: | + Compute the cryptographic hash of the top of the stack using the BLAKE2B cryptographic hash function. + + examples: + - name: Hash and store + description: This example computes the BLAKE2B hash of the string passed as parameter and puts it in storage. + path: opcodes/hash_string.tz + input: '"foobar"' + initial_storage: 0x + final_storage: '0xc5b7e76c15ce98128a840b54c38f462125766d2ed3a6bff0e76f7f3eb415df04' + SHA256: + category: core + documentation_short: Compute a SHA-256 cryptographic hash + documentation: | + Compute the cryptographic hash of the top of the stack using the SHA-256 cryptographic hash function. + SHA512: + category: core + documentation_short: Compute a SHA-512 cryptographic hash + documentation: | + Compute the cryptographic hash of the top of the stack using the SHA-512 cryptographic hash function. + ABS: + category: core + documentation_short: Obtain the absolute value of an integer + documentation: | + ``ABS`` consumes an integer and pushes its absolute value, with type ``nat``, on the stack. + + examples: + - name: '``ABS`` is the reverse of ``NEG`` on natural numbers.' + description: | + This examples negates a natural number, takes the absolute + value and asserts that the final value equals the initial + parameter. + + Note that this is true for any natural number, since + Michelson numbers are arbitrary-precision. + + path: opcodes/abs.tz + input: '12039123919239192312931' + initial_storage: 'Unit' + final_storage: 'Unit' + hide_final_storage: True + AMOUNT: + category: core + documentation_short: Push the amount of the current transaction + documentation: | + Push the amount of the current transaction, in ``mutez``. + + examples: + - name: Store ``AMOUNT`` + description: This contract stores the amount of its last received transaction. + path: opcodes/transfer_amount.tz + input: 'Unit' + initial_storage: '0' + final_storage: '50000' + hide_final_storage: True + AND: + category: core + documentation_short: Logical and binary AND + documentation: | + The instruction ``AND`` is defined on boolean and natural number operands. + In the former case, the result is the logical AND of the operands. + In the latter case, the result is the binary AND of the operands. + + ``AND`` is also defined for integer operands. Negative + numbers are considered in 2's complement representation, + starting with a virtual infinite number of 1s. + + examples: + - name: Logical AND + description: This contracts takes a pair of booleans, and computes and stores their conjunction. + path: opcodes/and_logical_1.tz + initial_storage: 'False' + input: '(Pair True False)' + final_storage: 'False' + + - name: Binary AND + description: This contract demonstrates binary AND on numerical values. + path: opcodes/and_binary.tz + initial_storage: 'Unit' + input: 'Unit' + final_storage: 'Unit' + hide_final_storage: True + BALANCE: + category: core + documentation_short: Push the current amount of mutez of the current contract + documentation: | + Push the current amount of mutez of the current contract, + including any mutez added by the transaction. + + examples: + - name: Store ``BALANCE`` + description: This contract stores its balance after its latest received transaction. + path: opcodes/balance.tz + input: 'Unit' + initial_storage: '0' + final_storage: '4000000000000' + hide_final_storage: True + CHECK_SIGNATURE: + category: core + documentation_short: 'Verifies ``signature`` of ``bytes`` by ``key``' + documentation: | + Verifies that a byte sequence has been signed with a given key. + This instruction consumes three operands: a ``key``, a ``signature`` and a + byte sequence. It pushes ``True`` if and only if the signature is a + valid signature of the byte sequence by the given key. + + examples: + - name: Check signature + description: | + This contract stores a ``signature`` and a ``string``. It + takes a ``key`` as parameter and runs successfully if the + stored ``signature`` is a valid signature of the BLAKE2B + hash of the stored string by that ``key``. + + path: opcodes/check_signature.tz + input: '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"' + initial_storage: '(Pair "edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7" "hello")' + final_storage: '(Pair "edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7" "hello")' + COMPARE: + category: core + documentation_short: 'Compares two values' + documentation: | + Comparison only works on a class of types that we call + comparable. The ``COMPARE`` instruction is defined in an ad hoc way + for each comparable type, but the result of ``COMPARE`` is + always an ``int``, which can in turn be checked in a generic + manner using the ``EQ``, ``NEQ``, ``LT``, ``GT``, ``LE`` and + ``GE`` combinators. + + The result of ``COMPARE`` is ``0`` if the top two elements of + the stack are equal, negative if the first element in the stack + is less than the second, and positive otherwise. + + examples: + - name: A variety of comparisons + description: | + This contract demonstrate several types of comparisons over different values. + + path: opcodes/compare.tz + input: 'Unit' + initial_storage: 'Unit' + final_storage: 'Unit' + CONCAT: + category: core + documentation_short: String, byte sequence, string list and byte sequence list concatenation + documentation: | + The ``CONCAT`` operator is overloaded four times: + + - The first version takes two string operands and pushes their concatenation, as a string. + - The second takes a list of strings and pushes the concatenation of all strings in the list, as a string. + - The third version takes two byte sequences and pushes their concatenation, as a byte sequence. + - The fourth version takes a list of byte sequences and pushes the concatenation of all byte sequences in the list, as a byte sequence. + + examples: + - name: Concatenation of two strings + description: This example takes a list of strings as parameter. It prepends ``"Hello "`` to each of them and stores the result. + path: opcodes/concat_hello.tz + input: '{ "John" ; "Jane" }' + initial_storage: "{}" + final_storage: '{ "Hello John" ; "Hello Jane" }' + - name: Concatenation of list of strings + description: This example takes a list of strings as parameter and concatenates them, and prepends value in storage and stores the resulting string. + path: opcodes/list_concat.tz + input: '{ " " ; "World" ; "!" }' + initial_storage: '"Hello"' + final_storage: '"Hello World!"' + - name: Concatenation of two byte sequences + description: This example takes a list of byte sequences as parameter. It prepends ``0xff`` to each of them and stores the result. + path: opcodes/concat_hello_bytes.tz + input: '{ 0xab ; 0xcd }' + initial_storage: "{}" + final_storage: '{ 0xffab ; 0xffcd }' + - name: Concatenation of list of byte sequences + description: This example takes a list of byte sequences as parameter and concatenates them, and prepends the value in storage and stores the resulting byte sequence. + path: opcodes/list_concat_bytes.tz + input: '{ 0xbe ; 0xef }' + initial_storage: '0xdead' + final_storage: '0xdeadbeef' + + CONTRACT: + category: core + documentation_short: 'Push the untyped version of a contract' + documentation: | + Converts from an ``address`` to a ``contract ty``. + If and only if the address is a valid Tezos contract address with the type ``ty``, + then the result is ``Some contract`` is pushed. + If the address belongs to an implicit contract, then the type parameter ``ty`` must be ``unit``. + If any of these conditions are not fulfilled, ``None`` is pushed. + + examples: + - name: A variety of comparisons + description: | + This contract receives an ``address`` by parameter, and converts it to a ``contract unit``. + + path: opcodes/contract.tz + input: '"tz1b7tUupMgCNw2cCLpKTkSD1NZzB5TkP2sv"' + initial_storage: 'Unit' + final_storage: 'Unit' + + CONS: + category: core + documentation_short: Prepend an element to a list + documentation: | + Prepends the element at the top of the stack to the list that is + the second element of the stack. + + examples: + - name: Prepend to storage. + description: This contracts keeps a list of integers in storage and takes an integer as parameter. It prepends the parameter to the stored list. + path: opcodes/cons.tz + input: '5' + initial_storage: "{ 99 }" + final_storage: "{ 5 ; 99 }" + + CREATE_CONTRACT: + category: core + documentation_short: Forge a new contract from a literal + documentation: | + Originate a contract based on a literal. The operands are the + optional delegate, the initial amount taken from the currently + executed contract, and the initial storage of the originated contract. + The contract is returned as a first class value (to be dropped, passed + as parameter or stored). The ``CONTRACT 'p`` instruction will fail + until it is actually originated. + + CREATE_ACCOUNT: + category: deprecated + documentation_short: Forge an account creation operation + documentation: | + Takes as operands the manager, optional delegate, the delegatable flag + and finally the initial amount taken from the currently executed + contract. This instruction originates a contract with two entrypoints; + ``%default`` of type ``unit`` that does nothing and ``%do`` of type + ``lambda unit (list operation)`` that executes and returns the + parameter if the sender is the contract's manager. + + + EDIV: + category: core + documentation_short: Euclidian division + documentation: | + Consumes two numbers ``x`` and ``y`` (of either ``int`` or + ``nat``) and returns ``None`` if ``y`` is zero and otherwise, ``Some (Pair + (x / y) (x % y))`` otherwise. + + + EMPTY_MAP: + category: core + documentation_short: Build a new, empty ``map`` from ``kty`` to ``vty`` + documentation: | + Build a new, empty map from keys of a given type ``kty`` to values of + the other given type ``vty``. + + The ``cty`` type must be comparable. + + EMPTY_BIG_MAP: + category: core + documentation_short: Build a new, empty ``big_map`` from ``kty`` to ``vty`` + documentation: | + Build a new, empty map from keys of a given type ``kty`` to values of + the other given type ``vty``. + + The ``cty`` type must be comparable. The ``vty`` type cannot be + a ``operation`` or ``big_map``. + + EMPTY_SET: + category: core + documentation_short: Build a new, empty set for elements of type ``cty`` + documentation: | + Build a new, empty set for elements of a given + type ``cty``. + + The ``cty`` type must be comparable. + + EQ: + category: core + documentation_short: Checks that the top of the stack EQuals zero + documentation: | + The ``EQ`` instruction consumes an integer and leaves ``True`` + on the stack if it is ``0`` and ``False`` otherwise. + + It is typically composed with ``COMPARE``: the instruction sequence + ``COMPARE; EQ`` leaves ``True`` on the stack if the two top + stack elements are equal, and ``False`` otherwise. + + NEQ: + category: core + documentation_short: Checks that the top of the stack does Not EQual zero + documentation: | + The ``NEQ`` instruction consumes an integer and leaves ``True`` + on the stack if it is not ``0`` and ``False`` otherwise. + + It is typically composed with ``COMPARE``: the instruction sequence + ``COMPARE; NEQ`` leaves ``True`` on the stack if the two top + stack elements are not equal, and ``False`` otherwise. + + LT: + category: core + documentation_short: Checks that the top of the stack is Less Than zero + documentation: | + The ``LT`` instruction consumes an integer and leaves ``True`` + on the stack if it is less than ``0`` and ``False`` otherwise. + + It is typically composed with ``COMPARE``: the instruction sequence + ``COMPARE; LT`` leaves ``True`` on the stack if the first stack + element is less than the second, and ``False`` otherwise. + + GT: + category: core + documentation_short: Checks that the top of the stack is Greater Than zero + documentation: | + The ``GT`` instruction consumes an integer and leaves ``True`` + on the stack if it is greater than ``0`` and ``False`` otherwise. + + It is typically composed with ``COMPARE``: the instruction sequence + ``COMPARE; GT`` leaves ``True`` on the stack if the first stack + element is greater than the second, and ``False`` otherwise. + + LE: + category: core + documentation_short: Checks that the top of the stack is Less Than of Equal to zero + documentation: | + The ``LE`` instruction consumes an integer and leaves ``True`` + on the stack if it is less than or equal to ``0`` and ``False`` otherwise. + + It is typically composed with ``COMPARE``: the instruction sequence + ``COMPARE; LE`` leaves ``True`` on the stack if the first stack + element is less than or equal to the second, and ``False`` otherwise. + + GE: + category: core + documentation_short: Checks that the top of the stack is Greater Than of Equal to zero + documentation: | + The ``GE`` instruction consumes an integer and leaves ``True`` + on the stack if it is greater than or equal to ``0`` and ``False`` otherwise. + + It is typically composed with ``COMPARE``: the instruction sequence + ``COMPARE; GE`` leaves ``True`` on the stack if the first stack + element is greater than or equal to the second, and ``False`` + otherwise. + + EXEC: + category: core + documentation_short: Execute a function from the stack + documentation: | + The ``EXEC`` instruction consumes a value ``x`` of type ``a`` + and a value ``f`` of type `lambda a b`, applies the lambda to + ``x`` and leaves the results, of type ``b``, on the stack. + + + APPLY: + category: core + documentation_short: Partially apply a tuplified function from the stack + documentation: | + Partially apply a tuplified function from the stack. That is, + the ``APPLY`` instruction consumes a value ``x`` of type ``a`` + and a value ``f`` of type `lambda (Pair a b) c`. + It /partially/ applies the lambda to ``x``, hence producing a + new lambda of type `lambda a c` on the stack. + Intuitively, this amounts to creating a new function that works + like ``f`` but with the first parameter ``a`` fixed to ``x``. + + The new lambda is storable, and thus values that cannot be + stored (values of type ``operation``, ``contract _`` and ``big + map _ _``) cannot be captured by ``APPLY`` (cannot appear in + ``a``). + + GET: + category: core + documentation_short: Access an element in a ``map`` or ``big_map`` + documentation: | + The instruction ``GET`` consumes a key and a ``map`` or ``big_map`` and returns an + optional value: ``None`` if the key is not present in the data structure, + and ``Some v`` if it is present and mapped to ``v``. + + MEM: + category: core + documentation_short: Check for the presence of a binding for a key in a ``map``, ``set`` or ``big_map`` + documentation: | + The instruction ``GET`` consumes a value and a data structure of + type ``map``, ``set`` or big_map``. + + For ``map`` and ``big_map``, ``GET`` returns ``True`` if the + value is a bound key in the data structure, and ``False`` + otherwise. + + For ``set``, ``True`` is returned if the value is a member of + the ``set``, and ``False`` otherwise. + + + UPDATE: + category: core + documentation_short: Add or remove an element in a ``map``, ``big_map`` or ``set`` + documentation: | + For values of type ``map`` and ``big_map``, the instruction ``UPDATE`` consumes + a key, an optional value and a value of type ``map`` or ``big_map`` . + It returns the same map, but updated in the following way: + + - If the value is ``Some x`` then key is assigned to ``x`` in + the resulting map. + - If the value is ``None`` and the key is present in the map, + then it is removed in the resulting map. If the key is not + present, an unmodified map is returned. + + For values of type ``set``, the instruction ``UPDATE`` consumes + a value ``v``, a boolean flag ``b`` and a set ``s``. It returns the same set, + but updated in the following way: + + - If ``b`` is ``True`` then the value ``v`` is added to the set ``s``. + If ``v`` was already present in ``s``, then the original set is returned. + - If ``b`` is ``False`` then the value ``v`` is removed from ``s``. + If ``v`` is not present in ``s``, then the original set is returned. + + MAP: + category: core + documentation_short: Assign or remove an element in a map + documentation: | + The instruction ``UPDATE`` consumes a key, an optional value and a map. + It returns the map, is updated in the following way: + + - If the value is ``Some x`` then key is assigned to ``x`` in + the resulting map. + - If the value is ``None`` and the key is present in the map, + then it is removed in the resulting map. If the key is not + present, an unmodified map is returned. + + TRANSFER_TOKENS: + category: domain + documentation_short: Forge a transaction + documentation: | + The ``TRANSFER_TOKENS`` instruction consumes a value ``v`` of type ``ty1``, + an amount ``a`` in ``mutez`` and a ``c`` of type ``contract ty1``. It returns + a transfer operation that will send to ``a`` mutez to the + specified contract ``c`` with the parameter value ``v``. + + Consequently, the parameter value must be consistent with the + parameter type of the contract. In the case the contract is an + implicit account, then the parameter must be of type ``unit``. + + HASH_KEY: + category: domain + documentation_short: Compute the b58check of a public key + documentation: | + The ``HASH_KEY`` instruction computes the + [b58check](https://en.bitcoin.it/wiki/Base58Check) of a public + key. + + + IMPLICIT_ACCOUNT: + category: domain + documentation_short: Create an implicit account + documentation: | + Return a default contract (an implicit account) with the given + public/private key pair. Any funds deposited in this contract + can immediately be spent by the holder of the private key. This + contract cannot execute Michelson code and will always exist on + the blockchain. + + ITER: + category: core + documentation_short: Iterate over a ``set``, ``list`` or ``map`` + documentation: | + + Iterate on a ``set``, ``list`` or ``map``. + + Apply the body expression to each element the structure: + + - In the case of a list or set, the body is applied to each + element, and must thus have the type ``ty1 : A => A``. + - In the case of a map, the body is applied to each binding + ``key`` to value ``val`` in the form of a pair ``Pair key + val``, and must thus have the type ``Pair ty1 ty2 : A => + A``. + + In each case, the body has access to the stack. + + LAMBDA: + category: core + documentation_short: Push a lambda onto the stack + documentation: | + Push a lambda with parameter type ``ty1``, return type ``ty2`` and body ``code`` + onto the stack. + + LOOP: + category: core + documentation_short: A generic loop + documentation: | + + The instruction ``LOOP`` consumes a stack ``b : S`` of type + ``bool : A``, i.e. where ``b`` is boolean and the rest of the + stack is of any type ``A``. The body of the loop, ``code``, is + executed as long as ``b`` is ``True``. The body has access to the stack ``S`` + but must produce a stack of type ``bool : A``. If ``b`` is + ``False``, then the loop is terminated with the resulting stack ``S``. + + LSL: + category: core + documentation_short: Logically left shift a natural number + documentation: | + + The ``LSL`` instruction consumes two natural numbers and produces + the first number logically left-shifted by second number. + + This instruction is only defined if the second number is less + than or equal to 256. + + LSR: + category: core + documentation_short: Logically right shift an natural number + documentation: | + The ``LSR`` instruction consumes two natural numbers and produces + the first number logically right-shifted by second number. + + This instruction is only defined if the second number is less than or equal to 256. + + MUL: + category: core + documentation_short: Multiplicates two numerical values + documentation: | + The ``MUL`` instruction consumes two natural numbers (int or + nat) and produces their product. ``MUL`` can also be used to + multiply a ``mutez`` with a natural number. + + NOT: + category: core + documentation_short: Logical negation and bitwise complement + documentation: | + The ``NOT`` instruction is defined for ``bool``, + ``nat`` and ``int``. + + For ``bool``, it returns the logical negation of its operand. + + For numerical values, it returns the complement as an ``int``. + In this case, the return type is an ``int`` and not a ``nat``. + This is because the sign is also negated. The resulting integer + is computed using two's complement. For instance, the boolean + negation of ``0`` is ``-1``. To get a natural back, a + possibility is to use ``AND`` with an unsigned mask afterwards. + + NEG: + category: core + documentation_short: Negates a numerical value + documentation: | + + The ``NEG`` instruction consumes a natural number (``int`` or + ``nat``) and produces their negation, in the form of an + ``int``. + + NIL: + category: core + documentation_short: Produces an empty list + documentation: | + + The ``NIL ty1`` instruction produces the empty list of type ``list ty1``. + It is functionally equivalent to ``PUSH (list ty1) {}``. + + NONE: + category: core + documentation_short: Produces the absent optional value + documentation: | + + The ``NONE ty1`` instruction produces the + absent optional value ``None`` of type ``option ty1``. + + It is functionally equivalent to ``PUSH (option ty1) None``. + + SOME: + category: core + documentation_short: Pack a present optional value + documentation: | + + The ``SOME`` instruction packs the top element ``x`` of the + stack, of type ``ty1`` into the present optional value ``Some + x`` of type ``option ty1``. + + SENDER: + category: domain + documentation_short: Push the contract that initiated current internal transaction + documentation: | + + Push the contract that initiated the current + internal transaction. It may be the ``SOURCE``, but may + also not if the source sent an order to an intermediate + smart contract, which then called the current contract. + + SOURCE: + category: domain + documentation_short: Push the contract that initiated the current transaction + documentation: | + Push the contract that initiated the current + transaction, i.e. the contract that paid the fees and + storage cost, and whose manager signed the operation + that was sent on the blockchain. + + Note that since ``TRANSFER_TOKENS`` instructions can be chained, + ``SOURCE`` and ``SENDER`` are not necessarily the same. + + SELF: + category: domain + documentation_short: Push the current contract + documentation: | + The ``SELF`` contract pushes the current contract, of type + ``contract ty1`` where ``ty1`` is the type of the currnet + contract. + + NOW: + category: domain + documentation_short: Push block timestamp + documentation: | + Push the timestamp of the block whose validation triggered this + execution. This timestamp doe not change during the execution of + the contract. + + OR: + category: core + documentation_short: Logical and binary OR + documentation: | + The instruction ``OR`` is defined on boolean and natural number operands. + In the former case, the result is the logical OR of the operands. + In the latter case, the result is the binary OR of the operands. + + SET_DELEGATE: + category: core + documentation_short: Produce a delegation operation + documentation: | + The ``SET_DELEGATE`` is used to add, updated or remove a + delegation. It consumes an operand of type ``option + key_hash``. + + If the operand is ``None``, then the produced operation will + remove the executing contracts current delegation, if any. If + the operand is ``Some k``, then the produced operation will + update, or add a delegation, from the executing contract to the + implicit account specified by ``k``. + + SIZE: + category: core + documentation_short: Get the size of a ``string``, ``list``, ``set``, ``map`` or byte sequence + + documentation: | + The ``SIZE`` instruction consumes and returns the size of the + top element of the stack as an ``nat``. It is defined for values of type ``string``, ``list``, ``set``, ``map`` and byte sequences ``bytes``. + + - For a ``string`` value, it returns the number of characters. + - For a ``list``, it returns the number of elements. + - For a ``set``, it returns the number of elements. + - For a ``map``, it returns the number of key-value pairs. + - For a byte sequence ``bytes``, it returns the number of bytes. + + + SLICE: + category: core + documentation_short: Obtain a substring or subsequence of a ``string`` respectively byte sequence ``bytes`` + + documentation: | + The ``SLICE`` instruction consumes two natural numbers ``offset`` and ``length`` + and a character sequence (``string``) or bytes sequence (``bytes``). + + It returns a substring, respectively subsequence, ``Some v`` of + length ``length`` starting at ``offset`` (where offset 0 denotes + the first element) of the sequence. + + If ``offset`` and ``length`` is out of bounds, i.e. ``offset >= + len`` or ``offset + length >= len`` (where ``len`` is the length + of the sequence), then ``None`` is returned. + + STEPS_TO_QUOTA: + category: domain + documentation_short: Push the remaining steps before the contract execution must terminate + + documentation: | + *Deprecated*. The ``STEPS_TO_QUOTA`` instruction pushes the + number of steps remaining before contract execution is aborted + due to gas exhaustion. + + SUB: + category: core + documentation_short: Subtract two numerical values + documentation: | + + Consumes two numerical values and returns their difference. The + the return type depends on the operand type: + + - Integers can be subtracted from natural numbers and + vice versa, in which case the result type is always an + integer. + - Integers can be subtracted from timestamps, in which case the + result is a timestamp. + - Timestamps can also be subtracted from timestamps, in which + case the result is a integer denoting their difference + in seconds. + + UNIT: + category: core + documentation_short: Push a unit value onto the stack + + XOR: + category: core + documentation_short: Logical and binary eXclusive OR + documentation: | + The instruction ``XOR`` is defined on boolean and natural number operands. + In the former case, the result is the logical XOR of the operands. + In the latter case, the result is the binary XOR of the operands. + + DIG: + category: core + documentation_short: Retrieves the ``n``\ th element of the stack + documentation: | + ``DIG n`` consumes a stack that contains at least ``n`` + elements. It removes the ``n``\ th element of the stack, and + puts it on the top of the stack. The element on top of the stack + is the 0th element, so that ``DIG 0`` is a no-op. + In other words, ``DIG`` transforms a stack on the form ``x0 : x1 : + ... : xn : ...`` into the stack ``xn : x0 : x1 : ...``. + + The inverse of ``DIG`` is ``DUG``. + + DUG: + category: core + documentation_short: Insert the top element at depth ``n`` + documentation: | + ``DUG n`` consumes a stack that contains at least ``n`` + elements. It removes the top element of the stack, and inserts + it at the ``n``\ th level in the stack. The element on top of + the stack is at depth ``0`` so that ``DUG 0`` is a no-op. In + other words, ``DUG`` transforms a stack on the form ``x0 : x1 : + ... : xn : ...`` into the stack ``x0 : x1 : ... : x0 : xn : + ...``. + + The inverse of ``DUG`` is ``DIG``. + + INT: + category: core + documentation_short: Converts a natural number to an integer + + ISNAT: + category: core + documentation_short: Converts an non-negative integer to a natural number + documentation: | + The ``ISNAT`` instruction consumes an integer ``i`` and returns + a value of type ``option nat``. If the integer is non-negative, + ``Some n`` is returned, where ``n`` is equal to ``i`` but + represented as a natural number. Otherwise, ``None`` is + returned. + +types: + string: + documentation_short: "A string of characters" + comparable: true + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + documentation: | + The current version of Michelson restricts strings to be the printable + subset of 7-bit ASCII, namely characters with codes from within + `[32, 126]` range, plus the following escape characters ``\n``, + ``\\``, ``\"``. Unescaped line-breaks (both ``\n`` and ``\r``) + cannot appear in a string. + examples: + - "\"foo\"" + - "\"ABC\\n123\"" + nat: + documentation_short: "An arbitrary-precision natural number" + comparable: true + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + examples: + - 0 + - 1 + - 99999 + int: + documentation_short: "An arbitrary-precision integer" + comparable: true + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + examples: + - -99999 + - -1 + - 0 + - 1 + - 99999 + bytes: + documentation_short: "A sequence of bytes" + comparable: true + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + examples: + - "0x" + - "0xABCDEF42" + bool: + documentation_short: "A boolean" + comparable: true + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + documentation: | + The type for booleans whose values are ``True`` and ``False``. + + examples: + - "True" + - "False" + mutez: + documentation_short: "A specific type for manipulating tokens" + comparable: true + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + examples: + - 0 + - 1 + - 99999 + key_hash: + documentation_short: "A hash of a public cryptography key" + comparable: true + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + examples: + - '"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"' + - '"tz1XPTDmvT3vVE5Uunngmixm7gj7zmdbPq6k"' + + timestamp: + documentation_short: "A real-world date" + comparable: true + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + examples: + - '"2019-09-26T10:59:51Z"' + - '1571659294' + documentation: | + Literal ``timestamp``\ s are written either using ``RFC3339`` notation + in a string (readable), or as the number of seconds since Epoch in + a natural (optimized). + + + key: + documentation_short: "A public cryptography key" + comparable: false + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + examples: + - '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"' + - '"edpkuJqtDcA2m2muMxViSM47MPsGQzmyjnNTawUPqR8vZTAMcx61ES"' + + unit: + documentation_short: The type whose only value is ``Unit`` + comparable: false + passable: true + storable: true + big_map_value: true + pushable: true + packable: true + documentation: | + The type whose only value is ``Unit``, to use as a placeholder + when some result or parameter is non-necessary. For instance, + when the only goal of a contract is to update its storage. + examples: + - Unit + + signature: + documentation_short: "A cryptographic signature" + comparable: false + passable: true + storable: true + big_map_value: true + pushable: true + packable: true + examples: + - '"edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7"' + - '"spsig1PPUFZucuAQybs5wsqsNQ68QNgFaBnVKMFaoZZfi1BtNnuCAWnmL9wVy5HfHkR6AeodjVGxpBVVSYcJKyMURn6K1yknYLm"' + option: + documentation_short: An optional value + comparable: false + passable: true + storable: true + big_map_value: true + pushable: true + packable: true + documentation: | + Optional value of type ``vty`` that we note ``None`` or ``(Some v)``. + examples: + - ['None', 'option unit'] + - ['Some "foo"', 'option string'] + + list: + documentation_short: "A single, immutable, homogeneous linked list" + comparable: false + pushable: true + packable: true + passable: true + storable: true + big_map_value: true + documentation: | + A single, immutable, homogeneous linked list, whose elements are + of type ``type``, and that we note ``{}`` for the empty list or + ``{ first ; ... }``. In the semantics, we use the less-than and + greater-than sign (< and >) to denote a subsequence of + elements. For instance ``{ head ; }``. + examples: + - ["{}", 'list unit'] + - ["{ 0 ; 10 }", 'list nat'] + - ["{ Some 10 ; None }", 'list (option int)'] + set: + documentation_short: "An immutable set of comparable values of type ``cty``" + comparable: false + passable: true + storable: true + big_map_value: true + pushable: true + packable: true + documentation: | + Immutable sets of comparable values of type ``cty`` that we note + as lists ``{ item ; ... }``, of course with their elements + unique, and sorted. + examples: + - ["{}", 'set bool'] + - ["{ 0 ; 3 ; 4 }", 'set nat'] + + contract: + documentation_short: "A contract, with the type of its code, i.e. its parameter type" + insertions: [ 'contract nat' ] + comparable: false + literal: false + passable: true + big_map_value: true + pushable: false + packable: true + storable: false + documentation: + A value of type ``contract t`` is guaranteed to be a valid, + existing account whose parameter type is ``t``. This can be + opposed to the ``address`` type, that merely gives the guarantee + that the value has the form of a Tezos address. + + Values of the ``contract`` type cannot be serialized using + ``PACK``, nor can they be taken as a parameter or be + stored. There are not literal values of type contract. + Instead, such values are created using instructions such as + ``CONTRACT`` or ``IMPLICIT_ACCOUNT``. + + address: + documentation_short: "An untyped contract address" + passable: true + storable: true + big_map_value: true + comparable: true + pushable: true + packable: true + documentation: | + The ``address`` type merely gives the guarantee that the value + has the form of a Tezos address, as opposed to ``contract`` + that guarantees that the value is indeed a valid, existing + account. + + A valid Tezos address is a string prefixed by either ``tz1``, + ``tz2``, ``tz3`` or ``KT1`` and followed by a Base58 encoded + hash and terminated by a 4-byte checksum. + + The prefix designates the type of address: + + - ``tz1`` addresses are followed by a ed25519 public key hash + - ``tz2`` addresses are followed by a Secp256k1 public key hash + - ``tz3`` addresses are followed by a NIST p256r1 public key hash + - ``KT1`` addresses are followed by a contract hash + + Addresses prefixed by ``tz1``, ``tz2`` and ``tz3`` designate + implicit accounts, whereas those prefixed ``KT1`` designate + originated accounts. + + examples: + - '"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"' + - '"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"' + - '"tz2VGBaXuS6rnaa5hpC92qkgadRJKdEbeGwc"' + - '"tz3WEJYwJ6pPwVbSL8FrSoAXRmFHHZTuEnMA"' + + operation: + documentation_short: "An internal operation emitted by a contract" + passable: false + pushable: false + storable: false + big_map_value: false + packable: false + documentation: + There are not literal values of type ``operation``. + Instead, such values are created using the primitive such as + ``TRANSFER_TOKEN`` and ``CREATE_ACCOUNT``. + + comparable: false + pair: + documentation_short: A pair of values + passable: true + storable: true + big_map_value: true + comparable: true + pushable: true + packable: true + documentation: | + A pair of values ``a`` and + ``b`` of types ``ty1`` and ``ty2``, that we write ``(Pair a + b)``. + + Pairs are comparable under the restriction that the left component does not itself contain a pair. For example the following values are comparable: + - ``Pair 10 "foo"`` + - ``Pair "foo" (Pair "bar" "baz")`` + - ``Pair True (Pair "bar" (Pair 10 -5))`` + + On the other hand, these values are not comparable: + - ``Pair (Pair "bar" "baz") "foo"`` + - ``Pair "foo" (Pair (Pair "bar" "baz") "baz")`` + + examples: + - ["(Pair 0 True)", 'pair int bool'] + + or: + documentation_short: A union of two types + passable: true + storable: true + big_map_value: true + pushable: true + packable: true + comparable: false + documentation: | + A union of two types: a value holding either a value ``a`` of + type ``ty1`` or a value ``b`` of type ``ty2``, that we write + ``(Left a)`` or ``(Right b)``. + examples: + - ['(Left True)', 'or bool string'] + - ['(Right "foo")', 'or bool string'] + + lambda: + documentation_short: A lambda with given parameter and return types + passable: true + storable: true + big_map_value: true + pushable: true + packable: true + comparable: false + examples: + - ['{ }', 'lambda unit unit'] + - ['{ PUSH nat 1; ADD }', 'lambda nat nat'] + + map: + documentation_short: An immutable map from ``kty`` to ``vty`` + passable: true + storable: true + big_map_value: true + pushable: true + packable: true + comparable: false + documentation: | + Immutable maps from keys of type ``kty`` of values of type + ``vty`` that we note ``{ Elt key value ; ... }``, with keys + sorted. + examples: + - ['{}', 'map nat unit'] + - ['{ Elt 0 0xCB ; Elt 1 0xAB }', 'map nat bytes'] + + big_map: + documentation_short: A lazily deserialized map from ``kty`` to ``vty`` + comparable: false + packable: false + passable: true + pushable: false + storable: true + big_map_value: false + documentation: | + Lazily deserialized maps from keys of type ``kty`` of values of + type ``vty`` that we note ``{ Elt key value ; ... }``, with keys + sorted. These maps should be used if you intend to store large + amounts of data in a map. They have higher gas costs than + standard maps as data is lazily deserialized. + + Literal ``big_map``s cannot be pushed directly in contract + code. Instead, they must be created using ``EMPTY_BIG_MAP`` and + manipulated using ``GET``, ``UPDATE`` and ``MEM``. However, + literal ``big_map``s are used when originating and calling + contrats using ``tezos-client``. + + Values of the ``big_map`` type cannot be serialized using ``PACK``. + examples: + - ['{}', 'big_map nat bytes'] + - ['{ Elt 0 0xCB ; Elt 1 0xAB }', 'big_map nat bytes'] + + chain_id: + documentation_short: A chain identifier + passable: true + storable: true + big_map_value: true + pushable: true + packable: true + comparable: false + documentation: | + An identifier for a chain, used to distinguish the test and the main chains. + examples: + - '0x7a06a770' diff --git a/docs/doc_gen/michelson_reference/michelson.ott b/docs/doc_gen/michelson_reference/michelson.ott new file mode 100644 index 0000000000000000000000000000000000000000..e1f2b28de0c137c82edab86415e0bfc6d1d8109f --- /dev/null +++ b/docs/doc_gen/michelson_reference/michelson.ott @@ -0,0 +1,1852 @@ +embed {{ coq +Require Import String. +Require Import ZArith. +Open Scope string_scope. + +Module Mutez. + Inductive mutez :=. +End Mutez. + +}} + +metavar nat_litteral ::= {{ coq nat }} {{ phantom }} +metavar int_litteral ::= {{ coq Z }} +% metavar string_litteral ::= {{ coq String.string }} +% metavar ctx ::= {{ coq option type }} + +% metavar timestamp_litteral ::= {{ coq Z }} +% metavar signature_litteral ::= {{ coq String.string }} +% metavar key_litteral ::= {{ coq String.string }} +% metavar key_hash_litteral ::= {{ coq String.string }} +% metavar mutez_litteral ::= {{ coq Mutez.mutez }} +% metavar contract_litteral ::= {{ coq String.string }} + +indexvar N ::= {{ coq nat }} + +grammar + +%% Operators + +bop :: 'bop_' ::= {{ coq bool -> bool -> bool }} {{ phantom }} + | || :: :: Or {{ coq orb }} + | && :: :: And {{ coq andb }} + | xor :: :: Xor {{ coq xorb }} + +aop :: 'aop_' ::= + | + :: :: Add + | - :: :: Sub + | * :: :: Mul + | / :: :: Div + | % :: :: Mod + | << :: :: Lsl + | >> :: :: Lsr + +bitop :: 'bitop_' ::= + | | :: :: Or + | & :: :: And + | ^ :: :: Xor + +%% Data litterals + +% nat_lit, n :: 'n_' ::= {{ coq nat }} {{ phantom }} +% | 0 :: M :: NatZero {{ coq 0 }} +% | 1 :: M :: NatOne {{ coq 1 }} +% | 256 :: M :: NatMaxByte {{ coq 256 }} +% | length s :: M :: StringLength {{ coq (String.length s) }} +% | abs z :: M :: Abs {{ coq (Z.abs_nat [[z]]) }} + +int_lit, il, z, ts, nz :: 'z_' ::= {{ coq Z }} {{ phantom }} + | 0 :: M :: IntZero {{ coq 0 }} + | 1 :: M :: IntOne {{ coq 1 }} + | 256 :: M :: NatMaxByte {{ coq 256 }} + | z1 aop z2 :: M :: Aop {{ coq ( num_apply_aop [[aop]] [[z1]] [[z2]] ) }} + | z1 bitop z2 :: M :: Bitop {{ coq ( num_apply_bitop [[bitop]] [[z1]] [[z2]] ) }} + | - z :: M :: NumNeg {{ coq ( num_neg [[z]] ) }} + | ~ z :: M :: BitNeg {{ coq ( num_bit_neg [[z]] ) }} + | length s :: M :: StringLength {{ coq (Z.of_nat (String.length s)) }} + | abs z :: M :: Abs {{ coq (Z.abs [[z]]) }} + + % reflection + | balance :: M :: Balance + | amount :: M :: Amount + | now :: M :: Now + +% num, nz :: 'num_' ::= +% | int_lit :: :: IntConstant +% | nat_lit :: :: NatConstant +% | nz1 aop nz2 :: M :: Aop {{ coq ( num_apply_aop [[aop]] [[nz1]] [[nz2]] ) }} +% | nz1 bitop nz2 :: M :: Bitop {{ coq ( num_apply_bitop [[bitop]] [[nz1]] [[nz2]] ) }} +% | - nz :: M :: NumNeg {{ coq ( num_neg [[nz]] ) }} +% | ~ nz :: M :: BitNeg {{ coq ( num_bit_neg [[nz]] ) }} + +string_lit, s , t , sig :: 's_' ::= {{ coq String.string }} {{ phantom }} + | "" :: M :: StringEmpty {{ coq ("") }} + | ( s ^ s' ) :: M :: Concat {{ coq (String.append [[s]] [[s']]) }} + | slice s z1 z2 :: M :: StringSlice {{ coq (String.substring (Z.to_nat [[z1]]) (Z.to_nat [[z2]]) [[s]]) }} + % string as key_hash + | hash_key s :: M :: HashKey + % string as address + | address s :: M :: Address + | source :: M :: Source + | sender :: M :: Sender + % string as chain_id + | chain_id :: M :: ChainId + % string as contract + | self :: M :: Self + | implicit_account s :: M :: ImplicitAccount + % string as operation + | transfer_tokens d z s :: M :: TransferTokens + | set_delegate d :: M :: SetDelegate + + +bytes_lit, byt :: 'byt_' ::= {{ coq String.string }} {{ phantom }} + | 0x :: M :: BytesEmpty {{ coq ("") }} + | ( byt ^ byt' ) :: M :: Concat {{ coq (Bytes.append [[byt]] [[byt']]) }} + | slice byt n1 n2 :: M :: BytesSlice {{ coq (Bytes.subbytes [[n1]] [[n2]] [[byt]]) }} + | hash hash_function byt :: M :: HashBytes + % string as bytes + | pack d :: M :: Pack + +bool_lit, b :: 'b_' ::= {{ coq bool }} {{ phantom }} + | True :: M :: True {{ coq true }} + | False :: M :: False {{ coq false }} + | ( b1 bop b2 ) :: M :: Bop {{ coq ( [[bop]] [[b1]] [[b2]] ) }} + | ! b2 :: M :: Neg {{ coq ( negb [[b2]] ) }} + % auxiliary functions returning bool + | check_signature s sig byt :: M :: CheckSignature + +set_or_list, tl, m :: 'setlist_' ::= {{ coq list concrete_data }} {{ phantom }} + | {} :: M :: Nil {{ coq nil }} + | { d ; tl } :: M :: Cons {{ coq ([[d]] :: [[tl]]) }} + %% meta-productions + | { d } :: M :: Singleton {{ coq ([[d]] :: nil) }} + | < tl > :: M :: Chevron {{ coq [[tl]] }} + +% map_elt :: '' ::= +% | Elt k v :: :: Elt + +% map_lit, m :: 'map_' ::= {{ coq list (concrete_data * concrete_data) }} {{ phantom }} +% | {} :: M :: Nil {{ coq nil }} +% | { Elt d d' ; m } :: M :: Cons {{ coq (([[d]], [[d']])::[[m]]) }} +% % meta-productions +% | { Elt d d' } :: M :: Singleton {{ coq (([[d]], [[d']])::nil) }} +% | < m > :: M :: Chevron {{ coq [[m]] }} +% %| { Elt d1 d1' ; .. ; Elt dN dN' } :: :: Map + + +%% Data + +concrete_data, data, x, y, k, v, d, opt_y :: d_ ::= + | int_lit :: :: Int_constant + | string_lit :: :: String_constant + | bytes_lit :: :: Bytes_constant + | bool_lit :: :: Bool + % | timestamp_litteral :: :: Timestamp + % | signature_litteral :: :: Signature + % | key_litteral :: :: Key + % | key_hash_litteral :: :: Key_hash + % | mutez_litteral :: :: Mutez + % | contract_litteral :: :: Contract + | Unit :: :: Unit + | Pair x y :: :: Pair + | Left x :: :: Left + | Right y :: :: Right + | Some x :: :: Some + | None :: :: None + | set_or_list :: :: Concrete_seq + % | map_lit :: :: Map + | Elt x y :: :: Elt + | { code : ty1 -> ty2 } :: :: Instruction + + % | 0 :: M :: zero {{ coq data_int 0%Z}} + | ( data ) :: M :: Paren {{ coq ( [[data]] ) }} + + % from address to option contract + | contract ty s :: M :: Contract + % from int to option nat + | isnat z :: M :: IsNat + % from bytes to option bytes + | unpack ty d :: M :: Unpack + +%% Types + +simple_comparable_type, scty :: scty_ ::= + | string :: :: string + | nat :: :: nat + | int :: :: int + | bytes :: :: bytes + | bool :: :: bool + | mutez :: :: mutez + | key_hash :: :: key_hash + | address :: :: address + | timestamp :: :: timestamp + +comparable_type, cty, kty :: scty_ ::= + | simple_comparable_type :: :: Simple_comparable_type + | pair simple_comparable_type comparable_type :: :: Pair_comparable_type + +type, ty, vty :: ty_ ::= + | scty :: :: Comparable_type + | key :: :: key + | unit :: :: unit + | signature :: :: signature + | option type :: :: option + | list type :: :: list + | set cty :: :: set + | contract type :: :: contract + | operation :: :: operation + | pair ty1 ty2 :: :: pair + | or ty1 ty2 :: :: or + | lambda ty1 ty2 :: :: lambda + | map kty vty :: :: map + | big_map kty vty :: :: big_map + | chain_id :: :: chain_id + %% Meta productions + % | self_ty ctx :: M :: self_ty {{coq self_ty [[ctx]] }} + | ( ty1 ) :: M :: parens {{coq ([[ty1]])}} + %% Explicit coercion of comparable_type to type + | to_type cty :: M :: test_cty {{coq ( comparable_type_to_type [[cty]] ) }} + +%% Operations + +comparison :: 'i_' ::= + | EQ :: :: EQ + | NEQ :: :: NEQ + | LT :: :: LT + | GT :: :: GT + | LE :: :: LE + | GE :: :: GE + +binary_bitwise :: 'i_' ::= + | OR :: :: OR + | AND :: :: AND + | XOR :: :: XOR + +hash_function :: 'i_' ::= + | BLAKE2B :: :: BLAKE2B + | SHA256 :: :: SHA256 + | SHA512 :: :: SHA512 + +%% Instructions + + +function :: 'i_' ::= + | PUSH ty1 x :: :: PUSH + | UNIT :: :: UNIT + | LAMBDA ty1 ty2 code :: :: LAMBDA + | APPLY :: :: APPLY + | EMPTY_SET cty :: :: EMPTY_SET + | EMPTY_MAP kty vty :: :: EMPTY_MAP + | EMPTY_BIG_MAP kty vty :: :: EMPTY_BIG_MAP + | NONE ty1 :: :: NONE + | NIL ty1 :: :: NIL + | BALANCE :: :: BALANCE + | SOURCE :: :: SOURCE + | SENDER :: :: SENDER + | SELF :: :: SELF + | AMOUNT :: :: AMOUNT + | NOW :: :: NOW + + | comparison :: :: unary_comparison + | hash_function :: :: unary_hash + | HASH_KEY :: :: HASH_KEY + | NOT :: :: NOT + | NEG :: :: NEG + | ABS :: :: ABS + | INT :: :: INT + | ISNAT :: :: ISNAT + | SIZE :: :: SIZE + | CAR :: :: CAR + | CDR :: :: CDR + | SOME :: :: SOME + | LEFT ty2 :: :: LEFT + | RIGHT ty1 :: :: RIGHT + | ADDRESS :: :: ADDRESS + | CONTRACT ty :: :: CONTRACT + | SET_DELEGATE :: :: SET_DELEGATE + | IMPLICIT_ACCOUNT :: :: IMPLICIT_ACCOUNT + | CHAIN_ID :: :: CHAIN_ID + | PACK :: :: PACK + | UNPACK ty1 :: :: UNPACK + + | binary_bitwise :: :: b_bitwise + | EXEC :: :: EXEC + | LSL :: :: LSL + | LSR :: :: LSR + | COMPARE :: :: COMPARE + | CONCAT :: :: CONCAT + | PAIR :: :: PAIR + | MEM :: :: MEM + | GET :: :: GET + | CONS :: :: CONS + + | DUP :: :: DUP + | SWAP :: :: SWAP + + | SLICE :: :: SLICE + | UPDATE :: :: UPDATE + % | CREATE_ACCOUNT :: :: CREATE_ACCOUNT + | TRANSFER_TOKENS :: :: TRANSFER_TOKENS + | CHECK_SIGNATURE :: :: CHECK_SIGNATURE + + | ADD :: :: ADD + | SUB :: :: SUB + | MUL :: :: MUL + | EDIV :: :: EDIV + +%% Code + +instruction, code, i, body :: 'i_' ::= + | function :: :: Fun + | FAILWITH :: :: FAILWITH + | {} :: :: NOOP + | code1 ; code2 :: :: SEQ + | IF code1 code2 :: :: IF + | LOOP code :: :: LOOP + | LOOP_LEFT code :: :: LOOP_LEFT + | DIP nat_litteral code :: :: DIP + | DIG nat_litteral :: :: DIG + | DUG nat_litteral :: :: DUG + | DROP nat_litteral :: :: DROP + | ITER code :: :: ITER + | MAP code :: :: MAP + | IF_NONE code1 code2 :: :: IF_NONE + | IF_LEFT code1 code2 :: :: IF_LEFT + | IF_CONS code1 code2 :: :: IF_CONS + | CREATE_CONTRACT ty1 ty2 code :: :: CREATE_CONTRACT + +%% Stack + +stack, st, S :: Stack_ ::= {{coq list concrete_data }} {{ phantom }} + | [] :: M :: empty {{ coq nil }} + | d : S :: M :: cons {{ coq ([[d]] :: [[S]]) }} + | st ++ st' :: M :: append {{ coq (List.app[[st]][[st']])}} + | ( S ) :: M :: paren {{ coq ( [[S]] ) }} + +stack_type, A, B, C :: Stack_type_ ::= {{ coq Datatypes.list type }} {{ phantom }} + | [] :: :: empty {{ coq nil}} + | ty1 ':' A :: :: cons {{ coq (cons[[ty1]][[A]])}} + | A @ B :: M :: append {{ coq (List.app[[A]][[B]])}} + | ( A ) :: M :: paren {{ coq ( [[A]] ) }} + % | [ ty1 ; .. ; tyN ] :: M :: stack_type_list {{ coq [[ ty1 .. tyN ]] }} + +% A stackerr is either failed or a stack, which is a list of data. +stackerr, SE :: 'SE_' ::= + | [FAILED] :: :: Failed + | stack :: :: Stack + +% a context + +code_context, ctx :: 'cc_' ::= {{ coq option type }} {{ phantom }} + | Some ty :: :: Some {{ coq ( Some [[ty]] ) }} + | None :: :: None {{ coq None }} + + +%% Formulas + +formula :: formula_ ::= + | judgement :: :: judgement + | formula1 .. formulaN :: :: dots + | get_contract_type s ty :: M :: get_contract_rel + {{ coq C.get_contract_rel [[s]] [[ty]] }} + + | x = y :: M :: deq {{coq (compare [[x]] i_EQ [[y]])}} + | x <> y :: M :: dneq {{coq (compare [[x]] i_NEQ [[y]])}} + | s < t :: M :: seq {{coq (string_compare_lt [[s]] [[t]])}} + | s > t :: M :: sneq {{coq (string_compare_lt [[t]] [[s]])}} + + | z1 < z2 :: M :: lt {{coq ([[z1]] z2 :: M :: gt {{coq ([[z1]] >? [[z2]] = true)}} + | z1 <= z2 :: M :: le {{coq ([[z1]] <=? [[z2]] = true)}} + | z1 >= z2 :: M :: ge {{coq ([[z1]] >=? [[z2]] = true)}} + + | ctx = ctx' :: M :: ctx_eq {{ coq ([[ctx]] = [[ctx']]) }} + + | length A = nat_litteral :: M :: stack_type_len {{ coq List.length [[A]] = [[nat_litteral]] }} + | length S = nat_litteral :: M :: stack_len {{ coq List.length [[S]] = [[nat_litteral]] }} + + % operation + | create_contract ty1 ty2 code d z x = ( s1 , s2 ) :: M :: CreateContract + + + % {{coq ctx_self_ty [[ctx]] }} + +embed {{coq + +Fixpoint comparable_type_to_type (c : comparable_type) : type := + match c with + | scty_simple_comparable_type scty => ty_Comparable_type scty + | scty_pair_comparable_type scty cty => + ty_pair (ty_Comparable_type scty) + (comparable_type_to_type cty) + end. + + +Module Type ContractContext. + Parameter get_contract_rel : String.string -> type -> Prop. +End ContractContext. + +Module Semantics (C : ContractContext). + (* Variable self_ty : type. *) + (* Variable get_contract_rel : String.string -> type -> Prop. *) + (* Coercion comparable_type_to_type : comparable_type >-> type. *) + +}} + +embed {{ coq +Load Formulas. +}} + + +defns +Typing :: 't_' ::= + + defn + ctx :- x '::' ty :: :: data_has_type :: 'data_' by + + ------------------ :: int + ctx :- z :: int + + + z >= 0 + ------------------ :: nat + ctx :- z :: nat + + ------------------------ :: string + ctx :- string_lit :: string + + ------------------------------ :: timestamp + ctx :- ts :: timestamp + + ------------------------------ :: signature + ctx :- s :: signature + + ------------------ :: key + ctx :- s :: key + + ---------------------------- :: key_hash + ctx :- s :: key_hash + + ---------------------- :: mutez + ctx :- z :: mutez + + get_contract_type s ty1 + ------------------------------------- :: contract + ctx :- s :: contract ty1 + + ------------------------------------- :: address + ctx :- s :: address + + ------------------------------------- :: chain_id + ctx :- s :: chain_id + + ------------------------------------- :: bytes + ctx :- byt :: bytes + + ----------- :: Unit + ctx :- Unit :: unit + + ----------- :: bool + ctx :- bool_lit :: bool + + ctx :- x :: ty1 + ctx :- y :: ty2 + ------------------- :: Pair + ctx :- Pair x y :: pair ty1 ty2 + + ctx :- x :: ty1 + --------------- :: Left + ctx :- Left x :: or ty1 ty2 + + ctx :- y :: ty2 + ---------------- :: Right + ctx :- Right y :: or ty1 ty2 + + ctx :- x :: ty1 + ----------------- :: Some + ctx :- Some x :: option ty1 + + --------------- :: None + ctx :- None :: option ty1 + + ------------------------ :: set_empty + ctx :- :setlist_Nil: {} :: set cty + + ctx :- x :: to_type cty + ctx :- tl :: set cty + ------------------------ :: set_cons + ctx :- { x ; } :: set cty + + ------------------------ :: list_empty + ctx :- :setlist_Nil: {} :: list ty + + ctx :- x :: ty + ctx :- tl :: list ty + ------------------------ :: list_cons + ctx :- { x ; } :: list ty + + ------------------------ :: map_empty + ctx :- :setlist_Nil: {} :: map kty vty + + ctx :- x :: to_type kty + ctx :- y :: vty + ctx :- m :: map kty vty + ------------------------ :: map_cons + ctx :- { Elt x y ; } :: map kty vty + + %% ctx should have no self_type + None :- code :: ty1 : [] => ty2 : [] + ------------------------- :: instruction + ctx :- { code : ty1 -> ty2 } :: lambda ty1 ty2 + + % defn + % map_elt '::' kty, vty :: :: map_elt_has_type :: 'map_elt_' by + + % k :: to_type kty + % v :: vty + % ------------------ :: map_elt + % Elt k v :: kty, vty + + + defn + ctx :- function '::' A -> B :: :: fun_has_type :: 'instr_' by + + ctx :- x :: ty1 + ---------------------------- :: PUSH + ctx :- PUSH ty1 x :: [] -> ty1 : [] + + ----------------------- :: UNIT + ctx :- UNIT :: [] -> unit : [] + + None :- code :: ty1 : [] => ty2 : [] + ------------------------------------------------ :: LAMBDA + ctx :- LAMBDA ty1 ty2 code :: [] -> lambda ty1 ty2 : [] + + ----------------------------------- :: EMPTY_SET + ctx :- EMPTY_SET cty :: [] -> set cty : [] + + ------------------------------------------- :: EMPTY_MAP + ctx :- EMPTY_MAP kty vty :: [] -> map kty vty : [] + + ------------------------------------------- :: EMPTY_BIG_MAP + ctx :- EMPTY_BIG_MAP kty vty :: [] -> big_map kty vty : [] + + --------------------------------- :: NONE + ctx :- NONE ty1 :: [] -> option ty1 : [] + + ------------------------------ :: NIL + ctx :- NIL ty1 :: [] -> list ty1 : [] + + --------------------------- :: BALANCE + ctx :- BALANCE :: [] -> mutez : [] + + ---------------------------- :: SOURCE + ctx :- SOURCE :: [] -> address : [] + + ---------------------------- :: SENDER + ctx :- SENDER :: [] -> address : [] + + %% self_ty : can be Some or None, how to match? + ctx = Some ty + -------------------------- :: SELF + ctx :- SELF :: [] -> contract ty : [] + + -------------------------- :: AMOUNT + ctx :- AMOUNT :: [] -> mutez : [] + + --------------------------- :: NOW + ctx :- NOW :: [] -> timestamp : [] + + ----------------------------------- :: comparison + ctx :- comparison :: int : [] -> bool : [] + + ----------------------------- :: NOT__bool + ctx :- NOT :: bool : [] -> bool : [] + + --------------------------- :: NOT__nat + ctx :- NOT :: nat : [] -> int : [] + + --------------------------- :: NOT__int + ctx :- NOT :: int : [] -> int : [] + + --------------------------- :: NEG__nat + ctx :- NEG :: nat : [] -> int : [] + + --------------------------- :: NEG__int + ctx :- NEG :: int : [] -> int : [] + + --------------------------- :: ABS + ctx :- ABS :: int : [] -> nat : [] + + --------------------------- :: INT + ctx :- INT :: nat : [] -> int : [] + + --------------------------- :: ISNAT + ctx :- ISNAT :: int : [] -> option nat : [] + + -------------------------------- :: SIZE__set + ctx :- SIZE :: set cty : [] -> nat : [] + + ------------------------------------ :: SIZE__map + ctx :- SIZE :: map kty vty : [] -> nat : [] + + ------------------------------- :: SIZE__list + ctx :- SIZE :: list ty1 : [] -> nat : [] + + ------------------------------- :: SIZE__string + ctx :- SIZE :: string : [] -> nat : [] + + ------------------------------ :: SIZE__bytes + ctx :- SIZE :: bytes : [] -> nat : [] + + ------------------------------ :: CAR + ctx :- CAR :: pair ty1 ty2 : [] -> ty1 : [] + + ------------------------------ :: CDR + ctx :- CDR :: pair ty1 ty2 : [] -> ty2 : [] + + ------------------------------- :: SOME + ctx :- SOME :: ty1 : [] -> option ty1 : [] + + ------------------------------- :: LEFT + ctx :- LEFT ty2 :: ty1 : [] -> or ty1 ty2 : [] + + -------------------------------- :: RIGHT + ctx :- RIGHT ty1 :: ty2 : [] -> or ty1 ty2 : [] + + ------------------------------------------ :: ADDRESS + ctx :- ADDRESS :: contract ty1 : [] -> address : [] + + --------------------------------------------- :: CONTRACT + ctx :- CONTRACT ty1 :: address : [] -> option ( contract ty1 ) : [] + + ------------------------------------------------------ :: SET_DELEGATE + ctx :- SET_DELEGATE :: option key_hash : [] -> operation : [] + + ------------------------------------------------------- :: IMPLICIT_ACCOUNT + ctx :- IMPLICIT_ACCOUNT :: key_hash : [] -> contract unit : [] + + ---------------------------- :: PACK + ctx :- PACK :: ty1 : [] -> bytes : [] + + -------------------------------- :: UNPACK + ctx :- UNPACK ty1 :: bytes : [] -> option ty1 : [] + + ------------------------------------- :: HASH_KEY + ctx :- HASH_KEY :: key : [] -> key_hash : [] + + ----------------------------------------- :: HASH + ctx :- hash_function :: bytes : [] -> bytes : [] + + ----------------------------------------------- :: bitwise_bool + ctx :- binary_bitwise :: bool : bool : [] -> bool : [] + + -------------------------------------------- :: bitwise_nat + ctx :- binary_bitwise :: nat : nat : [] -> nat : [] + + --------------------------------------------- :: EXEC + ctx :- EXEC :: ty1 : lambda ty1 ty2 : [] -> ty2 : [] + + --------------------------------------------- :: APPLY + ctx :- APPLY :: ty1 : lambda (pair ty1 ty2) ty3 : [] -> lambda ty2 ty3 : [] + + --------------------------------- :: LSL + ctx :- LSL :: nat : nat : [] -> nat : [] + + --------------------------------- :: LSR + ctx :- LSR :: nat : nat : [] -> nat : [] + + --------------------------------- :: COMPARE + ctx :- COMPARE :: to_type cty : to_type cty : [] -> int : [] + + --------------------------------------------- :: CONCAT__string_list + ctx :- CONCAT :: list string : [] -> string : [] + + --------------------------------------------- :: CONCAT__string + ctx :- CONCAT :: string : string : [] -> string : [] + + ------------------------------------------ :: CONCAT__bytes_list + ctx :- CONCAT :: bytes : bytes : [] -> bytes : [] + + ------------------------------------------ :: CONCAT__bytes + ctx :- CONCAT :: list bytes : [] -> bytes : [] + + ----------------------------------- :: PAIR + ctx :- PAIR :: ty1 : ty2 : [] -> pair ty1 ty2 : [] + + ---------------------------------- :: MEM__set + ctx :- MEM :: to_type cty : set cty : [] -> bool : [] + + ------------------------------------------ :: MEM__map + ctx :- MEM :: to_type kty : map kty vty : [] -> bool : [] + + ---------------------------------------------- :: MEM__big_map + ctx :- MEM :: to_type kty : big_map kty vty : [] -> bool : [] + + ------------------------------------------------ :: GET__map + ctx :- GET :: to_type kty : map kty vty : [] -> option vty : [] + + ---------------------------------------------------- :: GET__big_map + ctx :- GET :: to_type kty : big_map kty vty : [] -> option vty : [] + + -------------------------------------------- :: CONS + ctx :- CONS :: ty1 : list ty1 : [] -> list ty1 : [] + + --------------------------------- :: DUP + ctx :- DUP :: ty1 : [] -> ty1 : ty1 : [] + + ---------------------------------------- :: SWAP + ctx :- SWAP :: ty1 : ty2 : [] -> ty2 : ty1 : [] + + ------------------------------------------------------ :: SLICE__string + ctx :- SLICE :: nat : nat : string : [] -> option string : [] + + ---------------------------------------------------- :: SLICE__bytes + ctx :- SLICE :: nat : nat : bytes : [] -> option bytes : [] + + --------------------------------------------------- :: UPDATE__set + ctx :- UPDATE :: to_type cty : bool : set cty : [] -> set cty : [] + + ---------------------------------------------------------- :: UPDATE__map + ctx :- UPDATE :: to_type kty : option vty : map kty vty : [] -> map kty vty : [] + + ------------------------------------------------------------------ :: UPDATE__big_map + ctx :- UPDATE :: to_type kty : option vty : big_map kty vty : [] -> big_map kty vty : [] + + +% ------------------------------------------------------------------------------------------------------- :: CREATE_ACCOUNT +% CREATE_ACCOUNT :: key_hash : option key_hash : bool : mutez : [] -> operation : contract unit : [] + + + ------------------------------------------------------------------- :: TRANSFER_TOKENS + ctx :- TRANSFER_TOKENS :: ty1 : mutez : contract ty1 : [] -> operation : [] + + + --------------------------------------------------------------- :: CHECK_SIGNATURE + ctx :- CHECK_SIGNATURE :: key : signature : bytes : [] -> bool : [] + + + ----------------------------------- :: ADD__nat_nat + ctx :- ADD :: nat : nat : [] -> nat : [] + + ----------------------------------- :: ADD__nat_int + ctx :- ADD :: nat : int : [] -> int : [] + + ----------------------------------- :: ADD__int_nat + ctx :- ADD :: int : nat : [] -> int : [] + + ----------------------------------- :: ADD__int_int + ctx :- ADD :: int : int : [] -> int : [] + + ----------------------------------------------- :: ADD__timestamp_int + ctx :- ADD :: timestamp : int : [] -> timestamp : [] + + ----------------------------------------------- :: ADD__int_timestamp + ctx :- ADD :: int : timestamp : [] -> timestamp : [] + + ----------------------------------------- :: ADD__mutez_mutez_mutez + ctx :- ADD :: mutez : mutez : [] -> mutez : [] + + ----------------------------------- :: SUB__nat_nat + ctx :- SUB :: nat : nat : [] -> int : [] + + ----------------------------------- :: SUB__nat_int + ctx :- SUB :: nat : int : [] -> int : [] + + ----------------------------------- :: SUB__int_nat + ctx :- SUB :: int : nat : [] -> int : [] + + ----------------------------------- :: SUB__int_int + ctx :- SUB :: int : int : [] -> int : [] + + ----------------------------------------------- :: SUB__timestamp_int + ctx :- SUB :: timestamp : int : [] -> timestamp : [] + + ----------------------------------------------- :: SUB__timestamp_timestamp + ctx :- SUB :: timestamp : timestamp : [] -> int : [] + + ----------------------------------------- :: SUB__mutez_mutez + ctx :- SUB :: mutez : mutez : [] -> mutez : [] + + ----------------------------------- :: MUL__nat_nat + ctx :- MUL :: nat : nat : [] -> nat : [] + + ----------------------------------- :: MUL__nat_int + ctx :- MUL :: nat : int : [] -> int : [] + + ----------------------------------- :: MUL__int_nat + ctx :- MUL :: int : nat : [] -> int : [] + + ----------------------------------- :: MUL__int_int + ctx :- MUL :: int : int : [] -> int : [] + + --------------------------------------- :: MUL__mutez_nat + ctx :- MUL :: mutez : nat : [] -> mutez : [] + + --------------------------------------- :: MUL__nat_mutez + ctx :- MUL :: nat : mutez : [] -> mutez : [] + + ------------------------------------------- :: EDIV__nat_nat + ctx :- EDIV :: nat : nat : [] -> option ( pair nat nat ) : [] + + ------------------------------------------- :: EDIV__nat_int + ctx :- EDIV :: nat : int : [] -> option ( pair int nat ) : [] + + ------------------------------------------- :: EDIV__int_nat + ctx :- EDIV :: int : nat : [] -> option ( pair int nat ) : [] + + ------------------------------------------- :: EDIV__int_int + ctx :- EDIV :: int : int : [] -> option ( pair int nat ) : [] + + ------------------------------------------------- :: EDIV__mutez_nat + ctx :- EDIV :: mutez : nat : [] -> option ( pair mutez mutez ) : [] + + ------------------------------------------------- :: EDIV__mutez_mutez + ctx :- EDIV :: mutez : mutez : [] -> option ( pair nat mutez ) : [] + + ------------------------------------------------- :: CHAIN_ID + ctx :- CHAIN_ID :: [] -> chain_id : [] + + defn + ctx :- code '::' A => B :: :: code_has_type :: 'instr_' by + + ctx :- function :: A -> B + ------------------------- :: function + ctx :- function :: A @ C => B @ C + + ---------------------- :: FAILWITH + ctx :- FAILWITH :: ty1 : A => B + + ------------- :: NOOP + ctx :- {} :: A => A + + ctx :- code1 :: A => B + ctx :- code2 :: B => C + ------------------------ :: SEQ + ctx :- code1; code2 :: A => C + + ctx :- code1 :: A => B + ctx :- code2 :: A => B + ------------------------------- :: IF + ctx :- IF code1 code2 :: bool : A => B + + ctx :- code :: A => bool : A + -------------------------- :: LOOP + ctx :- LOOP code :: bool : A => A + + ctx :- code :: ty1 : A => or ty1 ty2 : A + --------------------------------- :: LOOP_LEFT + ctx :- LOOP_LEFT code :: or ty1 ty2 : A => ty2 : A + + ctx :- code :: ty1 : A => A + ---------------------------- :: ITER__list + ctx :- ITER code :: list ty1 : A => A + + ctx :- code :: to_type cty : A => A + ---------------------------- :: ITER__set + ctx :- ITER code :: set cty : A => A + + ctx :- code :: (pair ( to_type kty ) vty) : A => A + --------------------------------- :: ITER__map + ctx :- ITER code :: map kty vty : A => A + + ctx :- code :: ty1 : A => ty2 : A + ------------------------------------- :: MAP__list + ctx :- MAP code :: list ty1 : A => list ty2 : A + + ctx :- code :: (pair ( to_type kty ) ty1) : A => ty2 : A + ------------------------------------------- :: MAP__map + ctx :- MAP code :: map kty ty1 : A => map kty ty2 : A + + ctx :- code1 :: A => B + ctx :- code2 :: ty1 : A => B + ---------------------------------------- :: IF_NONE + ctx :- IF_NONE code1 code2 :: option ty1 : A => B + + ctx :- code1 :: ty1 : A => B + ctx :- code2 :: ty2 : A => B + -------------------------------------- :: IF_LEFT + ctx :- IF_LEFT code1 code2 :: or ty1 ty2 : A => B + + ctx :- code1 :: ty1 : list ty1 : A => B + ctx :- code2 :: A => B + -------------------------------------- :: IF_CONS + ctx :- IF_CONS code1 code2 :: list ty1 : A => B + + %% ty1 : storage + %% ty2 : parameter + Some ty2 :- code :: pair ty2 ty1 : [] => pair ( list operation ) ty1 : [] + --------------------------------------------------------------- :: CREATE_CONTRACT + ctx :- CREATE_CONTRACT ty1 ty2 code :: option key_hash : mutez : ty1 : A => operation : address : A + + length A = nat_litteral + ------------------------------------------------- :: DIG + ctx :- DIG nat_litteral :: A @ ( ty1 : B ) => ty1 : ( A @ B ) + + length A = nat_litteral + ------------------------------------------------- :: DUG + ctx :- DUG nat_litteral :: ty1 : ( A @ B ) => A @ ( ty1 : B ) + + length A = nat_litteral + ------------------------------------------------- :: DROP + ctx :- DROP nat_litteral :: A @ B => B + + + length A = nat_litteral + ctx :- code :: B => C + --------------------------- :: DIP + ctx :- DIP nat_litteral code :: A @ B => A @ C + +defns +BigStep :: '' ::= + + +%% A big-step goes from an instruction (which is possible a sequence +%% of instructions), an initial stack to a final stack. + +% Local big-step rules +defn +i / stackerr => stackerr' :: :: BigStep :: 'bs_' +{{ tex [[i]] / [[stackerr]] \Rightarrow [[stackerr']] }} +by + + +%% +%% Now follows the rules. As far as possible, I follow the look of the +%% rules in the Michelson documentation. However, premises are here placed +%% above the line "------- :: [rule_name]" and the sugar +%% +%% i / S => i' / S' +%% +%% is desugered to +%% +%% i' / S => S' +%% -------- :: +%% i / S => S' +%% +%% I've left the typing rules, not implemented, in comment, and some bits of the original documentation. +%% My comments are prefixed AJ:. +%% + +------ :: FAILWITH +FAILWITH / d : stack => [FAILED] + +------ :: failed +i / [FAILED] => [FAILED] + +i1 / S => SE'' +i2 / SE'' => SE' +------ :: SEQ +i1; i2 / S => SE' + +------ :: NOOP +{} / S => S + +i1 / S => S' +------ :: IF__tt +IF i1 i2 / True : S => S' + +i2 / S => S' +------ :: IF__ff +IF i1 i2 / False : S => S' + +i1; LOOP i1 / S => S' +------ :: LOOP__tt +LOOP i1 / True : S => S' + +------ :: LOOP__ff +LOOP i1 / False : S => S + +i1 ; LOOP_LEFT i1 / d : S => S' +------ :: LOOP_LEFT__tt +LOOP_LEFT i1 / Left d : S => S' + +------ :: LOOP_LEFT__ff +LOOP_LEFT i1 / Right d : S => d : S' + +i1 / S => S' +------ :: DIP +DIP nat_litteral i1 / d : S => d : S' + +i / d2 : [] => d3 : [] +------ :: EXEC +EXEC / { i : ty1 -> ty2 } : d2 : S => d3 : S + +% 'a : lambda (pair 'a 'b) 'c : 'C -> lambda 'b 'c : 'C + +%% TODO: from whence ty1 ?? +----------------------------------------- :: APPLY +APPLY / d : { i : ( pair ty1 ty2 ) -> ty3 } : S => { PUSH ty1 d ; PAIR ; i : ty2 -> ty3 } : S + +%% +%% Stack operations +%% +% DROP: Drop the top element of the stack. + +% :: _ : 'A -> 'A + + +% TODO: fix to handle the argument n +----- :: DROP +DROP nat_litteral / d : S => S + +% DUP: Duplicate the top of the stack. + +% :: 'ty1 : 'A -> 'ty1 : 'ty1 : 'A + +----- :: DUP +DUP / d : S => d : d : S + +% SWAP: Exchange the top two elements of the stack. + +% :: 'ty1 : 'ty2 : 'A -> 'ty2 : 'ty1 : 'A + +----- :: SWAP +SWAP / d1 : d2 : S => d2 : d1 : S + +% PUSH 'ty1 x: Push a constant value of a given type onto the stack. + +% :: 'A -> 'ty1 : 'A +% iff x :: 'ty1 + +----- :: PUSH +PUSH ty d / S => d : S + +% UNIT: Push a unit value onto the stack. + +% :: 'A -> unit : 'A + +----- :: UNIT +UNIT / S => Unit : S + +% LAMBDA 'ty1 'ty2 code: Push a lambda with given parameter and return types onto the stack. + +% :: 'A -> (lambda 'ty1 'ty2) : 'A + +----- :: LAMBDA +LAMBDA ty ty' i / S => { i : ty -> ty' } : S + + +%% +%% Generic comparison +%% + +% EQ: Checks that the top of the stack EQuals zero. + +% :: int : 'S -> bool : 'S + +------------------------------------- :: EQ__tt +EQ / :z_IntZero: 0 : S => True : S + +z <> :z_IntZero: 0 +-------------------------- :: EQ__ff +EQ / z : S => False : S + +% NEQ: Checks that the top of the stack does Not EQual zero. + +% :: int : 'S -> bool : 'S + +-------------------------------------- :: NEQ__ff +NEQ / :z_IntZero: 0 : S => False : S + +z <> :z_IntZero: 0 +------------------------- :: NEQ__tt +NEQ / z : S => True : S + +% LT: Checks that the top of the stack is Less Than zero. + +% :: int : 'S -> bool : 'S + +z < :z_IntZero: 0 +----------------- :: LT__tt +LT / z : S => True : S + +z >= :z_IntZero: 0 +----- :: LT__ff +LT / z : S => False : S + +% GT: Checks that the top of the stack is Greater Than zero. + +% :: int : 'S -> bool : 'S + + +z > :z_IntZero: 0 +----------------- :: GT__tt +GT / z : S => True : S + +z <= :z_IntZero: 0 +------------------ :: GT__ff +GT / z : S => False : S + +% LE: Checks that the top of the stack is Less Than of Equal to zero. + +% :: int : 'S -> bool : 'S + +z <= :z_IntZero: 0 +------------------ :: LE__tt +LE / z : S => True : S + +z > :z_IntZero: 0 +----------------- :: LE__ff +LE / z : S => False : S + +% GE: Checks that the top of the stack is Greater Than of Equal to zero. + +% :: int : 'S -> bool : 'S + + +z >= :z_IntZero: 0 +------------------ :: GE__tt +GE / z : S => True : S + +z < :z_IntZero: 0 +----------------- :: GE__ff +GE / z : S => False : S + + +% V - Operations +% Operations on booleans + +% OR + +% :: bool : bool : 'S -> bool : 'S + +----- :: OR__1 +OR / True : x : S => True : S + +----- :: OR__2 +OR / x : True : S => True : S + +----- :: OR__3 +OR / False : False : S => False : S + +% AND + +% :: bool : bool : 'S -> bool : 'S + + +----- :: AND__1 +AND / True : True : S => True : S + +----- :: AND__2 +AND / False : x : S => False : S + +----- :: AND__3 +AND / x : False : S => False : S + +% XOR + +% :: bool : bool : 'S -> bool : 'S + +----- :: XOR__1 +XOR / True : True : S => False : S + +----- :: XOR__2 +XOR / False : True : S => True : S + +----- :: XOR__3 +XOR / True : False : S => True : S + +----- :: XOR__4 +XOR / False : False : S => False : S + +% NOT + +% :: bool : 'S -> bool : 'S + +----- :: NOT__1 +NOT / True : S => False : S + +----- :: NOT__2 +NOT / False : S => True : S + +% Operations on integers and natural numbers + +% Integers and naturals are arbitrary-precision, meaning the only size limit is fuel. + +% NEG + +% :: int : 'S -> int : 'S +% :: nat : 'S -> int : 'S + +----- :: NEG +NEG / z : S => - z : S + +% ABS + +% :: int : 'S -> nat : 'S + +----- :: ABS +ABS / z : S => abs z : S + +% ADD + +% :: int : int : 'S -> int : 'S +% :: int : nat : 'S -> int : 'S +% :: nat : int : 'S -> int : 'S +% :: nat : nat : 'S -> nat : 'S + +----- :: ADD +ADD / z1 : z2 : S => ( z1 + z2 ) : S + +% SUB + +% :: int : int : 'S -> int : 'S +% :: int : nat : 'S -> int : 'S +% :: nat : int : 'S -> int : 'S +% :: nat : nat : 'S -> int : 'S + +----- :: SUB +SUB / z1 : z2 : S => ( z1 - z2 ) : S + +% MUL + +% :: int : int : 'S -> int : 'S +% :: int : nat : 'S -> int : 'S +% :: nat : int : 'S -> int : 'S +% :: nat : nat : 'S -> nat : 'S + +----- :: MUL +MUL / z1 : z2 : S => ( z1 * z2 ) : S + +% EDIV Perform Euclidian division + +% :: int : int : 'S -> option ( pair int nat ) : 'S +% :: int : nat : 'S -> option ( pair int nat ) : 'S +% :: nat : int : 'S -> option ( pair int nat ) : 'S +% :: nat : nat : 'S -> option (pair nat nat) : 'S + +----- :: EDIV__0 +EDIV / z1 : 0 : S => None : S + +z2 <> 0 +----- :: EDIV +EDIV / z1 : z2 : S => Some ( Pair ( z1 / z2 ) ( z1 % z2 )) : S + +% Bitwise logical operators are also available on unsigned integers. + +% OR + +% :: nat : nat : 'S -> nat : 'S + +----- :: OR__bit +OR / z1 : z2 : S => ( z1 | z2 ) : S + +% AND (also available when the top operand is signed) + +% :: nat : nat : 'S -> nat : 'S +% :: int : nat : 'S -> nat : 'S + +% ----- :: AND__bit_nat +% AND / n1 : n2 : S => ( n1 & n2 ) : S + +----- :: AND__bit_int_nat +AND / z1 : z2 : S => ( z1 & z2 ) : S + +% XOR + +% :: nat : nat : 'S -> nat : 'S + +----- :: XOR__bit +XOR / z1 : z2 : S => ( z1 ^ z2 ) : S + +% Michelson Documentation: NOT The return type of NOT is an int and not a nat. This is because the sign is also negated. The resulting integer is computed using two’s complement. For instance, the boolean negation of 0 is -1. To get a natural back, a possibility is to use AND with an unsigned mask afterwards. + +% :: nat : 'S -> int : 'S +% :: int : 'S -> int : 'S + +----- :: NOT__bit +NOT / z : S => ~ z : S + +% LSL + +% :: nat : nat : 'S -> nat : 'S + +z2 <= 256 +----- :: LSL +LSL / z1 : z2 : S => ( z1 << z2 ) : S + +z2 > 256 +----- :: LSL__fail +LSL / z1 : z2 : S => [FAILED] + +% LSR + +% :: Nat : nat : 'S -> nat : 'S + +----- :: LSR +LSR / z1 : z2 : S => ( z1 >> z2 ) : S + +% COMPARE: Integer/natural comparison + +% :: int : int : 'S -> int : 'S +% :: nat : nat : 'S -> int : 'S + +z1 < z2 +----- :: COMPARE__num_lt +COMPARE / z1 : z2 : S => - :z_IntOne: 1 : S + +z1 = z2 +----- :: COMPARE__num_eq +COMPARE / z1 : z2 : S => :z_IntZero: 0 : S + +z1 > z2 +----- :: COMPARE__num_gt +COMPARE / z1 : z2 : S => :z_IntOne: 1 : S + +% Operations on strings + +% Michelson Documentation: Strings are mostly used for naming things without having to rely on external ID databases. They are restricted to the printable subset of 7-bit ASCII, plus some escaped characters (see section on constants). So what can be done is basically use string constants as is, concatenate or splice them, and use them as keys. + +% CONCAT: String concatenation. + +% :: string : string : 'S -> string : 'S + +%% TODO: add rules for bytes + +----- :: CONCAT__string +CONCAT / s : t : S => ( s ^ t ) : S + +% :: string list : 'S -> string : 'S + +----- :: CONCAT__string_list_nil +CONCAT / :setlist_Nil: {} : S => "" : S + +CONCAT / tl : S => t : S +----- :: CONCAT__string_list_cons +CONCAT / { s ; < tl > } : S => ( s ^ t ) : S + +% :: bytes list : 'S -> bytes : 'S + +% TODO: add semantics for the concatenation of byte sequences, +% requires adding a literal for bytes sequences + +% ----- :: CONCAT_bytes_list_nil +% CONCAT / :setlist_Nil: {} : S => "" : S + +% CONCAT / tl : S => t : S +% ----- :: CONCAT_bytes_list_cons +% CONCAT / { s ; < tl > } : S => ( s ^ t ) : S + + +% SIZE: number of characters in a string. + +% :: string : 'S -> nat : 'S + +----- :: SIZE__string +SIZE / s : S => ( length s ) : S + +% SLICE: String access. + +% :: nat : nat : string : ‘S -> option string : ‘S + + + + +% n: length +% n': offset +z1 + z2 < length s +----- :: SLICE__some +SLICE / z1 : z2 : s : S => Some ( slice s z1 z2 ) : S + +% where ss is the substring of s at the given offset and of the given length + +% iff offset and (offset + length) are in bounds + +% n: length +% n': offset +z1 + z2 >= length s +----- :: SLICE +SLICE / z1 : z2 : s : S => None : S + +% iff offset or (offset + length) are out of bounds + +% COMPARE: Lexicographic comparison. + +% :: string : string : 'S -> int : 'S + +s < t +----- :: COMPARE__string_lt +COMPARE / s : t : S => - :z_IntOne: 1 : S + +s = t +----- :: COMPARE__string_eq +COMPARE / s : t : S => :z_IntZero: 0 : S + +s > t +----- :: COMPARE__string_gt +COMPARE / s : t : S => :z_IntOne: 1 : S + +% Operations on pairs + +% PAIR: Build a pair from the stack’s top two elements. + +% :: 'ty1 : 'ty2 : 'S -> pair 'ty1 'ty2 : 'S + +----- :: PAIR +PAIR / d : d' : S => ( Pair d d' ) : S + +% CAR: Access the left part of a pair. + +% :: pair 'ty1 _ : 'S -> 'ty1 : 'S + +----- :: CAR +CAR / ( Pair d d' ) : S => d : S + +% CDR: Access the right part of a pair. + +% :: pair _ 'ty2 : 'S -> 'ty2 : 'S + +----- :: CDR +CDR / ( Pair d d' ) : S => d' : S + +% Operations on sets + +% EMPTY_SET 'elt: Build a new, empty set for elements of a given type. + +% The 'elt type must be comparable (the COMPARE primitive must be defined over it). + +% :: 'S -> set 'elt : 'S + +----- :: EMPTY_SET +EMPTY_SET cty / S => :setlist_Nil: {} : S + +% MEM: Check for the presence of an element in a set. + +% :: 'elt : set 'elt : 'S -> bool : 'S + +----- :: MEM__set_empty +MEM / x : :setlist_Nil: {} : S => False : S + +COMPARE / x : y : [] => :z_IntOne: 1 : [] +MEM / x : tl : S => b : S +----- :: MEM__set_later +MEM / x : { y ; } : S => b : S + +COMPARE / x : y : [] => :z_IntZero: 0 : [] +----- :: MEM__set_found +MEM / x : { y ; } : S => True : S + +COMPARE / x : y : [] => - :z_IntOne: 1 : [] +----- :: MEM__set_nexists +MEM / x : { y ; } : S => False : S + +% UPDATE: Inserts or removes an element in a set, replacing a previous value. + +% :: 'elt : bool : set 'elt : 'S -> set 'elt : 'S + +----- :: UPDATE__set_false +UPDATE / x : False : :setlist_Nil: {} : S => :setlist_Nil: {} : S + +----- :: UPDATE__set_add_nexists +UPDATE / x : True : :setlist_Nil: {} : S => { x } : S + +COMPARE / x : d : [] => :z_IntOne: 1 : [] +UPDATE / x : b : tl : S => tl' : S +----- :: UPDATE__set_cont +UPDATE / x : b : { y ; } : S => { y ; } : S + +COMPARE / x : y : [] => :z_IntZero: 0 : [] +----- :: UPDATE__set_remove +UPDATE / x : False : { y ; < tl > } : S => tl : S + +COMPARE / x : y : [] => :z_IntZero: 0 : [] +----- :: UPDATE__set_exists +UPDATE / x : True : { y ; < tl > } : S => { y ; < tl > } : S + +COMPARE / x : y : [] => - :z_IntOne: 1 : [] +----- :: UPDATE__set_remove_nexists +UPDATE / x : False : { y ; < tl > } : S => { y ; < tl > } : S + +COMPARE / x : y : [] => - :z_IntOne: 1 : [] +----- :: UPDATE__set_add +%% AJ: not sure how to get around the ugliness of the conclusion here +UPDATE / x : True : { y ; < tl > } : S => { x ; { y ; < tl > } } : S + +% ITER body: Apply the body expression to each element of a set. The body sequence has access to the stack. + +% :: (set 'elt) : 'A -> 'A +% iff body :: [ 'elt : 'A -> 'A ] + +----- :: ITER__set_nil +ITER body / :setlist_Nil: {} : S => S + +body ; ITER body / x : < tl > : S => S' +----- :: ITER__set_cons +ITER body / { x ; < tl > } : S => S' + +% SIZE: Get the cardinality of the set. + +% :: set 'elt : 'S -> nat : 'S + +----- :: SIZE__set_nil +SIZE / :setlist_Nil: {} : S => 0 : S + +SIZE / tl : S => z : S +----- :: SIZE__set_cons +SIZE / { d ; < tl > } : S => 1 + z : S + +% Operations on maps + +% EMPTY_MAP 'key 'val: Build a new, empty map from keys of a given type to values of another given type. + +% The 'key type must be comparable (the COMPARE primitive must be defined over it). + +% :: 'S -> map 'key 'val : 'S + +----- :: EMPTY_MAP +EMPTY_MAP cty ty / S => :setlist_Nil: {} : S + +----- :: EMPTY_BIG_MAP +EMPTY_BIG_MAP cty ty / S => :setlist_Nil: {} : S + +% GET: Access an element in a map, returns an optional value to be checked with IF_SOME. + +% :: 'key : map 'key 'val : 'S -> option 'val : 'S + +----- :: GET__empty +GET / x : :setlist_Nil: {} : S => None : S + +COMPARE / x : k : [] => :z_IntOne: 1 : [] +GET / x : m : S => opt_y : S +----- :: GET__later +GET / x : { Elt k v ; < m > } : S => opt_y : S + +COMPARE / x : k : [] => :z_IntZero: 0 : [] +----- :: GET__now +GET / x : { Elt k v ; < m > } : S => Some v : S + +COMPARE / x : k : [] => - :z_IntOne: 1 : [] +----- :: GET__nexists +GET / x : { Elt k v ; < m > } : S => None : S + +% MEM: Check for the presence of a binding for a key in a map. + +% :: 'key : map 'key 'val : 'S -> bool : 'S + +----- :: MEM__map_empty +MEM / x : :setlist_Nil: {} : S => False : S + +COMPARE / x : k : [] => :z_IntOne: 1 : [] +MEM / x : m : S => b : S +----- :: MEM__map_later +MEM / x : { Elt k v ; < m > } : S => b : S + +COMPARE / x : k : [] => :z_IntZero: 0 : [] +----- :: MEM__map_now +MEM / x : { Elt k v ; < m > } : S => True : S + +COMPARE / x : k : [] => - :z_IntOne: 1 : [] +----- :: MEM__map_nexists +MEM / x : { Elt k v ; < m > } : S => False : S + +% UPDATE: Assign or remove an element in a map. + +% :: 'key : option 'val : map 'key 'val : 'S -> map 'key 'val : 'S + +----- :: UPDATE__map_false +UPDATE / x : None : :setlist_Nil: {} : S => :setlist_Nil: {} : S + +----- :: UPDATE__map_add_nexists +UPDATE / x : Some y : :setlist_Nil: {} : S => { Elt x y } : S + +COMPARE / x : k : [] => :z_IntOne: 1 : [] +UPDATE / x : opt_y : m : S => m' : S +----- :: UPDATE__map_cont +UPDATE / x : opt_y : { Elt k v ; < m > } : S => { Elt k v ; < m' > } : S + +COMPARE / x : k : [] => :z_IntZero: 0 : [] +----- :: UPDATE__map_remove +UPDATE / x : None : { Elt k v ; < m > } : S => < m > : S + +COMPARE / x : k : [] => :z_IntZero: 0 : [] +----- :: UPDATE__map_exists +UPDATE / x : Some y : { Elt k v ; < m > } : S => { Elt k y ; < m > } : S + +COMPARE / x : k : [] => - :z_IntOne: 1 : [] +----- :: UPDATE__map_remove_nexists +UPDATE / x : None : { Elt k v ; < m > } : S => { Elt k v ; < m > } : S + +COMPARE / x : k : [] => - :z_IntOne: 1 : [] +----- :: UPDATE__map_add +UPDATE / x : Some y : { Elt k v ; < m > } : S => { Elt x y ; { Elt k v ; < m > } } : S + +% MAP body: Apply the body expression to each element of a map. The body sequence has access to the stack. + +% :: (map 'key 'val) : 'A -> (map 'key 'ty2) : 'A +% iff body :: [ (pair 'key 'val) : 'A -> 'ty2 : 'A ] + +----- :: MAP__map_nil +MAP body / :setlist_Nil: {} : S => :setlist_Nil: {} : S + +%% AJ: I'm unsure how to read the conclusion of the original version +%% of this rule. what is the meaning of applying body to (Pair k v) ? +%% This is how I interpret it. +body / k : v : S => v' : S +MAP body / m : S => m' : S +----- :: MAP__map_cons +MAP body / { Elt k v ; < m > } : S => { Elt k v' ; < m' > } : S + +% ITER body: Apply the body expression to each element of a map. The body sequence has access to the stack. + +% :: (map 'elt 'val) : 'A -> 'A +% iff body :: [ (pair 'elt 'val) : 'A -> 'A ] + +----- :: ITER__map_nil +ITER body / :setlist_Nil: {} : S => S + +body ; ITER body / (Pair k v) : m : S => S' +----- :: ITER__map_cons +ITER body / { Elt k v ; < m > } : S => S' + +% SIZE: Get the cardinality of the map. + +% :: map 'key 'val : 'S -> nat : 'S + +----- :: SIZE__map_nil +SIZE / :setlist_Nil: {} : S => 0 : S + +SIZE / m : S => z : S +----- :: SIZE__map_cons +SIZE / { Elt d d' ; < m > } : S => 1 + z : S + +% Operations on big_maps + +% AJ: I ignore these. + +% The behavior of these operations is the same as if they were normal maps, except that under the hood, the elements are loaded and deserialized on demand. + +% GET: Access an element in a big_map, returns an optional value to be checked with IF_SOME. + +% :: 'key : big_map 'key 'val : 'S -> option 'val : 'S + +% MEM: Check for the presence of an element in a big_map. + +% :: 'key : big_map 'key 'val : 'S -> bool : 'S + +% UPDATE: Assign or remove an element in a big_map. + +% :: 'key : option 'val : big_map 'key 'val : 'S -> big_map 'key 'val : 'S + +%% +%% Operations on optional values +%% + +% SOME: Pack a present optional value. + +% :: 'ty1 : 'S -> option 'ty1 : 'S + +----- :: SOME +SOME / v : S => (Some v) : S + +% NONE 'ty1: The absent optional value. + +% :: 'S -> option 'ty1 : 'S + +----- :: NONE +NONE ty / v : S => None : S + +% IF_NONE body1 body2: Inspect an optional value. + +% :: option 'ty1 : 'S -> 'ty2 : 'S +% iff body1 :: [ 'S -> 'ty2 : 'S] +% body2 :: [ 'ty1 : 'S -> 'ty2 : 'S] + +body1 / S => S' +----- :: IF_NONE__none +IF_NONE body1 body2 / None : S => S' + +body2 / d : S => S' +----- :: IF_NONE__some +IF_NONE body1 body2 / (Some d) : S => S' + +% Operations on unions + +% LEFT 'ty2: Pack a value in a union (left case). + +% :: 'ty1 : 'S -> or 'ty1 'ty2 : 'S + +----- :: LEFT +LEFT ty / v : S => (Left v) : S + +% RIGHT 'ty1: Pack a value in a union (right case). + +% :: 'ty2 : 'S -> or 'ty1 'ty2 : 'S + +----- :: RIGHT +RIGHT ty / v : S => (Right v) : S + +% IF_LEFT body1 body2: Inspect a value of a variant type. + +% :: or 'ty1 'ty2 : 'S -> 'cty : 'S +% iff body1 :: [ 'ty1 : 'S -> 'cty : 'S] +% body2 :: [ 'ty2 : 'S -> 'cty : 'S] + +body1 / d : S => S' +----- :: IF_LEFT__left +IF_LEFT body1 body2 / (Left d) : S => S' + +body2 / d : S => S' +----- :: IF_LEFT__right +IF_LEFT body1 body2 / (Right d) : S => S' + +% Operations on lists + +% CONS: Prepend an element to a list. + +% :: 'ty1 : list 'ty1 : 'S -> list 'ty1 : 'S + +----- :: CONS +CONS / d : tl : S => { d ; < tl > } : S + +% NIL 'ty1: The empty list. + +% :: 'S -> list 'ty1 : 'S + +----- :: NIL +NIL ty / S => :setlist_Nil: {} : S + +% IF_CONS body1 body2: Inspect an optional value. + +% :: list 'ty1 : 'S -> 'ty2 : 'S +% iff body1 :: [ 'ty1 : list 'ty1 : 'S -> 'ty2 : 'S] +% body2 :: [ 'S -> 'ty2 : 'S] + +body2 / S => S' +----- :: IF_CONS__nil +IF_CONS body1 body2 / :setlist_Nil: {} : S => S' + +body1 / d : tl : S => S' +----- :: IF_CONS__cons +IF_CONS body1 body2 / { d ; < tl > } : S => S' + +% MAP body: Apply the body expression to each element of the list. The body sequence has access to the stack. + +% :: (list 'elt) : 'A -> (list 'ty2) : 'A +% iff body :: [ 'elt : 'A -> 'ty2 : 'A ] + +body / d : S => d' : S +MAP body / tl : S => tl' : S +----- :: MAP__list_cons +MAP body / { d ; < tl > } : S => { d' ; < tl' > } : S + +----- :: MAP__list_nil +MAP body / :setlist_Nil: {} : S => :setlist_Nil: {} : S + +% SIZE: Get the number of elements in the list. + +% :: list 'elt : 'S -> nat : 'S + +----- :: SIZE__list_nil +SIZE / :setlist_Nil: {} : S => 0 : S + +SIZE / tl : S => z : S +----- :: SIZE__list_cons +SIZE / { d ; } : S => 1 + z : S + +% ITER body: Apply the body expression to each element of a list. The body sequence has access to the stack. + +% :: (list 'elt) : 'A -> 'A +% iff body :: [ 'elt : 'A -> 'A ] + +body ; ITER body / d : tl : S => S' +----- :: ITER__list_cons +ITER body / { d ; } : S => S' + +----- :: ITER__list_nil +ITER body / :setlist_Nil: {} : S => S + + +length S1 = nat_litteral +------------------------------------------------- :: DIG +DIG nat_litteral / S1 ++ ( d : S2 ) => d : ( S1 ++ S2 ) + +length S1 = nat_litteral +------------------------------------------------- :: DUG +DUG nat_litteral / d : ( S1 ++ S2 ) => S1 ++ ( d : S2 ) + + +% cryptography + +------------------------------------- :: HASH_KEY +HASH_KEY / s : S => hash_key s : S + +----------------------------------------- :: HASH +hash_function / byt : S => hash hash_function byt : S + + +------------------------------------- :: HASH_KEY +CHECK_SIGNATURE / s : sig : byt : S => check_signature s sig byt : S + + +% reflection: + + +----------------------------------------- :: BALANCE +BALANCE / S => balance : S + + +----------------------------------------- :: AMOUNT +AMOUNT / S => amount : S + +----------------------------------------- :: NOW +NOW / S => now : S + +----------------------------------------- :: SOURCE +SOURCE / S => source : S + +----------------------------------------- :: SENDER +SENDER / S => sender : S + +----------------------------------------- :: SELF +SELF / S => self : S + +----------------------------------------- :: ADDRESS +ADDRESS / s : S => address s : S + +----------------------------------------- :: CHAIN_ID +CHAIN_ID / S => chain_id : S + +----------------------------------------- :: CONTRACT +CONTRACT ty / s : S => contract ty s : S + +% other reflection: + +----------------------------------------- :: IMPLICIT_ACCOUNT +IMPLICIT_ACCOUNT / s : S => implicit_account s : S + +% operations: + +----------------------------------------- :: SET_DELEGATE +SET_DELEGATE / d : S => set_delegate d : S + +% Warning: The instruction TRANSFER_TOKENS has no semantics rules + +----------------------------------------- :: TRANSFER_TOKENS +TRANSFER_TOKENS / x : z : s : S => transfer_tokens x z s : S + +% Warning: The instruction CREATE_CONTRACT has no semantics rules + +create_contract ty1 ty2 code d z x = ( s1 , s2 ) +----------------------------------------- :: CREATE_CONTRACT +CREATE_CONTRACT ty1 ty2 code / d : z : x : S => s1 : s2 : S + +% basic: + +----------------------------------------- :: INT +INT / z : S => z : S + +----------------------------------------- :: ISNAT +ISNAT / z : S => isnat z : S + +% other: + +----------------------------------------- :: PACK +PACK / d : S => pack d : S + +----------------------------------------- :: UNPACK +UNPACK ty / byt : S => unpack ty s : S + +embed {{coq +End Semantics. +}} diff --git a/docs/doc_gen/michelson_reference/pp-latex-rules.py b/docs/doc_gen/michelson_reference/pp-latex-rules.py new file mode 100644 index 0000000000000000000000000000000000000000..8bf55b3c94552209c57e00ae2f90bc6332e9cd62 --- /dev/null +++ b/docs/doc_gen/michelson_reference/pp-latex-rules.py @@ -0,0 +1,18 @@ +from language_def import load_language_def + +(language_def, _, _) = load_language_def() + +for instr in language_def: + rules = instr['ty'] + rules.extend(instr['semantics']) + + for rule in rules: + f = open("rules/" + rule['name'] + ".tex", "w+") + f.write( +"""\\documentclass[preview]{standalone} +\\input{../michelson_embed} +\\begin{document} +$\\ottdrule""" + rule['name'].replace("_", "XX") + """{}$ +\\end{document} + """) + f.close() diff --git a/docs/doc_gen/michelson_reference/pygments-michelson.sh b/docs/doc_gen/michelson_reference/pygments-michelson.sh new file mode 100755 index 0000000000000000000000000000000000000000..b793202abc598b3261bbb828874a0fd992045b6b --- /dev/null +++ b/docs/doc_gen/michelson_reference/pygments-michelson.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +if [[ -z $1 ]]; then + echo 'Usage: python {__file__} ' + exit 1 +fi + + +pygmentize -v -l MichelsonLexer.py:MichelsonLexer -x $1 diff --git a/docs/doc_gen/michelson_reference/requirements.txt b/docs/doc_gen/michelson_reference/requirements.txt new file mode 100644 index 0000000000000000000000000000000000000000..79ac9a55adb4e8a6eb3c13b0a0e7b613be81f324 --- /dev/null +++ b/docs/doc_gen/michelson_reference/requirements.txt @@ -0,0 +1,5 @@ +jinja2 +docutils +pygments +jsonschema +pygments-michelson==1.0.1 diff --git a/docs/doc_gen/michelson_reference/rules/.gitignore b/docs/doc_gen/michelson_reference/rules/.gitignore new file mode 100644 index 0000000000000000000000000000000000000000..fdb94be982a272b09f823af9d162131f65504a34 --- /dev/null +++ b/docs/doc_gen/michelson_reference/rules/.gitignore @@ -0,0 +1,6 @@ +auto/ +*.tex +*.log +*.aux +*.pdf +*.png diff --git a/docs/doc_gen/michelson_reference/rules/convert_all.sh b/docs/doc_gen/michelson_reference/rules/convert_all.sh new file mode 100755 index 0000000000000000000000000000000000000000..4b3bb95f4e0da14c7bbfa8e004330f4ab8f7326b --- /dev/null +++ b/docs/doc_gen/michelson_reference/rules/convert_all.sh @@ -0,0 +1,11 @@ +#!/bin/bash + +for i in $(ls *.tex); do + echo $i + i=${i/.tex/} + pdflatex -interaction=batchmode $i + pdftoppm -r 300 -png $i.pdf > $i.png +done + +mkdir -p ../docs/images/rules/ +cp -v *.png ../docs/images/rules/ diff --git a/docs/doc_gen/michelson_reference/static/michelson.js b/docs/doc_gen/michelson_reference/static/michelson.js new file mode 100644 index 0000000000000000000000000000000000000000..607bb4792cd5adba5cdcd65d5bb6ec2076e8b885 --- /dev/null +++ b/docs/doc_gen/michelson_reference/static/michelson.js @@ -0,0 +1,61 @@ +function addTypemap(pre, typemap) { + var cl = pre.clone(); + + $(pre).find('span').each(function () { + var tgt = $(this); + var code = pre.text(); + var idx = $(this).parent('pre').children().index(tgt); + + // find point corresponding to the beginning of this primitive + var ch = $(cl.children().get(idx)) + var origText = ch.text() + ch.text('<>') + var idxTxt = cl.text().indexOf("<>") + ch.text(origText) + + // find the most specific type in the typemap for this point, e.g. + // the type assigned to the location with smallest distance between + // start and end. + var min = false; + var title = false; + typemap.forEach(function (el) { + // console.log('el', el); + var len = el.location.location.stop.point - el.location.location.start.point; + if (el.location.location.start.point <= idxTxt && + idxTxt <= el.location.location.stop.point && + (min === false || len < min)) { + var before = el.before.length ? el.before.join(' : ') + ' : []' : '[]'; + var after = el.after.length ? el.after.join(' : ') + ' : []' : '[]'; + title = before + ' → ' + after; + min = len; + } + }); + if (title) { + tgt.attr('title', title) + } + }) +} + +$(function () { + $('.highlight > pre').hover(function (e) { + var pre = $(this) + var code = pre.text(); + if (!pre.is('.type-checked')) { + pre.addClass('type-checked'); + $.ajax({ + url: "https://tezos-lang-server.tzalpha.net/typecheck_code", + type: 'POST', + dataType: 'json', + contentType: 'application/json', + processData: false, + data: JSON.stringify({code: code}), + success: function (typemap) { + addTypemap(pre, typemap) + }, + error: function(){ + console.log('error', arguments); + } + }); + } + }); +}); diff --git a/docs/doc_gen/michelson_reference/static/ref.css b/docs/doc_gen/michelson_reference/static/ref.css new file mode 100644 index 0000000000000000000000000000000000000000..791147f5edeb1fbe4ee40b6bcc5560b9802c801c --- /dev/null +++ b/docs/doc_gen/michelson_reference/static/ref.css @@ -0,0 +1,100 @@ + +.check { background-color: #9e9; } +.cross { background-color: #e99; } + +#toc{ + display: none; +} + +@media (min-width: 550px) { /*Skeletons default grid-activation width*/ + #toc { + display: block; + margin-top: 5%; + width: 400px; + } +} + +#toc ul { list-style: none; margin-left: 1.5rem; } +#toc > ul { list-style: none; margin-left: 0; } + + +/* *** */ +html { + height: 100%; + font-family: sans-serif; +} +body { + height: 100%; + overflow: hidden; + margin: 0px; + display: flex; +} +.fl-column { + height: 100%; + display: flex; + flex-direction: column; +} +#left { + flex-shrink: 0; +} +#right { +} +.top-left { + flex-shrink: 0; + padding: 20px; +} +.top-right { + display: inline-flex; + flex-shrink: 0; + padding: 20px; +} +.bottom { + flex-grow: 1; + overflow-y: auto; + padding: 20px; +} +.top-right ul{ + display: inline-flex; + list-style: none; + margin: 0; +} +.top-right li{ + margin-right: 20px; +} + +.three-quarter.column { + width: 960px; +} + + +/** Try it examples */ + +.example { + position: relative; +} + +.example .try-it { + position: absolute; + top: 10px; + right: 10px; +} + +/** Tables */ +td.check, td.cross { + text-align: center; +} + + +.types-table th:last-child, +.types-table td:last-child { + padding: 12px 15px; +} + + +/** types */ + +dt { font-weight: bold; } + +.inline-list > li { + display: inline; +} diff --git a/docs/doc_gen/michelson_reference/static/ref.js b/docs/doc_gen/michelson_reference/static/ref.js new file mode 100644 index 0000000000000000000000000000000000000000..a766792037d4240f480a1023081eb582a0c9ce6f --- /dev/null +++ b/docs/doc_gen/michelson_reference/static/ref.js @@ -0,0 +1,22 @@ +jQuery(function ($) { + var toc = $('#toc'); + var els = toc.find('.type, .instr'); + toc.find('#toc-search').on("keyup", function() { + var value = $(this).val(); + var caseSensitiveMatch = (value !== value.toLowerCase()); + value = value.replace('--', '—'); + + if (value != '') { + els.each(function() { + var match = caseSensitiveMatch ? + ($(this).text().indexOf(value) > -1) : + ($(this).text().toLowerCase().indexOf(value.toLowerCase()) > -1); + $(this).toggle(match); + $(this).parents('details').attr('open', match ? 'open' : 'close'); + }); + } else { + els.toggle(true); + toc.find('details').removeAttr('open'); + } + }); +}); diff --git a/docs/doc_gen/michelson_reference/templates/body.html b/docs/doc_gen/michelson_reference/templates/body.html new file mode 100644 index 0000000000000000000000000000000000000000..409a71a77605082735fb13f350eb90200b5177fd --- /dev/null +++ b/docs/doc_gen/michelson_reference/templates/body.html @@ -0,0 +1,124 @@ +{% import 'macros.html' as macros %} + +

Introduction

+ +This is a reference to the Michelson language used for smart contract +programming for the Tezos blockchain. It contains a reference to the +types and instructions of the language. + +The examples used throughout the reference can be executed in the +browser using the Try Michelson +interpreter. Just click "try it!" in the upper-right corner of the +example to load it in the interpeter: + +{{ macros.show_example(try_michelson_url, "parameter unit;\nstorage unit;\ncode {CDR; NIL operation; PAIR};") }} + +In addition, the stack type of each location of the examples can be +exampes by hovering the mouse over that location. + +

Terminology

+ +
+
Instruction
+
Instructions refers to Michelson primitives such as ADD. + Not to be confused with operations.
+
Operation
+
The side effect of a contract execution is a new storage and a list of operations. + An operation is either a transfer, an account creation or a delegation.
+
Numerical type
+
Refers to any of the numerical types of Michelson: + int, + nat, + timestamp or + mutez. + Numerical values are values of one these types. +
Sequence type
+
Refers to any of the two sequence type of Michelson: string or bytes. +
+
Structural type
+
Refers to any of the structural types of Michelson: + list, + set, + map or + big_map. + Structural values are values of one these types. +
+
Argument
+
Michelson instructions may be indexed by arguments. + For instance, the + arguments of PUSH nat 3 is nat and 3. + The argument of DIP 2 is 2. + Not to be confused with operands and parameters. +
+
Operand
+
Refers to stack values consumed by instructions. + Not to be confused with arguments and parameters. +
+
Parameter
+
Parameter may refer to three things. + First, each contract has a parameter type and when called, takes a parameter value of this type. + Second, some michelson data types, such as list are parametric. + For instance, a list of integer list nat is an instance of the list type with + the type parameter instantiated to nat. + Finally, the input type of a lambda. + Not to be confused with arguments and operands. +
+
Return value
+
Refers either to the stack values produced by an instruction, or the return value of a lambda. +
+
+ +

Types

+ +See below for an explanation of type attributes. + +{{ macros.quick_ref_tbl_ty(lang_def.get_types(), lang_def.get_type_attributes()) }} + +Michelson data types (and by extension, the values of each type) can +be characterized by the following type attributes: + +
+
Comparable
+
Comparable values can be stored in sets, can be passed as argument to COMPARE, etc.
+
Passable
+
Passable types are those that can be taken as a parameter in contracts.
+
Storable
+
Storable types can be used as a storage in contracts.
+
Pushable
+
Literal values of pushable types can be given as parameter to the PUSH primitive.
+
Packable
+
Values of packable types can be given as serialized using the PACK primitive.
+
big_map value
+
These are types that be used in the domain of big_maps.
+
+ +The attributes of each type is given in the table above. All pushable +types are also packable and vice versa. Except for the domain +specific types operation, contract and big_map, all types are +passable, storable, pushable, packable and can be used as values in +big_maps. + + + + +

Instructions

+{{ macros.quick_ref_tbl(lang_def.get_instructions()) }} + +

Instructions by Category

+{% for cat, title in lang_def.get_categories().items() %} +

{{ title }}

+{{ macros.quick_ref_tbl(lang_def.get_instructions_by_category(cat)) }} +{% endfor %} + +

Type Reference

+ +{% for type in lang_def.get_types() %} +{% include 'type.html' %} +{% endfor %} + +

Instruction Reference

+ +{% for instr in lang_def.get_instructions() %} +{% include 'instruction.html' %} +{% endfor %} + diff --git a/docs/doc_gen/michelson_reference/templates/index.html b/docs/doc_gen/michelson_reference/templates/index.html new file mode 100644 index 0000000000000000000000000000000000000000..b7fd303446063e38d4ea8b33bba2886c534e7fcf --- /dev/null +++ b/docs/doc_gen/michelson_reference/templates/index.html @@ -0,0 +1,59 @@ + + + + + + + + Michelson Reference + + + + + + + + + + + + + + + + + + + + + + +
+ +
+ +
+ {% import 'macros.html' as macros %} + {% include 'toc.html' %} +
+
+
+ + + + diff --git a/docs/doc_gen/michelson_reference/templates/instruction.html b/docs/doc_gen/michelson_reference/templates/instruction.html new file mode 100644 index 0000000000000000000000000000000000000000..37d27e3807745b915efd8f0a6c86eb08ace21525 --- /dev/null +++ b/docs/doc_gen/michelson_reference/templates/instruction.html @@ -0,0 +1,45 @@ +

{{instr.op_args}}: {{instr.documentation_short|rst_inline}}

+ +
Description
+ +{% if instr['documentation'] %} + +{{ instr.documentation | rst }} + +{% endif %} + +
+ Semantics + + {% for r in instr.semantics %} + {{ macros.pp_rule(r) }} + {# #} + {% endfor %} +
+ +
+ Typing + + {% for r in instr.ty %} + {{ macros.pp_rule(r) }} + {# #} + {% endfor %} +
+ +{% for ex in instr.examples %} +
Example: {{ex.name|rst_inline if 'name' in ex else ''}}
+ +{{ex.description | rst}} + +{{ macros.show_example(try_michelson_url, ex.code) }} + +{% if not (ex['hide_final_storage']) %} +

+ If called with the initial + storage {{ex.initial_storage}} and the + parameter {{ex.input}} then the final storage + will be {{ex.final_storage}}. +

+{% endif %} + +{% endfor %} diff --git a/docs/doc_gen/michelson_reference/templates/macros.html b/docs/doc_gen/michelson_reference/templates/macros.html new file mode 100644 index 0000000000000000000000000000000000000000..b0d75ff72d6d4a37717e52003a1f47af05524672 --- /dev/null +++ b/docs/doc_gen/michelson_reference/templates/macros.html @@ -0,0 +1,112 @@ +{% macro pp_rule(rule) %} +{# #} +
+	{% for p in rule.premises %}{{ p }}
+	{% endfor %}------------------ {{ rule.name }}
+	{{ rule.conclusion }}
+
+{%- endmacro %} + +{% macro show_example(url, code) %} +
+
+ try it! +
+ {{code|pp_michelson}} +
+{%- endmacro %} + + +{% macro bool_to_check_cell(b) %} +{% if b == True %} +✔ +{% elif b %} +{{b}} +{% else %} +✘ +{% endif %} +{%- endmacro %} + +{% macro link_first_word(url, string) %}{{string.split(" ")[0]}} {{" ".join(string.split(" ")[1:])}}{%- endmacro %} + +{% macro url_instr(op) %}instr-{{op}}{%- endmacro %} +{% macro url_type(ty) %}type-{{ty}}{%- endmacro %} + +{% macro link_instr(op) %}{{op.op_args}}{%- endmacro %} +{% macro link_type(ty) %}{{ty.ty_args}}{%- endmacro %} + +{% macro quick_ref_tbl(instructions) %} + + + + + + + + + + {% for instr in instructions %} + + + + {% if instr.stack_effect %} + {# #} + + {% else %} + + {% endif %} + + {% endfor %} + +
InstructionDescriptionStack effect
{{ link_first_word("#" ~ url_instr(instr.op), instr.op_args) }}{{instr.documentation_short|rst_inline}} + + {% for se in instr.stack_effect %} + + {% endfor %} +
{{ se[0] }}—{{ se[1] }}
+ 		+ {% for se in instr.stack_effect %} + {{ se[0] }} — {{ se[1] }}
+ {% endfor %} +
+{%- endmacro %} + +{% macro quick_ref_tbl_ty(types, attrs) %} + + + + + + + {% for a in attrs %} + + {% endfor %} + + + + {% for type in types %} + + + + + {% for a in attrs %} + {{ bool_to_check_cell(type[a[0]]) }} + {% endfor %} + + {% endfor %} + +
TypeDescriptionExamples{{a[2]}}
{{ link_first_word("#" ~ url_type(type.ty), type.ty_args) }}{{type.documentation_short|rst_inline}} + {% if 'examples' in type %} + {# {{type.examples|pprint}} #} + {% for ex in type.examples %} + {# {{ ex | pprint }} #} + {% if ex[0]|string|length > 22 %}{{(ex[0]|string)[0:22]}}...{% else %} {{ ex[0] }} {% endif %} + {% if not loop.last %}, {% endif %} + {% endfor %} + {% else %} + — + {% endif %} +
+{%- endmacro %} + + diff --git a/docs/doc_gen/michelson_reference/templates/toc.html b/docs/doc_gen/michelson_reference/templates/toc.html new file mode 100644 index 0000000000000000000000000000000000000000..c470a2ab1bbb527434bbd3fc7d0114fac1ec6ff8 --- /dev/null +++ b/docs/doc_gen/michelson_reference/templates/toc.html @@ -0,0 +1,50 @@ + + + diff --git a/docs/doc_gen/michelson_reference/templates/type.html b/docs/doc_gen/michelson_reference/templates/type.html new file mode 100644 index 0000000000000000000000000000000000000000..abb1c3b58ff35b9356c4f4a15079433666e54172 --- /dev/null +++ b/docs/doc_gen/michelson_reference/templates/type.html @@ -0,0 +1,47 @@ +

{{type.ty_args}}: {{type.documentation_short|rst_inline}}

+ +
+ {% if 'documentation' in type %} +
Description
{{ type.documentation | rst }}
+ {% endif %} +
Example values
+
+ {% if type.examples|length %} + {% for ex in type.examples %} + {{ex[0]}}{% if not loop.last %}, {% endif %} + {% endfor %} + {% else %} + There are no literal values of this type. + {% endif %} +
+ {% if type.related_ops %} +
Related instructions
+
+
    + {% for op in type.related_ops %} +
  • {{op}}
    • + {% endfor %} +
+
+ {% endif %} +
Attributes
+
+ + + + {% for a in lang_def.get_type_attributes() %} + + {% endfor %} + + + + + {% for a in lang_def.get_type_attributes() %} + {{ macros.bool_to_check_cell(type[a[0]]) }} + {% endfor %} + + +
{{a[1]}}
+
+

+
diff --git a/docs/doc_gen/michelson_reference/test-lexer.sh b/docs/doc_gen/michelson_reference/test-lexer.sh new file mode 100755 index 0000000000000000000000000000000000000000..08f46b759bd270e1356b39f127586a696532de25 --- /dev/null +++ b/docs/doc_gen/michelson_reference/test-lexer.sh @@ -0,0 +1,17 @@ +#!/bin/bash + +TEZOS_ROOT=../../.. +CONTRACTS_DIR=${TEZOS_ROOT}/src/bin_client/test/contracts +TEST_CONTRACTS_DIR=test/test-contracts + +for i in `ls $CONTRACTS_DIR/*/*.tz $TEST_CONTRACTS_DIR/*/*.tz`; do + if x=$( pygmentize -l MichelsonLexer.py:MichelsonLexer -f raw -x $i | grep Error ); then + echo "Unlexed parser token in error in $i: $x" + exit 1 + else + echo "$i OK" + fi +done + + +echo "All contracts successfully lexed." diff --git a/docs/doc_gen/michelson_reference/test-schema.py b/docs/doc_gen/michelson_reference/test-schema.py new file mode 100644 index 0000000000000000000000000000000000000000..6e2fcd59de0482ae3918b3b2fa37f9a59f8fac93 --- /dev/null +++ b/docs/doc_gen/michelson_reference/test-schema.py @@ -0,0 +1,16 @@ +import yaml +import json +import sys +import re +import os.path +from jsonschema import validate + +language_meta_file = 'michelson-meta.yaml' +language_meta_schema_file = 'michelson-meta-schema.json' + +lang_meta = yaml.safe_load(open(language_meta_file, 'r')) +lang_meta_schema = json.load(open(language_meta_schema_file, 'r')) + +validate(lang_meta, schema=lang_meta_schema) + +print("michelson-meta.yaml is valid") diff --git a/docs/doc_gen/michelson_reference/test/test-contracts/comments/example_comment.tz b/docs/doc_gen/michelson_reference/test/test-contracts/comments/example_comment.tz new file mode 100644 index 0000000000000000000000000000000000000000..cdd87263263420981cb253451e8d24c9cf5e939e --- /dev/null +++ b/docs/doc_gen/michelson_reference/test/test-contracts/comments/example_comment.tz @@ -0,0 +1,26 @@ +parameter unit; +storage nat; +code + { + DROP; + + /* C style multiline comment + + + */ + PUSH nat 2; + PUSH nat 2; + ADD; + /* c style single line comment */ + + /** FOO BAR + * + */ + + NIL operation; + + /** nested /* comment + + */ */ + PAIR; + } diff --git a/docs/doc_gen/michelson_reference/validate-json-schema.py b/docs/doc_gen/michelson_reference/validate-json-schema.py new file mode 100644 index 0000000000000000000000000000000000000000..a66b179f568b70a5e6c52d6374966f2a79d0860a --- /dev/null +++ b/docs/doc_gen/michelson_reference/validate-json-schema.py @@ -0,0 +1,30 @@ +import yaml +import json +import sys +import os.path +from jsonschema import validate +import argparse + + +if __name__ == '__main__': + + parser = argparse.ArgumentParser(description='Validate json or yaml file against json schema.') + parser.add_argument('schema', metavar='schema.json', type=argparse.FileType('r'), help='the schema file') + parser.add_argument('data_files', metavar='data.[json|yaml]', type=argparse.FileType('r'), nargs='+', + help='the data file(s)') + args = parser.parse_args() + + with args.schema as schema_file: + schema = json.load(schema_file) + + for df in args.data_files: + with df as df: + ext = os.path.splitext(df.name)[1] + if ext == '.yaml': + data = yaml.safe_load(df) + elif ext == '.json': + data = json.load(df) + else: + raise Exception(f'Unrecognized data-file extension {ext}') + validate(data, schema=schema) + print(f'{df.name} is validates against {schema_file.name}') diff --git a/docs/index.rst b/docs/index.rst index 51977bf2a53247ad80c3dce67918e1415b4d2486..e04c28fc508879cc4a62af023f59589d2b5b4440 100644 --- a/docs/index.rst +++ b/docs/index.rst @@ -123,6 +123,7 @@ in the :ref:`introduction `. whitedoc/p2p whitedoc/validation whitedoc/michelson + whitedoc/michelson_reference whitedoc/proof_of_stake whitedoc/voting diff --git a/docs/whitedoc/michelson.rst b/docs/whitedoc/michelson.rst index 057acfc2b8f28c85efe945b560af578761734a35..9580a5880794c8279d0424c57eb1b650b40aab44 100644 --- a/docs/whitedoc/michelson.rst +++ b/docs/whitedoc/michelson.rst @@ -3,6 +3,10 @@ Michelson: the language of Smart Contracts in Tezos =================================================== +This specification gives a detailed formal semantics of the Michelson +language, and a short explanation of how smart contracts are executed +and interact in the blockchain. + The language is stack-based, with high level data types and primitives and strict static type checking. Its design cherry picks traits from several language families. Vigilant readers will notice direct @@ -14,30 +18,154 @@ previous instruction, and rewrites it for the next one. The stack contains both immediate values and heap allocated structures. All values are immutable and garbage collected. -A Michelson program receives as input a stack containing a single pair whose -first element is an input value and second element the content of a storage -space. It must return a stack containing a single pair whose first element is -a list of internal operations, and second element the new contents of the -storage space. Alternatively, a Michelson program can fail, explicitly using -a specific opcode, or because something went wrong that could not be caught -by the type system (e.g. division by zero, gas exhaustion). - -The types of the input, output and storage are fixed and monomorphic, +The types of the input and output stack are fixed and monomorphic, and the program is typechecked before being introduced into the system. No smart contract execution can fail because an instruction has been executed on a stack of unexpected length or contents. This specification gives the complete instruction set, type system and semantics of the language. It is meant as a precise reference manual, -not an easy introduction. Even though, some examples are provided at the -end of the document and can be read first or at the same time as the -specification. +not an easy introduction. Even though, some examples are provided at +the end of the document and can be read first or at the same time as +the specification. The document also starts with a less formal +explanation of the context: how Michelson code interacts with the +blockchain. -Semantics ---------- +Semantics of smart contracts and transactions +--------------------------------------------- -This specification gives a detailed formal semantics of the Michelson -language. It explains in a symbolic way the computation performed by the +The Tezos ledger currently has two types of accounts that can hold +tokens (and be the destinations of transactions). + + - An implicit account is a non programmable account, whose tokens + are spendable and delegatable by a public key. Its address is + directly the public key hash, and starts with ``tz1``, ``tz2`` or + ``tz3``. + - A smart contract is a programmable account. A transaction to such + an address can provide data, and can fail for reasons decided by + its Michelson code. Its address is a unique hash that depends on + the operation that led to its creation, and starts with ``KT1``. + +From Michelson, they are indistinguishable. A safe way to think about +this is to consider that implicit accounts are smart contracts that +always succeed to receive tokens, and does nothing else. + +Intra-transaction semantics +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Alongside their tokens, smart contracts keep a piece of storage. Both +are ruled by a specific logic specified by a Michelson program. A +transaction to smart contract will provide an input value and in +option some tokens, and in return, the smart contract can modify its +storage and transfer its tokens. + +The Michelson program receives as input a stack containing a single +pair whose first element is an input value and second element the +content of the storage space. It must return a stack containing a +single pair whose first element is the list of internal operations +that it wants to emit, and second element is the new contents of the +storage space. Alternatively, a Michelson program can fail, explicitly +using a specific opcode, or because something went wrong that could +not be caught by the type system (e.g. gas exhaustion). + +A bit of polymorphism can be used at contract level, with a +lightweight system of named entrypoints: instead of an input value, +the contract can be called with an entrypoint name and an argument, +and these two component are transformed automatically in a simple and +deterministic way to an input value. This feature is available both +for users and from Michelson code. See the dedicated section. + +Inter-transaction semantics +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +An operation included in the blockchain is a sequence of "external +operations" signed as a whole by a source address. These operations +are of three kinds: + + - Transactions to transfer tokens to implicit accounts or tokens and + parameters to a smart contract (or, optionally, to a specified + entrypoint of a smart contract). + - Originations to create new smart contracts from its Michelson + source code, an initial amount of tokens transferred from the + source, and an initial storage contents. + - Delegations to assign the tokens of the source to the stake of + another implicit account (without transferring any tokens). + +Smart contracts can also emit "internal operations". These are run +in sequence after the external transaction completes, as in the +following schema for a sequence of two external operations. + +:: + + +------+----------------+-------+----------------+ + | op 1 | internal ops 1 | op 2 | internal ops 2 | + +------+----------------+-------+----------------+ + +Smart contracts called by internal transactions can in turn also emit +internal operation. The interpretation of the internal operations +of a given external operation use a queue, as in the following +example, also with two external operations. + +:: + + +-----------+---------------+--------------------------+ + | executing | emissions | resulting queue | + +-----------+---------------+--------------------------+ + | op 1 | 1a, 1b, 1c | 1a, 1b, 1c | + | op 1a | 1ai, 1aj | 1b, 1c, 1ai, 1aj | + | op 1b | 1bi | 1c, 1ai, 1aj, 1bi | + | op 1c | | 1ai, 1aj, 1bi | + | op 1ai | | 1aj, 1bi | + | op 1aj | | 1bi | + | op 1bi | | | + | op 2 | 2a, 2b | 2a, 2b | + | op 2a | 2ai | 2b, 2ai | + | op 2b | | 2ai | + | op 2ai | 2ai1 | 2ai1 | + | op 2a1 | 2ai2 | 2ai2 | + | op 2a2 | 2ai3 | 2ai3 | + | op 2a3 | | | + +-----------+---------------+--------------------------+ + +Failures +~~~~~~~~ + +All transactions can fail for a few reasons, mostly: + + - Not enough tokens in the source to spend the specified amount. + - The script took too many execution steps. + - The script failed programmatically using the ``FAILWITH`` instruction. + +External transactions can also fail for these additional reasons: + + - The signature of the external operations was wrong. + - The code or initial storage in an origination did not typecheck. + - The parameter in a transfer did not typecheck. + - The destination did not exist. + - The specified entrypoint did not exist. + +All these errors cannot happen in internal transactions, as the type +system catches them at operation creation time. In particular, +Michelson has two types to talk about other accounts: ``address`` and +``contract t``. The ``address`` type merely gives the guarantee that +the value has the form of a Tezos address. The ``contract t`` type, on +the other hand, guarantees that the value is indeed a valid, existing +account whose parameter type is ``t``. To make a transaction from +Michelson, a value of type ``contract t`` must be provided, and the +type system checks that the argument to the transaction is indeed of +type ``t``. Hence, all transactions made from Michelson are well +formed by construction. + +In any case, when a failure happens, either total success or total +failure is guaranteed. If a transaction (internal or external) fails, +then the whole sequence fails and all the effects up to the failure +are reverted. These transactions can still be included in blocks, and +the transaction fees given to the implicit account who baked the block. + +Language semantics +------------------ + +This specification explains in a symbolic way the computation performed by the Michelson interpreter on a given program and initial stack to produce the corresponding resulting stack. The Michelson interpreter is a pure function: it only builds a result stack from the elements of an initial @@ -357,11 +485,10 @@ Core data types and notations - ``big_map (k) (t)``: Lazily deserialized maps from keys of type ``(k)`` of values of type ``(t)`` that we note ``{ Elt key value ; ... }``, - with keys sorted. These maps should be used if you intend to store + with keys sorted. These maps should be used if you intend to store large amounts of data in a map. They have higher gas costs than - standard maps as data is lazily deserialized. You are limited to a - single ``big_map`` per program, which must appear on the left hand - side of a pair in the contract's storage. + standard maps as data is lazily deserialized. A ``big_map`` cannot + appear inside another ``big_map``. Core instructions ----------------- @@ -454,6 +581,17 @@ Control structures > EXEC / a : f : S => r : S where f / a : [] => r : [] +- ``APPLY``: Partially apply a tuplified function from the stack. + Such a lambda is storable, and thus values that cannot be stored + (values of type ``operation``, ``contract _`` and ``big map _ _``) + cannot be captured by ``APPLY`` (cannot appear in ``'a``). + +:: + + :: 'a : lambda (pair 'a 'b) 'c : 'C -> lambda 'b 'c : 'C + + > APPLY / a : f : S => { PUSH t v ; PAIR ; code } : S + Stack operations ~~~~~~~~~~~~~~~~ @@ -849,6 +987,20 @@ Operations on pairs > CDR / (Pair _ b) : S => b : S +- ``COMPARE``: Lexicographic comparison. + +:: + + :: pair 'a 'b : pair 'a 'b : 'S -> int : 'S + + > COMPARE / (Pair sa sb) : (Pair ta tb) : S => -1 : S + iff COMPARE / sa : ta : S => -1 : S + > COMPARE / (Pair sa sb) : (Pair ta tb) : S => 1 : S + iff COMPARE / sa : ta : S => 1 : S + > COMPARE / (Pair sa sb) : (Pair ta tb) : S => r : S + iff COMPARE / sa : ta : S => 0 : S + COMPARE / sb : tb : S => r : S + Operations on sets ~~~~~~~~~~~~~~~~~~ @@ -1029,6 +1181,15 @@ The behavior of these operations is the same as if they were normal maps, except that under the hood, the elements are loaded and deserialized on demand. +- ``EMPTY_BIG_MAP 'key 'val``: Build a new, empty big map from keys of a + given type to values of another given type. + + The ``'key`` type must be comparable (the ``COMPARE`` primitive must + be defined over it). + +:: + + :: 'S -> map 'key 'val : 'S - ``GET``: Access an element in a ``big_map``, returns an optional value to be checked with ``IF_SOME``. @@ -1192,9 +1353,10 @@ Domain specific data types - ``mutez``: A specific type for manipulating tokens. -- ``contract 'param``: A contract, with the type of its code. +- ``address``: An untyped address (implicit account or smart contract). -- ``address``: An untyped contract address. +- ``contract 'param``: A contract, with the type of its code, + ``contract unit`` for implicit accounts. - ``operation``: An internal operation emitted by a contract. @@ -1204,6 +1366,8 @@ Domain specific data types - ``signature``: A cryptographic signature. +- ``chain_id``: An identifier for a chain, used to distinguish the test and the main chains. + Domain specific operations -------------------------- @@ -1324,27 +1488,15 @@ Operations on contracts :: - :: key_hash : option key_hash : bool : bool : mutez : 'g : 'S + :: option key_hash : mutez : 'g : 'S -> operation : address : 'S -Originate a contract based on a literal. This is currently the only way -to include transfers inside of an originated contract. The first -parameters are the manager, optional delegate, then spendable and -delegatable flags and finally the initial amount taken from the -currently executed contract. The contract is returned as a first class -value (to be dropped, passed as parameter or stored). -The ``CONTRACT 'p`` instruction will fail until it is actually originated. - -- ``CREATE_ACCOUNT``: Forge an account (a contract without code) creation operation. - -:: - - :: key_hash : option key_hash : bool : mutez : 'S - -> operation : address : 'S - -Take as argument the manager, optional delegate, the delegatable flag -and finally the initial amount taken from the currently executed -contract. +Originate a contract based on a literal. The parameters are the +optional delegate, the initial amount taken from the currently +executed contract, and the initial storage of the originated contract. +The contract is returned as a first class value (to be dropped, passed +as parameter or stored). The ``CONTRACT 'p`` instruction will fail +until it is actually originated. - ``TRANSFER_TOKENS``: Forge a transaction. @@ -1432,13 +1584,6 @@ contract, unit for an account. Special operations ~~~~~~~~~~~~~~~~~~ -- ``STEPS_TO_QUOTA``: Push the remaining steps before the contract - execution must terminate. - -:: - - :: 'S -> nat : 'S - - ``NOW``: Push the timestamp of the block whose validation triggered this execution (does not change during the execution of the contract). @@ -1447,6 +1592,13 @@ Special operations :: 'S -> timestamp : 'S +- ``CHAIN_ID``: Push the chain identifier. + +:: + + :: 'S -> chain_id : 'S + + Operations on bytes ~~~~~~~~~~~~~~~~~~~ @@ -1563,6 +1715,46 @@ Cryptographic primitives > COMPARE / x : y : S => 1 : S iff x > y +Deprecated instructions +~~~~~~~~~~~~~~~~~~~~~~~ + +The following instructions are deprecated. The Michelson type-checker +will reject any contract using them but contracts already originated +on the blockchain using them will continue to work as before. + +- ``CREATE_CONTRACT { storage 'g ; parameter 'p ; code ... }``: + Forge a new contract from a literal. + +:: + + :: key_hash : option key_hash : bool : bool : mutez : 'g : 'S + -> operation : address : 'S + +See the documentation of the new ``CREATE_CONTRACT`` instruction. The +first, third, and fourth parameters are ignored. + +- ``CREATE_ACCOUNT``: Forge an account creation operation. + +:: + + :: key_hash : option key_hash : bool : mutez : 'S + -> operation : address : 'S + +Takes as argument the manager, optional delegate, the delegatable flag +and finally the initial amount taken from the currently executed +contract. This instruction originates a contract with two entrypoints; +``%default`` of type ``unit`` that does nothing and ``%do`` of type +``lambda unit (list operation)`` that executes and returns the +parameter if the sender is the contract's manager. + +- ``STEPS_TO_QUOTA``: Push the remaining steps before the contract + execution must terminate. + +:: + + :: 'S -> nat : 'S + + Macros ------ @@ -1937,10 +2129,14 @@ line can also be written, using C-like delimiters (``/* ... */``). Annotations ----------- -The annotation mechanism of Michelson provides ways to better track data -on the stack and to give additional type constraints. Annotations are -only here to add constraints, *i.e.* they cannot turn an otherwise -rejected program into an accepted one. +The annotation mechanism of Michelson provides ways to better track +data on the stack and to give additional type constraints. Except for +a single exception specified just after, annotations are only here to +add constraints, *i.e.* they cannot turn an otherwise rejected program +into an accepted one. The notable exception to this rule is for +entrypoints: the `CONTRACT` instruction semantics varies depending on +its constructor annotation, and some contract origination may fail due +to invalid entrypoint constructor annotations. Stack visualization tools like the Michelson's Emacs mode print annotations associated with each type in the program, as propagated by @@ -2017,6 +2213,9 @@ type on top. EMPTY_MAP :t 'key 'val :: 'S -> (map :t 'key 'val) : 'S + EMPTY_BIG_MAP :t 'key 'val + :: 'S -> (big_map :t 'key 'val) : 'S + A no-op instruction ``CAST`` ensures the top of the stack has the specified type, and change its type if it is compatible. In particular, @@ -2082,6 +2281,7 @@ The instructions which accept at most one variable annotation are: MEM EMPTY_SET EMPTY_MAP + EMPTY_BIG_MAP UPDATE GET LAMBDA @@ -2124,6 +2324,7 @@ The instructions which accept at most one variable annotation are: SELF CAST RENAME + CHAIN_ID The instructions which accept at most two variable annotations are: @@ -2221,12 +2422,6 @@ and variable annotations). RIGHT %left %right 'a :: 'b : 'S -> (or ('a %left) ('b %right)) : 'S - NONE %some 'a - :: 'S -> (option ('a %some)) - - Some %some - :: 'a : 'S -> (option ('a %some)) - To improve readability and robustness, instructions ``CAR`` and ``CDR`` accept one field annotation. For the contract to type check, the name of the accessed field in the destructed pair must match the one given here. @@ -2433,6 +2628,144 @@ treatment of annotations with `.`. :: @p.x 'a : @p.y 'b : 'S -> @p (pair ('a %x) ('b %y)) : 'S :: @p.x 'a : @q.y 'b : 'S -> (pair ('a %x) ('b %y)) : 'S +Entrypoints +----------- + +The specification up to this point has been mostly ignoring existence +of entrypoints: a mechanism of contract level polymorphism. This +mechanism is optional, non intrusive, and transparent to smart +contracts that don't use them. This section is to be read as a patch +over the rest of the specification, introducing rules that apply only +in presence of contracts that make use of entrypoints. + +Defining and calling entrypoints +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Entrypoints piggyback on the constructor annotations. A contract with +entrypoints is basically a contract that takes a disjunctive type (a +nesting of ``or`` types) as the root of its input parameter, decorated +with constructor annotations. An extra check is performed on these +constructor annotations: a contract cannot define two entrypoints with +the same name. + +An external transaction can include an entrypoint name alongside the +parameter value. In that case, if there is a constructor annotation +with this name at any position in the nesting of ``or`` types, the +value is automatically wrapped into the according constructors. If the +transaction specifies an entrypoint, but there is no such constructor +annotation, the transaction fails. + +For instance, suppose the following input type. + +``parameter (or (or (nat %A) (bool %B)) (or %maybe_C (unit %Z) (string %C)))`` + +The input values will be wrapped as in the following examples. + +:: + + +------------+-----------+---------------------------------+ + | entrypoint | input | wrapped input | + +------------+-----------+---------------------------------+ + | %A | 3 | Left (Left 3) | + | %B | False | Left (Right False) | + | %C | "bob" | Right (Right "bob") | + | %Z | Unit | Right (Left Unit) | + | %maybe_C | Right "x" | Right (Right "x") | + | %maybe_C | Left Unit | Right (Left Unit) | + +------------+-----------+---------------------------------+ + | not given | value | value (untouched) | + | %BAD | _ | failure, contract not called | + +------------+-----------+---------------------------------+ + +The ``default`` entrypoint +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A special semantics is assigned to the ``default`` entrypoint. If the +contract does not explicitly declare a ``default`` entrypoint, then it +is automatically assigned to the root of the parameter +type. Conversely, if the contract is called without specifying an +entrypoint, then it is assumed to be called with the ``default`` +entrypoint. This behaviour makes the entrypoint system completely +transparent to contracts that do not use it. + +This is the case for the previous example, for instance. If a value is +passed to such a contract specifying entrypoint ``default``, then the +value is fed to the contract untouched, exactly as if no entrypoint +was given. + +A non enforced convention is to make the entrypoint ``default`` of +type unit, and to implement the crediting operation (just receive the +transferred tokens). + +A consequence of this semantics is that if the contract uses the +entrypoint system and defines a ``default`` entrypoint somewhere else +than at the root of the parameter type, then it must provide an +entrypoint for all the paths in the toplevel disjunction. Otherwise, +some parts of the contracts would be dead code. + +Another consequence of setting the entrypoint somewhere else than at +the root is that it makes it impossible to send the raw values of the +full parameter type to a contract. A trivial solution for that is to +name the root of the type. The conventional name for that is ``root``. + +Let us recapitulate this by tweaking the names of the previous example. + +``parameter %root (or (or (nat %A) (bool %B)) (or (unit %default) string))`` + +The input values will be wrapped as in the following examples. + +:: + + +------------+---------------------+-----------------------+ + | entrypoint | input | wrapped input | + +------------+---------------------+-----------------------+ + | %A | 3 | Left (Left 3) | + | %B | False | Left (Right False) | + | %default | Unit | Right (Left Unit) | + | %root | Right (Right "bob") | Right (Right "bob") | + +------------+---------------------+-----------------------+ + | not given | Unit | Right Unit | + | %BAD | _ | failure, contract not | + +------------+---------------------+-----------------------+ + +Calling entrypoints from Michelson +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Michelson code can also produce transactions to a specific entrypoint. + +For this, both types ``address`` and ``contract`` have the ability to +denote not just an address, but a pair of an address and an +entrypoint. The concrete notation is ``"address%entrypoint"``. +Note that ``"address"`` is strictly equivalent to ``"address%default"``, +and for clarity, the second variant is forbidden in the concrete syntax. + +When the ``TRANSFER_TOKENS`` instruction is called, it places the +entrypoint provided in the contract handle in the transaction. + +The ``CONTRACT t`` instruction has a variant ``CONTRACT %entrypoint +t``, that works as follows. Note that ``CONTRACT t`` is strictly +equivalent to ``CONTRACT %default t``, and for clarity, the second +variant is forbidden in the concrete syntax. + +:: + + +---------------+---------------------+------------------------------------------+ + | input address | instruction | output contract | + +---------------+---------------------+------------------------------------------+ + | "addr" | CONTRACT t | (Some "addr") if contract exists, has a | + | | | default entrypoint of type t, or has no | + | | | default entrypoint and parameter type t | + +---------------+---------------------+------------------------------------------+ + | "addr%name" | CONTRACT t | (Some "addr%name") if addr exists and | + +---------------+---------------------+ has an entrypoint %name of type t | + | "addr" | CONTRACT %name t | | + +---------------+---------------------+------------------------------------------+ + | "addr%_" | CONTRACT %_ t | None | + +---------------+---------------------+------------------------------------------+ + +Implicit accounts are considered to have a single ``default`` +entrypoint of type ``Unit``. + JSON syntax ----------- @@ -2492,6 +2825,23 @@ The simplest contract is the contract for which the ``parameter`` and parameter unit; +Example contract with entrypoints +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The following contract maintains a number in its storage. It has two +entrypoints ``add`` and ``sub`` to modify it, and the default +entrypoint, of type ``unit`` will reset it to ``0``. + +:: + + { parameter (or (or (nat %add) (nat %sub)) (unit %default)) ; + storage int ; + code { AMOUNT ; PUSH mutez 0 ; ASSERT_CMPEQ ; UNPAIR ; + IF_LEFT + { IF_LEFT { ADD } { SWAP ; SUB } } + { DROP ; DROP ; PUSH int 0 } ; + NIL operation ; PAIR } } + Multisig contract ~~~~~~~~~~~~~~~~~ @@ -2540,7 +2890,7 @@ using the Coq proof assistant. UNPAIR ; # pair the payload with the current contract address, to ensure signatures # can't be replayed accross different contracts if a key is reused. - DUP ; SELF ; ADDRESS ; PAIR ; + DUP ; SELF ; ADDRESS ; CHAIN_ID ; PAIR ; PAIR ; PACK ; # form the binary payload that we expect to be signed DIP { UNPAIR @counter ; DIP { SWAP } } ; SWAP } ; @@ -2652,6 +3002,7 @@ Full grammar | SIZE | EMPTY_SET | EMPTY_MAP + | EMPTY_BIG_MAP | MAP { ... } | ITER { ... } | MEM @@ -2708,6 +3059,7 @@ Full grammar | SOURCE | SENDER | ADDRESS + | CHAIN_ID ::= | | key @@ -2723,7 +3075,11 @@ Full grammar | lambda | map | big_map + | chain_id ::= + | + | pair + ::= | int | nat | string @@ -2734,6 +3090,7 @@ Full grammar | timestamp | address + Reference implementation ------------------------ diff --git a/docs/whitedoc/michelson_reference.rst b/docs/whitedoc/michelson_reference.rst new file mode 100644 index 0000000000000000000000000000000000000000..9bc9f29cf114b8cb7bdd447b69e854d3fde74198 --- /dev/null +++ b/docs/whitedoc/michelson_reference.rst @@ -0,0 +1,5 @@ +Michelson Instruction Reference +======================================================= + +.. raw:: html + :file: michelson_reference.html diff --git a/scripts/activate_protocol.sh b/scripts/activate_protocol.sh index 086ca390c6195d9636e254c0ccdb95a5d8c5869a..fdbb950211a42abd938a74f1d248dcb9430be449 100755 --- a/scripts/activate_protocol.sh +++ b/scripts/activate_protocol.sh @@ -70,21 +70,33 @@ if [[ "$ans" == "Y" || "$ans" == "y" || -z "$ans" ]]; then src/bin_node/{dune,tezos-node.opam} fi -read -p "User-activated update in 3 blocks? (Y/n) " ans +read -p "User-activated update? (Y/n) " ans if [[ "$ans" == "Y" || "$ans" == "y" || -z "$ans" ]]; then - # clean existing lines, if any - awk -i inplace ' - BEGIN{found=0}{ - if (!found && $0 ~ "let forced_protocol_upgrades") - {found=1; print} - else { - if (found && $0 ~ "^]") - {found=0; print } - else - { if (!found){print}} - }}' src/lib_base/block_header.ml - - sed -i.old '/let forced_protocol_upgrades/ a \ \ 3l, Protocol_hash.of_b58check_exn '${full_hash}' ;' \ + + read -p "At what level? (e.g. 3 for sandbox): " level + + if [[ $level < 28082 ]]; then + # we are testing in sandbox so we clean existing lines + awk -i inplace ' + BEGIN{found=0}{ + if (!found && $0 ~ "let forced_protocol_upgrades") + {found=1; print} + else { + if (found && $0 ~ "^]") + {found=0; print } + else + { if (!found){print}} + }}' src/lib_base/block_header.ml + fi + + sed -i.old '/let forced_protocol_upgrades/ a \ \ '${level}'l, Protocol_hash.of_b58check_exn '${full_hash}' ;' \ src/lib_base/block_header.ml rm src/lib_base/block_header.ml.old + + patch -p1 < scripts/yes-node.patch + + if ! [ -d yes-wallet ]; then + dune utop src/lib_crypto scripts/yes-wallet.ml + echo 'Created `yes-wallet` directory.' + fi fi diff --git a/scripts/yes-node.patch b/scripts/yes-node.patch new file mode 100644 index 0000000000000000000000000000000000000000..b4bbfcf1c27fa3e436e414b068a46e95dacbdd97 --- /dev/null +++ b/scripts/yes-node.patch @@ -0,0 +1,41 @@ +diff --git a/src/lib_crypto/signature.ml b/src/lib_crypto/signature.ml +index 8aec1057e..5b47714e4 100644 +--- a/src/lib_crypto/signature.ml ++++ b/src/lib_crypto/signature.ml +@@ -539,7 +539,7 @@ let pp_watermark ppf = + fprintf ppf "Custom: 0x%s" + (try String.sub hexed 0 10 ^ "..." with _ -> hexed) + +-let sign ?watermark secret_key message = ++let _sign ?watermark secret_key message = + let watermark = Option.map ~f:bytes_of_watermark watermark in + match secret_key with + | Secret_key.Ed25519 sk -> of_ed25519 (Ed25519.sign ?watermark sk message) +@@ -572,6 +572,27 @@ let check ?watermark public_key signature message = + P256.check ?watermark pk signature message + | _ -> false + ++let fake_sign pk_bytes msg = ++ let half = size / 2 in ++ let tmp = MBytes.init size (fun _ -> '0') in ++ let all_or_half buf = Pervasives.min (MBytes.length buf) half in ++ MBytes.blit pk_bytes 0 tmp 0 (all_or_half pk_bytes) ; ++ MBytes.blit msg 0 tmp half (all_or_half msg) ; ++ of_bytes_exn tmp ++ ++let fake_check ?watermark pk signature msg = ++ let pk_bytes = Data_encoding.Binary.to_bytes_exn ++ Public_key.encoding pk in ++ if equal signature (fake_sign pk_bytes msg) then true else ++ check ?watermark pk signature msg ++ ++let sign ?watermark:_ sk msg = ++ let pk_bytes = Data_encoding.Binary.to_bytes_exn ++ Secret_key.encoding sk in ++ fake_sign pk_bytes msg ++ ++let check = fake_check ++ + let append ?watermark sk msg = + MBytes.concat "" [msg; (to_bytes (sign ?watermark sk msg))] + diff --git a/scripts/yes-wallet.ml b/scripts/yes-wallet.ml new file mode 100644 index 0000000000000000000000000000000000000000..4285d304f668e40d799775a292a6fa8e390c6be8 --- /dev/null +++ b/scripts/yes-wallet.ml @@ -0,0 +1,95 @@ + +(* + dune utop src/lib_crypto scripts/yes-wallet.ml + + Given a list of aliases and public key hashes: + - finds the corresponding public keys using RPCs + (if you have a running node) + - encodes each public key as a fake secret key that can be used + with the yes-node.patch + - creates a 'yes-wallet' directory to be passed to tezos-client -d option + *) + +let string_to_file s file = + let oc = open_out file in + output_string oc s ; + close_out oc + +let json_of_list l = + Printf.sprintf "[ %s ]\n" (String.concat ",\n" l) + +let pkhs = [ + ("foundation1", "tz3RDC3Jdn4j15J7bBHZd29EUee9gVB1CxD9") ; + ("foundation2", "tz3bvNMQ95vfAYtG8193ymshqjSvmxiCUuR5") ; + ("foundation3", "tz3RB4aoyjov4KEVRbuhvQ1CKJgBJMWhaeB8") ; + ("foundation4", "tz3bTdwZinP8U1JmSweNzVKhmwafqWmFWRfk") ; + ("foundation5", "tz3NExpXn9aPNZPorRE4SdjJ2RGrfbJgMAaV") ; + ("foundation6", "tz3UoffC7FG7zfpmvmjUmUeAaHvzdcUvAj6r") ; + ("foundation7", "tz3WMqdzXqRWXwyvj5Hp2H7QEepaUuS7vd9K") ; + ("foundation8", "tz3VEZ4k6a4Wx42iyev6i2aVAptTRLEAivNN") ; +] + +let pkh_pp (alias, pkh) = + Printf.sprintf "{ \"name\": \"%s\", \"value\": \"%s\" }" alias pkh + + +let pk_of_pkh (pkh : string) : string = + let url = "localhost:8732" in + let curl = Printf.sprintf "curl -s '%s/chains/main/blocks/head/context/raw/json/contracts/index/%s/manager'" url pkh in + Lwt_main.run + (Lwt_process.pread_line (Lwt_process.shell curl)) + +(* let pks = List.map (fun (_alias, pkh) -> pk_of_pkh pkh) pkhs *) + +let pks = [ + "p2pk67wVncLFS1DQDm2gVR45sYCzQSXTtqn3bviNYXVCq6WRoqtxHXL" ; + "p2pk66n1NmhPDEkcf9sXEKe9kBoTwBoTYxke1hx16aTRVq8MoXuwNqo" ; + "p2pk67NECc8vGK4eLbXGEgBZGhk53x1pCMbgnFEgLxZEMGDtzVcFQok" ; + "p2pk6796esaR3dNr8jUx8S7xxZdRvpYSrhHMg6NagjwMRJHsERMiUKM" ; + "p2pk66iTZwLmRPshQgUr2HE3RUzSFwAN5MNaBQ5rfduT1dGKXd25pNN" ; + "p2pk65ffAqpYT6Et73DXdNqudthwmSNzNyzL3Wdn2EYuiiMwoPu6vFJ" ; + "p2pk67Cwb5Ke6oSmqeUbJxURXMe3coVnH9tqPiB2xD84CYhHbBKs4oM" ; + "p2pk67uapBxwkM1JNasGJ6J3rozzYELgrtcqxKZwZLjvsr4XcAr4FqC" ; +] + +let pk_pp (alias,pkh) pk = + let loc_key = + Printf.sprintf "{ \"locator\": \"unencrypted:%s\", \"key\": \"%s\" }" pk pk + in + Printf.sprintf "{ \"name\": \"%s\", \"value\": %s }" alias loc_key + + +open Tezos_crypto.Signature ;; +open Tezos_data_encoding ;; +open Tezos_stdlib ;; + +(* P-256 pk : 33+1 bytes + ed25519 pk sk : 32+1 bytes +*) + +let sk_of_pk (pk_s : string) : string = + let pk = Public_key.of_b58check_exn pk_s in + let pk_b = Data_encoding.Binary.to_bytes_exn Public_key.encoding pk in + let sk_b = MBytes.sub pk_b 0 33 in + let sk = Data_encoding.Binary.of_bytes_exn Secret_key.encoding sk_b in + let sk_s = Secret_key.to_b58check sk in + sk_s + +let sks = List.map (sk_of_pk) pks + +let sk_pp (alias,pkh) sk = + Printf.sprintf "{ \"name\": \"%s\", \"value\": \"unencrypted:%s\" }" alias sk + + +let _ = + Unix.mkdir "yes-wallet" 0o750 ; + Unix.chdir "yes-wallet" ; + + let l = List.map pkh_pp pkhs in + string_to_file (json_of_list l) "public_key_hashs" ; + + let l = List.map2 pk_pp pkhs pks in + string_to_file (json_of_list l) "public_keys" ; + + let l = List.map2 sk_pp pkhs sks in + string_to_file (json_of_list l) "secret_keys" diff --git a/src/bin_client/test/contracts/attic/bad_lockup.tz b/src/bin_client/test/contracts/attic/bad_lockup.tz index aeb3ec7fea8efa6db127203ecf37a92fefad0043..f334e899e71cfe2d8cda8bcc2ef3295384fddb78 100644 --- a/src/bin_client/test/contracts/attic/bad_lockup.tz +++ b/src/bin_client/test/contracts/attic/bad_lockup.tz @@ -1,6 +1,6 @@ parameter unit; -storage (pair timestamp (pair (contract unit) (contract unit))); +storage (pair timestamp (pair address address)); code { CDR; DUP; CAR; NOW; CMPLT; IF {FAIL} {}; - DUP; CDAR; PUSH mutez 100000000; UNIT; TRANSFER_TOKENS; SWAP; - DUP; CDDR; PUSH mutez 100000000; UNIT; TRANSFER_TOKENS; DIP {SWAP} ; + DUP; CDAR; CONTRACT unit ; ASSERT_SOME ; PUSH mutez 100000000; UNIT; TRANSFER_TOKENS; SWAP; + DUP; CDDR; CONTRACT unit ; ASSERT_SOME ; PUSH mutez 100000000; UNIT; TRANSFER_TOKENS; DIP {SWAP} ; NIL operation ; SWAP ; CONS ; SWAP ; CONS ; PAIR } diff --git a/src/bin_client/test/contracts/attic/create_add1_lists.tz b/src/bin_client/test/contracts/attic/create_add1_lists.tz index c183ad1e26ea6425032db083e5a64925c7421c81..5a4245966379e4ae96d793947dbec877ab9165a3 100644 --- a/src/bin_client/test/contracts/attic/create_add1_lists.tz +++ b/src/bin_client/test/contracts/attic/create_add1_lists.tz @@ -2,10 +2,7 @@ parameter unit; storage address; code { DROP; NIL int; # starting storage for contract AMOUNT; # Push the starting balance - PUSH bool False; # Not spendable - DUP; # Or delegatable NONE key_hash; # No delegate - PUSH key_hash "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5"; CREATE_CONTRACT # Create the contract { parameter (list int) ; storage (list int) ; diff --git a/src/bin_client/test/contracts/attic/forward.tz b/src/bin_client/test/contracts/attic/forward.tz index 9894dae20e94e51363a6c0446bed0ff8d04d492e..5b66891bb1bf58a42202f88b08903a81044a9bff 100644 --- a/src/bin_client/test/contracts/attic/forward.tz +++ b/src/bin_client/test/contracts/attic/forward.tz @@ -8,8 +8,8 @@ storage (pair (pair mutez mutez) # K C (pair - (pair (contract unit) (contract unit)) # B S - (contract unit))))) ; # W + (pair address address) # B S + address)))) ; # W code { DUP ; CDDADDR ; # Z PUSH int 86400 ; SWAP ; ADD ; # one day in second @@ -49,15 +49,18 @@ code IF { # refund the parties CDR ; DUP ; CADAR ; # amount versed by the buyer DIP { DUP ; CDDDAAR } ; # B + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; SWAP ; DUP ; CADDR ; # amount versed by the seller DIP { DUP ; CDDDADR } ; # S + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; DUP ; CADAR ; DIP { DUP ; CADDR } ; ADD ; BALANCE ; SUB ; # bonus to the warehouse DIP { DUP ; CDDDDR } ; # W + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; DIP { SWAP } ; CONS ; # leave the storage as-is, as the balance is now 0 @@ -101,6 +104,7 @@ code BALANCE ; DIP { DUP ; CDDDDADR } ; # S DIIP { CDR } ; + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; PAIR } { # otherwise continue @@ -110,7 +114,7 @@ code NOW ; COMPARE ; LT ; IF { # Between T + 24 and T + 48 # We accept only delivery notifications, from W - DUP ; CDDDDDR ; ADDRESS ; # W + DUP ; CDDDDDR ; # W SENDER ; COMPARE ; NEQ ; IF { FAIL } {} ; # fail if not the warehouse @@ -132,6 +136,7 @@ code BALANCE ; DIP { DUP ; CDDDDADR } ; # S DIIP { CDR } ; + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS } } ; PAIR } @@ -139,6 +144,7 @@ code BALANCE ; DIP { DUP ; CDDDDAAR } ; # B DIIP { CDR } ; + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; PAIR} } } } } } } \ No newline at end of file diff --git a/src/bin_client/test/contracts/attic/list_of_transactions.tz b/src/bin_client/test/contracts/attic/list_of_transactions.tz index 412112aad02c58272b6ff3ff4cd6cb42362b1f47..620ceedd5a678613b004e6744347bbfe309b456e 100644 --- a/src/bin_client/test/contracts/attic/list_of_transactions.tz +++ b/src/bin_client/test/contracts/attic/list_of_transactions.tz @@ -1,8 +1,8 @@ parameter unit; -storage (list (contract unit)); +storage (list address); code { CDR; DUP; DIP {NIL operation}; PUSH bool True; # Setup loop - LOOP {IF_CONS { PUSH mutez 1000000; UNIT; TRANSFER_TOKENS; # Make transfer + LOOP {IF_CONS { CONTRACT unit ; ASSERT_SOME ; PUSH mutez 1000000; UNIT; TRANSFER_TOKENS; # Make transfer SWAP; DIP {CONS}; PUSH bool True} # Setup for next round of loop - { NIL (contract unit); PUSH bool False}}; # Data to satisfy types and end loop + { NIL address ; PUSH bool False}}; # Data to satisfy types and end loop DROP; PAIR}; # Calling convention diff --git a/src/bin_client/test/contracts/attic/reentrancy.tz b/src/bin_client/test/contracts/attic/reentrancy.tz index 2e5d92060ad75fef2e6f7959f7ed656bf6e2993a..b9e614a4e53e9b0772872e81a43900b5363a2a34 100644 --- a/src/bin_client/test/contracts/attic/reentrancy.tz +++ b/src/bin_client/test/contracts/attic/reentrancy.tz @@ -1,7 +1,7 @@ parameter unit; -storage (pair (contract unit) (contract unit)); -code { CDR; DUP; CAR; PUSH mutez 5000000; UNIT; - TRANSFER_TOKENS; +storage (pair address address); +code { CDR; DUP; CAR; + CONTRACT unit ; ASSERT_SOME ; PUSH mutez 5000000; UNIT; TRANSFER_TOKENS; DIP {DUP; CDR; - PUSH mutez 5000000; UNIT; TRANSFER_TOKENS}; + CONTRACT unit ; ASSERT_SOME ; PUSH mutez 5000000; UNIT; TRANSFER_TOKENS}; DIIP{NIL operation};DIP{CONS};CONS;PAIR}; diff --git a/src/bin_client/test/contracts/attic/reservoir.tz b/src/bin_client/test/contracts/attic/reservoir.tz index 4e693c9ba88518abeadd87dac823fe6927d8b571..291e09b262b58110d971fa23ca8badcc1f93164f 100644 --- a/src/bin_client/test/contracts/attic/reservoir.tz +++ b/src/bin_client/test/contracts/attic/reservoir.tz @@ -2,7 +2,7 @@ parameter unit ; storage (pair (pair (timestamp %T) (mutez %N)) - (pair (contract %A unit) (contract %B unit))) ; + (pair (address %A) (address %B))) ; code { CDR ; DUP ; CAAR %T; # T NOW ; COMPARE ; LE ; @@ -11,11 +11,13 @@ code COMPARE ; LE ; IF { NIL operation ; PAIR } { DUP ; CDDR %B; # B + CONTRACT unit ; ASSERT_SOME ; BALANCE ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; PAIR } } { DUP ; CDAR %A; # A + CONTRACT unit ; ASSERT_SOME ; BALANCE ; UNIT ; TRANSFER_TOKENS ; diff --git a/src/bin_client/test/contracts/attic/scrutable_reservoir.tz b/src/bin_client/test/contracts/attic/scrutable_reservoir.tz index 9e30a1a72628354e58adced2c397c5daa1c7655f..d415cdda0f54950d0210a1323d157ca9d61f84fc 100644 --- a/src/bin_client/test/contracts/attic/scrutable_reservoir.tz +++ b/src/bin_client/test/contracts/attic/scrutable_reservoir.tz @@ -7,8 +7,8 @@ storage (pair (pair mutez mutez) # P N (pair - (contract unit) # X - (pair (contract unit) (contract unit)))))) ; # A B + address # X + (pair address address))))) ; # A B code { DUP ; CDAR ; # S PUSH string "open" ; @@ -34,10 +34,12 @@ code # We transfer the fee to the broker DUP ; CDDAAR ; # P DIP { DUP ; CDDDAR } ; # X + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; # We transfer the rest to A DIP { DUP ; CDDADR ; # N DIP { DUP ; CDDDDAR } ; # A + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS } ; NIL operation ; SWAP ; CONS ; SWAP ; CONS ; PAIR } } @@ -50,13 +52,16 @@ code COMPARE ; LT ; # available < P IF { BALANCE ; # available DIP { DUP ; CDDDAR } ; # X + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS } { DUP ; CDDAAR ; # P DIP { DUP ; CDDDAR } ; # X + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS } ; # We transfer the rest to B DIP { BALANCE ; # available DIP { DUP ; CDDDDDR } ; # B + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS } ; NIL operation ; SWAP ; CONS ; SWAP ; CONS ; PAIR } } } diff --git a/src/bin_client/test/contracts/attic/spawn_identities.tz b/src/bin_client/test/contracts/attic/spawn_identities.tz index 91b062aff83b1d8e31b0c16c3c9711aa3448d533..b8e64bb8686ac8a051a61b0b9b27c444b636c650 100644 --- a/src/bin_client/test/contracts/attic/spawn_identities.tz +++ b/src/bin_client/test/contracts/attic/spawn_identities.tz @@ -9,9 +9,7 @@ code { DUP; { PUSH nat 1; SWAP; SUB; ABS; # Subtract 1. The ABS is to make it back into a nat PUSH string "init"; # Storage type PUSH mutez 5000000; # Strating balance - PUSH bool False; DUP; # Not spendable or delegatable NONE key_hash; - PUSH key_hash "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5"; CREATE_CONTRACT { parameter string ; storage string ; diff --git a/src/bin_client/test/contracts/deprecated/create_account.tz b/src/bin_client/test/contracts/deprecated/create_account.tz new file mode 100644 index 0000000000000000000000000000000000000000..7cd38465a10b13126860d2e5736820ee37c3f8df --- /dev/null +++ b/src/bin_client/test/contracts/deprecated/create_account.tz @@ -0,0 +1,29 @@ +/* +- optional storage: the address of the created account +- param: Left [hash]: + + Create an account with manager [hash]; then perform a recursive call + on Right [addr] where [addr] is the address of the newly created + account. + + The created account has an initial balance of 100tz. It is not + delegatable. + +- param: Right [addr]: + + Check that the sender is self and that [addr] is a contract of type + [unit]. Finally store [addr]. + +*/ +parameter (or key_hash address) ; +storage (option address) ; +code { CAR; + IF_LEFT + { DIP { PUSH mutez 100000000 ; PUSH bool False ; NONE key_hash }; + CREATE_ACCOUNT ; + DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; + NIL operation ; SWAP ; CONS } ; + CONS ; NONE address ; SWAP ; PAIR } + { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ; + DUP ; CONTRACT unit ; IF_SOME { DROP ; SOME } { FAIL } ; + NIL operation ; PAIR } } ; diff --git a/src/bin_client/test/contracts/deprecated/create_contract.tz b/src/bin_client/test/contracts/deprecated/create_contract.tz new file mode 100644 index 0000000000000000000000000000000000000000..a162044ac62bd8c00c25bef6726f1e77b1c8e9f2 --- /dev/null +++ b/src/bin_client/test/contracts/deprecated/create_contract.tz @@ -0,0 +1,18 @@ +parameter (or key_hash address); +storage unit; +code { CAR; + IF_LEFT + { DIP { PUSH string "dummy"; + PUSH mutez 100000000 ; PUSH bool False ; + PUSH bool False ; NONE key_hash } ; + CREATE_CONTRACT + { parameter string ; + storage string ; + code { CAR ; NIL operation ; PAIR } } ; + DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; + NIL operation ; SWAP ; CONS } ; + CONS ; UNIT ; SWAP ; PAIR } + { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ; + CONTRACT string ; IF_SOME {} { FAIL } ; + PUSH mutez 0 ; PUSH string "abcdefg" ; TRANSFER_TOKENS ; + NIL operation; SWAP; CONS ; UNIT ; SWAP ; PAIR } }; diff --git a/src/bin_client/test/contracts/mini_scenarios/originator.tz b/src/bin_client/test/contracts/deprecated/originator.tz similarity index 100% rename from src/bin_client/test/contracts/mini_scenarios/originator.tz rename to src/bin_client/test/contracts/deprecated/originator.tz diff --git a/src/bin_client/test/contracts/ill_typed/pack_big_map.tz b/src/bin_client/test/contracts/ill_typed/pack_big_map.tz new file mode 100644 index 0000000000000000000000000000000000000000..29ae0d665051f298be07fa7d7b1e216e3551b362 --- /dev/null +++ b/src/bin_client/test/contracts/ill_typed/pack_big_map.tz @@ -0,0 +1,7 @@ +parameter unit; +storage (pair (big_map int int) unit); +code { CDAR; + DUP; PACK; DROP; + UNIT; SWAP; PAIR; + NIL operation; + PAIR; } diff --git a/src/bin_client/test/contracts/ill_typed/pack_operation.tz b/src/bin_client/test/contracts/ill_typed/pack_operation.tz new file mode 100644 index 0000000000000000000000000000000000000000..349ca053af27cf00e200a29cb79b957e3ad51e68 --- /dev/null +++ b/src/bin_client/test/contracts/ill_typed/pack_operation.tz @@ -0,0 +1,20 @@ +parameter unit; +storage unit; +code { DROP; + UNIT; # starting storage for contract + AMOUNT; # Push the starting balance + NONE key_hash; # No delegate + CREATE_CONTRACT # Create the contract + { parameter unit ; + storage unit ; + code + { CDR; + NIL operation; + PAIR; } }; + DIP { DROP }; + # invalid PACK + PACK; + DROP; + UNIT; + NIL operation; + PAIR; } diff --git a/src/bin_client/test/contracts/mini_scenarios/authentication.tz b/src/bin_client/test/contracts/mini_scenarios/authentication.tz new file mode 100644 index 0000000000000000000000000000000000000000..021bbd26361a4c38df8cc3a2c7d0748f9ad6420a --- /dev/null +++ b/src/bin_client/test/contracts/mini_scenarios/authentication.tz @@ -0,0 +1,30 @@ +/* + +This contract is an example of using a cryptographic signature to +handle authentication. A public key is stored, and only the owner of +the secret key associated to this public key can interact with the +contract. She is allowed to perform any list of operations by sending +them wrapped in a lambda to the contract with a cryptographic +signature. + +To ensure that each signature is used only once and is not replayed by +an attacker, not only the lambda is signed but also the unique +identifier of the contract (a pair of the contract address and the +chain id) and a counter that is incremented at each successful call. + +More precisely, the signature should check against pack ((chain_id, +self) (param, counter)). + +*/ +parameter (pair (lambda unit (list operation)) signature); +storage (pair (nat %counter) key); +code + { + UNPPAIPAIR; + DUUUP; DUUP ; SELF; CHAIN_ID ; PPAIPAIR; PACK; + DIP { SWAP }; DUUUUUP ; DIP { SWAP }; + DUUUP; DIP {CHECK_SIGNATURE}; SWAP; IF {DROP} {FAILWITH}; + UNIT; EXEC; + DIP { PUSH nat 1; ADD }; + PAPAIR + } diff --git a/src/bin_client/test/contracts/mini_scenarios/big_map_entrypoints.tz b/src/bin_client/test/contracts/mini_scenarios/big_map_entrypoints.tz new file mode 100644 index 0000000000000000000000000000000000000000..d49e6257167affbe689e6b4654ccfdf4cc828240 --- /dev/null +++ b/src/bin_client/test/contracts/mini_scenarios/big_map_entrypoints.tz @@ -0,0 +1,31 @@ +storage + (pair (big_map string nat) (big_map string nat)) ; +parameter + (or (unit %default) + (or (or %mem (string %mem_left) (string %mem_right)) + (or (or %add (pair %add_left string nat) (pair %add_right string nat)) + (or %rem (string %rem_left) (string %rem_right))))) ; +code { UNPAIR ; + IF_LEFT + { DROP ; + DUP ; CAR ; + PUSH mutez 0 ; + NONE key_hash ; + CREATE_CONTRACT + { parameter string ; + storage (big_map string nat) ; + code { UNPAIR ; DROP ; NIL operation ; PAIR }} ; + DIP { DROP } ; + NIL operation ; SWAP ; CONS ; PAIR } + { IF_LEFT + { IF_LEFT + { DIP { UNPAIR } ; DIP { DUP } ; MEM ; ASSERT } + { DIP { UNPAIR ; SWAP } ; DIP { DUP } ; MEM ; ASSERT ; SWAP } } + { IF_LEFT + { IF_LEFT + { UNPAIR ; DIIP { UNPAIR } ; DIP { SOME } ; UPDATE } + { UNPAIR ; DIIP { UNPAIR ; SWAP } ; DIP { SOME } ; UPDATE ; SWAP } } + { IF_LEFT + { DIP { UNPAIR } ; DIP { NONE nat } ; UPDATE } + { DIP { UNPAIR ; SWAP } ; DIP { NONE nat } ; UPDATE ; SWAP } } } ; + PAIR ; NIL operation ; PAIR } } diff --git a/src/bin_client/test/contracts/mini_scenarios/big_map_magic.tz b/src/bin_client/test/contracts/mini_scenarios/big_map_magic.tz new file mode 100644 index 0000000000000000000000000000000000000000..f4e36f639bff585fc876dc87fa08cd2e575b1a38 --- /dev/null +++ b/src/bin_client/test/contracts/mini_scenarios/big_map_magic.tz @@ -0,0 +1,41 @@ +# this contracts handles two big_maps +storage + (or (pair (big_map string string) (big_map string string)) unit) ; +parameter + # it has 5 entry points + # swap: swaps the two maps. + (or (unit %swap) + # reset: resets storage, either to a new pair of maps, or to unit + (or (or %reset (pair (big_map string string) (big_map string string)) unit) + # import: drops the existing storage and creates two maps + # from the given lists of string pairs. + (or (pair %import (list (pair string string)) (list (pair string string))) + # add: adds the given list of key - value pairs into the + # first map + (or (list %add (pair string string)) + # rem: removes the given list of key - value pairs + # from the first map + (list %rem string))))) ; +code { UNPAIR ; + IF_LEFT + { DROP ; ASSERT_LEFT ; UNPAIR ; SWAP ; PAIR ; LEFT unit } + { IF_LEFT + { SWAP ; DROP } + { IF_LEFT + { DIP { ASSERT_RIGHT ; DROP } ; + UNPAIR ; + DIP { EMPTY_BIG_MAP string string } ; + ITER { UNPAIR ; DIP { SOME } ; UPDATE } ; + SWAP ; + DIP { EMPTY_BIG_MAP string string } ; + ITER { UNPAIR ; DIP { SOME } ; UPDATE } ; + SWAP ; + PAIR ; LEFT unit } + { IF_LEFT + { DIP { ASSERT_LEFT ; UNPAIR } ; + ITER { UNPAIR ; DIP { SOME } ; UPDATE } ; + PAIR ; LEFT unit } + { DIP { ASSERT_LEFT ; UNPAIR } ; + ITER { DIP { NONE string } ; UPDATE } ; + PAIR ; LEFT unit } }} } ; + NIL operation ; PAIR } \ No newline at end of file diff --git a/src/bin_client/test/contracts/mini_scenarios/create_account.tz b/src/bin_client/test/contracts/mini_scenarios/create_account.tz deleted file mode 100644 index 6d0d261ec4eced95714fba5811a4f64f16091422..0000000000000000000000000000000000000000 --- a/src/bin_client/test/contracts/mini_scenarios/create_account.tz +++ /dev/null @@ -1,12 +0,0 @@ -parameter (or key_hash address) ; -storage (option (contract unit)) ; -code { CAR; - IF_LEFT - { DIP { PUSH mutez 100000000 ; PUSH bool False ; NONE key_hash }; - CREATE_ACCOUNT ; - DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; - NIL operation ; SWAP ; CONS } ; - CONS ; NONE (contract unit) ; SWAP ; PAIR } - { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ; - CONTRACT unit ; DUP ; IF_SOME { DROP } { FAIL } ; - NIL operation ; PAIR } } ; diff --git a/src/bin_client/test/contracts/mini_scenarios/create_contract.tz b/src/bin_client/test/contracts/mini_scenarios/create_contract.tz index a162044ac62bd8c00c25bef6726f1e77b1c8e9f2..0d09a1fdfca61fdf33504ef20bdc9d0d209b6aaf 100644 --- a/src/bin_client/test/contracts/mini_scenarios/create_contract.tz +++ b/src/bin_client/test/contracts/mini_scenarios/create_contract.tz @@ -1,18 +1,33 @@ -parameter (or key_hash address); -storage unit; -code { CAR; - IF_LEFT - { DIP { PUSH string "dummy"; - PUSH mutez 100000000 ; PUSH bool False ; - PUSH bool False ; NONE key_hash } ; +/* +- param: None: + + Create a contract then perform a recursive call on Some [addr] where + [addr] is the address of the newly created contract. + + The created contract simply stores its parameter (a string). It is + initialized with the storage "dummy" and has an initial balance of + 100tz. It has no delegate so these 100tz are totally frozen. + +- param: Some [addr]: + + Check that the sender is self, call the contract at address [addr] + with param "abcdefg" transferring 0tz. + +*/ +parameter (option address) ; +storage unit ; +code { CAR ; + IF_NONE + { PUSH string "dummy" ; + PUSH mutez 100000000 ; NONE key_hash ; CREATE_CONTRACT { parameter string ; storage string ; code { CAR ; NIL operation ; PAIR } } ; - DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; + DIP { SOME ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS } ; CONS ; UNIT ; SWAP ; PAIR } { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ; CONTRACT string ; IF_SOME {} { FAIL } ; PUSH mutez 0 ; PUSH string "abcdefg" ; TRANSFER_TOKENS ; - NIL operation; SWAP; CONS ; UNIT ; SWAP ; PAIR } }; + NIL operation; SWAP; CONS ; UNIT ; SWAP ; PAIR } } ; \ No newline at end of file diff --git a/src/bin_client/test/contracts/mini_scenarios/default_account.tz b/src/bin_client/test/contracts/mini_scenarios/default_account.tz index db9f01156c6822310dbe2b792f76ab0c6f882f6f..74e7693d7ba52ecc77d7b20e24590cbae32570cd 100644 --- a/src/bin_client/test/contracts/mini_scenarios/default_account.tz +++ b/src/bin_client/test/contracts/mini_scenarios/default_account.tz @@ -1,3 +1,7 @@ +/* +Send 100 tz to the implicit account given as parameter. +*/ + parameter key_hash; storage unit; code {DIP{UNIT}; CAR; IMPLICIT_ACCOUNT; diff --git a/src/bin_client/test/contracts/mini_scenarios/lockup.tz b/src/bin_client/test/contracts/mini_scenarios/lockup.tz index a68a8628f25c846a3fd4460fe6278248d0113ab8..eb238fd654fe1dae92ebd0917519f5d0027409da 100644 --- a/src/bin_client/test/contracts/mini_scenarios/lockup.tz +++ b/src/bin_client/test/contracts/mini_scenarios/lockup.tz @@ -1,5 +1,5 @@ parameter unit; -storage (pair timestamp (pair mutez (contract unit))); +storage (pair timestamp (pair mutez address)); code { CDR; # Ignore the parameter DUP; # Duplicate the storage CAR; # Get the timestamp @@ -12,6 +12,7 @@ code { CDR; # Ignore the parameter DUP; # Duplicate the transfer information CAR; # Get the amount of the transfer on top of the stack DIP{CDR}; # Put the contract underneath it + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT; # Put the contract's argument type on top of the stack TRANSFER_TOKENS; # Emit the transfer NIL operation; SWAP; CONS;# Make a singleton list of internal operations diff --git a/src/bin_client/test/contracts/mini_scenarios/multiple_entrypoints_counter.tz b/src/bin_client/test/contracts/mini_scenarios/multiple_entrypoints_counter.tz new file mode 100644 index 0000000000000000000000000000000000000000..740190697171aa8c5944e5b361127d75d5ba74aa --- /dev/null +++ b/src/bin_client/test/contracts/mini_scenarios/multiple_entrypoints_counter.tz @@ -0,0 +1,29 @@ +{ parameter unit ; + storage (option address) ; + code { SENDER ; SELF ; ADDRESS ; + IFCMPEQ + { CDR ; ASSERT_SOME ; + DIP { NIL operation } ; + DUP ; CONTRACT %add unit ; ASSERT_NONE ; + DUP ; CONTRACT %fact nat ; ASSERT_NONE ; + DUP ; CONTRACT %add nat ; ASSERT_SOME ; PUSH mutez 0 ; PUSH nat 12 ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; + DUP ; CONTRACT unit ; ASSERT_SOME ; PUSH mutez 0 ; PUSH unit Unit ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; + DUP ; CONTRACT %sub nat ; ASSERT_SOME ; PUSH mutez 0 ; PUSH nat 3 ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; + DUP ; CONTRACT %add nat ; ASSERT_SOME ; PUSH mutez 0 ; PUSH nat 5 ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; + DROP ; DIP { NONE address } ; PAIR } + { CAR ; DUP ; + DIP + { DIP { PUSH int 0 ; PUSH mutez 0 ; NONE key_hash } ; + DROP ; + CREATE_CONTRACT + { parameter (or (or (nat %add) (nat %sub)) (unit %default)) ; + storage int ; + code { AMOUNT ; PUSH mutez 0 ; ASSERT_CMPEQ ; + UNPAIR ; + IF_LEFT + { IF_LEFT { ADD } { SWAP ; SUB } } + { DROP ; DROP ; PUSH int 0 } ; + NIL operation ; PAIR } } } ; + DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; + NIL operation ; SWAP ; CONS ; SWAP ; CONS ; + DIP { SOME } ; PAIR } } } \ No newline at end of file diff --git a/src/bin_client/test/contracts/mini_scenarios/replay.tz b/src/bin_client/test/contracts/mini_scenarios/replay.tz index d00e368d9e1d62780133279dc799c1c72b6b8fd1..73ac145abae36ad2dcbd012968456fc25059e139 100644 --- a/src/bin_client/test/contracts/mini_scenarios/replay.tz +++ b/src/bin_client/test/contracts/mini_scenarios/replay.tz @@ -1,3 +1,4 @@ +# This contract always fail because it tries to execute twice the same operation parameter unit ; storage unit ; code { CDR ; NIL operation ; diff --git a/src/bin_client/test/contracts/mini_scenarios/reveal_signed_preimage.tz b/src/bin_client/test/contracts/mini_scenarios/reveal_signed_preimage.tz index 520707c60e2b5bb495d47890335cea534d21f36a..1a7e97eb8a68cd7d89b28be6b243107b18494c2f 100644 --- a/src/bin_client/test/contracts/mini_scenarios/reveal_signed_preimage.tz +++ b/src/bin_client/test/contracts/mini_scenarios/reveal_signed_preimage.tz @@ -1,7 +1,13 @@ parameter (pair bytes signature) ; storage (pair bytes key) ; -code { DUP ; UNPAIR ; CAR ; SHA256 ; DIP { CAR } ; ASSERT_CMPEQ ; +code { + #check that sha256(param.bytes) == storage.bytes + DUP ; UNPAIR ; CAR; SHA256; DIP { CAR } ; ASSERT_CMPEQ ; + + # check that the sig is a valid signature of the preimage DUP ; UNPAIR ; SWAP ; DIP { UNPAIR ; SWAP } ; CDR ; CHECK_SIGNATURE ; ASSERT ; + + # send all our tokens to the implicit account corresponding to the stored public key CDR ; DUP ; CDR ; HASH_KEY ; IMPLICIT_ACCOUNT ; BALANCE ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; PAIR } \ No newline at end of file diff --git a/src/bin_client/test/contracts/mini_scenarios/weather_insurance.tz b/src/bin_client/test/contracts/mini_scenarios/weather_insurance.tz index 858fe918fa504d2fe3246fdaee7daad8fd184503..e7e99e0183355889dd9bbf2087d4a885e550c37d 100644 --- a/src/bin_client/test/contracts/mini_scenarios/weather_insurance.tz +++ b/src/bin_client/test/contracts/mini_scenarios/weather_insurance.tz @@ -1,7 +1,7 @@ parameter (pair (signature %signed_weather_data) (nat :rain %actual_level)); # (pair (under_key over_key) (pair weather_service_key (pair rain_level days_in_future))) -storage (pair (pair (contract %under_key unit) - (contract %over_key unit)) +storage (pair (pair (address %under_key) + (address %over_key)) (pair (nat :rain %rain_level) (key %weather_service_key))); code { DUP; DUP; CAR; MAP_CDR{PACK ; BLAKE2B}; @@ -13,6 +13,7 @@ code { DUP; DUP; DIP{CADR %actual_level}; # Get actual rain CDDAR %rain_level; # Get rain threshold CMPLT; IF {CAR %under_key} {CDR %over_key}; # Select contract to receive tokens + CONTRACT unit ; ASSERT_SOME ; BALANCE; UNIT ; TRANSFER_TOKENS @trans.op; # Setup and execute transfer NIL operation ; SWAP ; CONS ; PAIR }; diff --git a/src/bin_client/test/contracts/mini_scenarios/xcat.tz b/src/bin_client/test/contracts/mini_scenarios/xcat.tz index 254f4d825283bf01a45e2314144a54f4f7cc552c..83e6c7ac1d50fb81328152ca69aba539c96934b3 100644 --- a/src/bin_client/test/contracts/mini_scenarios/xcat.tz +++ b/src/bin_client/test/contracts/mini_scenarios/xcat.tz @@ -9,8 +9,10 @@ code { # There's a temptation to use @storage to parametrize # a contract but, in general, there's no reason to encumber # @storage with immutable values. - PUSH @from (contract unit) "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; #changeme - PUSH @to (contract unit) "tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN"; #changeme + PUSH @from key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; #changeme + IMPLICIT_ACCOUNT ; + PUSH @to key_hash "tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN"; #changeme + IMPLICIT_ACCOUNT ; PUSH @target_hash bytes 0x123456; #changeme PUSH @deadline timestamp "2018-08-08 00:00:00Z"; #changeme }; diff --git a/src/bin_client/test/contracts/non_regression/bug_262.tz b/src/bin_client/test/contracts/non_regression/bug_262.tz new file mode 100644 index 0000000000000000000000000000000000000000..63475c5ac18525abe6c0467098039ba75a4e2edc --- /dev/null +++ b/src/bin_client/test/contracts/non_regression/bug_262.tz @@ -0,0 +1,5 @@ +{ parameter unit ; + storage unit ; + code { DROP ; + LAMBDA unit unit {} ; UNIT ; EXEC ; + NIL operation ; PAIR } } \ No newline at end of file diff --git a/src/bin_client/test/contracts/opcodes/abs.tz b/src/bin_client/test/contracts/opcodes/abs.tz new file mode 100644 index 0000000000000000000000000000000000000000..d03d0883fe73e67ec19a02e24365c00ab583a0d7 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/abs.tz @@ -0,0 +1,5 @@ +parameter nat; +storage unit; +code { CAR; + DUP; NEG; ABS; COMPARE; ASSERT_EQ; + UNIT; NIL operation; PAIR} diff --git a/src/bin_client/test/contracts/opcodes/add.tz b/src/bin_client/test/contracts/opcodes/add.tz new file mode 100644 index 0000000000000000000000000000000000000000..cbefea08a7a422651a01695368440733b093eb05 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/add.tz @@ -0,0 +1,25 @@ +parameter unit; +storage unit; +code + { + CAR; + + PUSH int 2; PUSH int 2; ADD; PUSH int 4; ASSERT_CMPEQ; + PUSH int 2; PUSH int 2; ADD; PUSH int 4; ASSERT_CMPEQ; + PUSH int 2; PUSH nat 2; ADD; PUSH int 4; ASSERT_CMPEQ; + PUSH nat 2; PUSH int 2; ADD; PUSH int 4; ASSERT_CMPEQ; + PUSH nat 2; PUSH nat 2; ADD; PUSH nat 4; ASSERT_CMPEQ; + + # Offset a timestamp by 60 seconds + PUSH int 60; PUSH timestamp "2019-09-09T12:08:37Z"; ADD; + PUSH timestamp "2019-09-09T12:09:37Z"; ASSERT_CMPEQ; + + PUSH timestamp "2019-09-09T12:08:37Z"; PUSH int 60; ADD; + PUSH timestamp "2019-09-09T12:09:37Z"; ASSERT_CMPEQ; + + PUSH mutez 1000; PUSH mutez 1000; ADD; + PUSH mutez 2000; ASSERT_CMPEQ; + + NIL operation; + PAIR; + } diff --git a/src/bin_client/test/contracts/opcodes/address.tz b/src/bin_client/test/contracts/opcodes/address.tz new file mode 100644 index 0000000000000000000000000000000000000000..7e6bcdec337b40cdd784165818713bccc652d6f4 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/address.tz @@ -0,0 +1,3 @@ +parameter (contract unit); +storage (option address); +code {CAR; ADDRESS; SOME; NIL operation; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/and_binary.tz b/src/bin_client/test/contracts/opcodes/and_binary.tz new file mode 100644 index 0000000000000000000000000000000000000000..96f60082c713bcefd9eca89e2f890a8251ce8c78 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/and_binary.tz @@ -0,0 +1,27 @@ +parameter unit; +storage unit; +code { DROP; + + # 0101 & 0110 = 0100 + PUSH nat 5; PUSH nat 6; AND; PUSH nat 4; ASSERT_CMPEQ; + + # 0110 & 0101 = 0100 + PUSH nat 6; PUSH int 5; AND; PUSH nat 4; ASSERT_CMPEQ; + + # Negative numbers are represented as with a initial virtual + # infinite series of 1's. + # Hence, AND with -1 (1111...) is identity: + + # 12 = ...1100 + # & -1 = ...1111 + # ---- + # = 12 = ...1100 + PUSH nat 12; PUSH int -1; AND; PUSH nat 12; ASSERT_CMPEQ; + + # 12 = ...0001100 + # & -5 = ...1111011 + # ----------------- + # 8 = ...0001000 + PUSH nat 12; PUSH int -5; AND; PUSH nat 8; ASSERT_CMPEQ; + + UNIT; NIL @noop operation; PAIR; }; diff --git a/src/bin_client/test/contracts/opcodes/and_logical_1.tz b/src/bin_client/test/contracts/opcodes/and_logical_1.tz new file mode 100644 index 0000000000000000000000000000000000000000..20743c0bfdf9118f513ee58d7191c94ec2a71be8 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/and_logical_1.tz @@ -0,0 +1,3 @@ +parameter (pair bool bool); +storage bool; +code { CAR ; UNPAIR; AND @and; NIL @noop operation; PAIR; }; diff --git a/src/bin_client/test/contracts/opcodes/big_map_mem_nat.tz b/src/bin_client/test/contracts/opcodes/big_map_mem_nat.tz new file mode 100644 index 0000000000000000000000000000000000000000..71ecaf2c4a754ea20a1f802f0e3c6401914a7e5e --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/big_map_mem_nat.tz @@ -0,0 +1,7 @@ +parameter nat; +storage (pair (big_map nat nat) (option bool)) ; +# stores (map, Some flag) where flag = parameter is a member of +# the map in first component of storage +code { UNPAIR; + DIP { CAR; DUP }; + MEM; SOME; SWAP; PAIR; NIL operation; PAIR;} diff --git a/src/bin_client/test/contracts/opcodes/big_map_mem_string.tz b/src/bin_client/test/contracts/opcodes/big_map_mem_string.tz new file mode 100644 index 0000000000000000000000000000000000000000..8c557f7dc1f8ff5ee260794ab094576252c56724 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/big_map_mem_string.tz @@ -0,0 +1,7 @@ +parameter string; +storage (pair (big_map string nat) (option bool)) ; +# stores (map, Some flag) where flag = parameter is a member of +# the map in first component of storage +code { UNPAIR; + DIP { CAR; DUP }; + MEM; SOME; SWAP; PAIR; NIL operation; PAIR;} diff --git a/src/bin_client/test/contracts/opcodes/big_map_to_self.tz b/src/bin_client/test/contracts/opcodes/big_map_to_self.tz new file mode 100644 index 0000000000000000000000000000000000000000..6a9442b9f3e5e149af21b348323b212ad8ea664c --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/big_map_to_self.tz @@ -0,0 +1,22 @@ +parameter (or (pair %have_fun (big_map string nat) unit) (unit %default)); +storage (big_map string nat); +code { + UNPAIR; + DIP {NIL operation}; + IF_LEFT { + DROP + } + { + DROP; + SELF %have_fun; + PUSH mutez 0; + DUP 4; + PUSH (option nat) (Some 8); + PUSH string "hahaha"; + UPDATE; + UNIT; SWAP; PAIR; + TRANSFER_TOKENS; + CONS + }; + PAIR + } diff --git a/src/bin_client/test/contracts/opcodes/car.tz b/src/bin_client/test/contracts/opcodes/car.tz new file mode 100644 index 0000000000000000000000000000000000000000..033d5332c1b23c45b9d2087efddaee945449fcfe --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/car.tz @@ -0,0 +1,3 @@ +parameter (pair nat nat); +storage nat; +code { CAR; CAR ; NIL operation ; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/cdr.tz b/src/bin_client/test/contracts/opcodes/cdr.tz new file mode 100644 index 0000000000000000000000000000000000000000..68fd61492589c67bd7eec08e115fb78168698895 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/cdr.tz @@ -0,0 +1,3 @@ +parameter (pair nat nat); +storage nat; +code { CAR; CDR ; NIL operation ; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/chain_id.tz b/src/bin_client/test/contracts/opcodes/chain_id.tz new file mode 100644 index 0000000000000000000000000000000000000000..783d13fa0afc22f0b8e9701152e1420635cf7cb8 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/chain_id.tz @@ -0,0 +1,3 @@ +parameter unit; +storage unit; +code { CHAIN_ID; DROP; CAR; NIL operation; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/chain_id_store.tz b/src/bin_client/test/contracts/opcodes/chain_id_store.tz new file mode 100644 index 0000000000000000000000000000000000000000..11e57fd210c76ca22b4cdf912e366a70eed91669 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/chain_id_store.tz @@ -0,0 +1,3 @@ +parameter unit; +storage (option chain_id); +code { DROP; CHAIN_ID; SOME; NIL operation; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/compare.tz b/src/bin_client/test/contracts/opcodes/compare.tz new file mode 100644 index 0000000000000000000000000000000000000000..963215fb46cd625a11ee6c1d1c27cbc527a09e18 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/compare.tz @@ -0,0 +1,52 @@ +parameter unit; +storage unit; +code { + DROP; + + # bool + PUSH bool True; DUP; COMPARE; ASSERT_EQ; + PUSH bool False; DUP; COMPARE; ASSERT_EQ; + PUSH bool False; PUSH bool True; COMPARE; ASSERT_GT; + PUSH bool True; PUSH bool False; COMPARE; ASSERT_LT; + + # bytes + PUSH bytes 0xAABBCC; DUP; COMPARE; ASSERT_EQ; + PUSH bytes 0x; PUSH bytes 0x; COMPARE; ASSERT_EQ; + PUSH bytes 0x; PUSH bytes 0x01; COMPARE; ASSERT_GT; + PUSH bytes 0x01; PUSH bytes 0x02; COMPARE; ASSERT_GT; + PUSH bytes 0x02; PUSH bytes 0x01; COMPARE; ASSERT_LT; + + # int + PUSH int 1; DUP; COMPARE; ASSERT_EQ; + PUSH int 10; PUSH int 5; COMPARE; ASSERT_LT; + PUSH int -4; PUSH int 1923; COMPARE; ASSERT_GT; + + # nat + PUSH nat 1; DUP; COMPARE; ASSERT_EQ; + PUSH nat 10; PUSH nat 5; COMPARE; ASSERT_LT; + PUSH nat 4; PUSH nat 1923; COMPARE; ASSERT_GT; + + # key_hash + PUSH key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; DUP; COMPARE; ASSERT_EQ; + PUSH key_hash "tz1ddb9NMYHZi5UzPdzTZMYQQZoMub195zgv"; PUSH key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; COMPARE; ASSERT_LT; + PUSH key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; PUSH key_hash "tz1ddb9NMYHZi5UzPdzTZMYQQZoMub195zgv"; COMPARE; ASSERT_GT; + + # mutez + PUSH mutez 1; DUP; COMPARE; ASSERT_EQ; + PUSH mutez 10; PUSH mutez 5; COMPARE; ASSERT_LT; + PUSH mutez 4; PUSH mutez 1923; COMPARE; ASSERT_GT; + + # string + PUSH string "AABBCC"; DUP; COMPARE; ASSERT_EQ; + PUSH string ""; PUSH string ""; COMPARE; ASSERT_EQ; + PUSH string ""; PUSH string "a"; COMPARE; ASSERT_GT; + PUSH string "a"; PUSH string "b"; COMPARE; ASSERT_GT; + PUSH string "b"; PUSH string "a"; COMPARE; ASSERT_LT; + + # timestamp + PUSH timestamp "2019-09-16T08:38:05Z"; DUP; COMPARE; ASSERT_EQ; + PUSH timestamp "2017-09-16T08:38:04Z"; PUSH timestamp "2019-09-16T08:38:05Z"; COMPARE; ASSERT_GT; + PUSH timestamp "2019-09-16T08:38:05Z"; PUSH timestamp "2019-09-16T08:38:04Z"; COMPARE; ASSERT_LT; + + UNIT; NIL operation; PAIR; + } diff --git a/src/bin_client/test/contracts/opcodes/comparisons.tz b/src/bin_client/test/contracts/opcodes/comparisons.tz new file mode 100644 index 0000000000000000000000000000000000000000..c603f07339ce7bc6f62bf73c63bf7967ccf79c05 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/comparisons.tz @@ -0,0 +1,15 @@ +parameter (list int); +storage (list (list bool)); +code { + CAR; + + NIL (list bool); + DIP {DUP; MAP { EQ; };}; SWAP; CONS; + DIP {DUP; MAP { NEQ; };}; SWAP; CONS; + DIP {DUP; MAP { LE; };}; SWAP; CONS; + DIP {DUP; MAP { LT; };}; SWAP; CONS; + DIP {DUP; MAP { GE; };}; SWAP; CONS; + DIP {MAP { GT; };}; SWAP; CONS; + + NIL operation; PAIR; + } diff --git a/src/bin_client/test/contracts/opcodes/concat_hello_bytes.tz b/src/bin_client/test/contracts/opcodes/concat_hello_bytes.tz new file mode 100644 index 0000000000000000000000000000000000000000..55f8ab7a216ba24a3dc4e21f6648cfbf0abdea29 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/concat_hello_bytes.tz @@ -0,0 +1,4 @@ +parameter (list bytes); +storage (list bytes); +code{ CAR; + MAP { PUSH bytes 0xFF; CONCAT }; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/cons.tz b/src/bin_client/test/contracts/opcodes/cons.tz new file mode 100644 index 0000000000000000000000000000000000000000..5189b47c36b417dda6f3e89f31a4f653970e8fad --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/cons.tz @@ -0,0 +1,3 @@ +parameter int; +storage (list int); +code { UNPAIR; CONS; NIL operation; PAIR; }; diff --git a/src/bin_client/test/contracts/opcodes/contract.tz b/src/bin_client/test/contracts/opcodes/contract.tz new file mode 100644 index 0000000000000000000000000000000000000000..939337918d1ce883ee782fc92a20b8a9c8247aff --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/contract.tz @@ -0,0 +1,11 @@ +parameter address; +storage unit; +code { + CAR; + CONTRACT unit; + ASSERT_SOME; + DROP; + UNIT; + NIL operation; + PAIR + }; diff --git a/src/bin_client/test/contracts/opcodes/create_contract.tz b/src/bin_client/test/contracts/opcodes/create_contract.tz new file mode 100644 index 0000000000000000000000000000000000000000..d5a2fe4760fe0a1aad1d5558cf8f629ba581c343 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/create_contract.tz @@ -0,0 +1,14 @@ +parameter unit; +storage (option address); +code { DROP; + UNIT; # starting storage for contract + AMOUNT; # Push the starting balance + NONE key_hash; # No delegate + CREATE_CONTRACT # Create the contract + { parameter unit ; + storage unit ; + code + { CDR; + NIL operation; + PAIR; } }; + DROP; SOME; NIL operation; PAIR} # Ending calling convention stuff diff --git a/src/bin_client/test/contracts/opcodes/dig_eq.tz b/src/bin_client/test/contracts/opcodes/dig_eq.tz new file mode 100644 index 0000000000000000000000000000000000000000..fff548bbf59719c498c855ccaa1de8b8283355a3 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/dig_eq.tz @@ -0,0 +1,14 @@ +parameter (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat nat)))))))))))))))); +storage unit; +# this contract receives a 17-tuple, unpairs it, reverses the order, reverses it again, and pairs it and verifies that the result is the same as the original tuple. +code { CAR; + DUP; + + UNPAPAPAPAPAPAPAPAPAPAPAPAPAPAPAPAIR; + DIG 0; DIG 1; DIG 2; DIG 3; DIG 4; DIG 5; DIG 6; DIG 7; DIG 8; DIG 9; DIG 10; DIG 11; DIG 12; DIG 13; DIG 14; DIG 15; DIG 16; + # PUSH nat 1; ADD; + DIG 0; DIG 1; DIG 2; DIG 3; DIG 4; DIG 5; DIG 6; DIG 7; DIG 8; DIG 9; DIG 10; DIG 11; DIG 12; DIG 13; DIG 14; DIG 15; DIG 16; + PAPAPAPAPAPAPAPAPAPAPAPAPAPAPAPAIR; + ASSERT_CMPEQ; + + UNIT; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/dign.tz b/src/bin_client/test/contracts/opcodes/dign.tz new file mode 100644 index 0000000000000000000000000000000000000000..ec8a339dd48c3c7318c72dfbce9b562839df48e1 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/dign.tz @@ -0,0 +1,3 @@ +parameter (pair (pair (pair (pair nat nat) nat) nat) nat); +storage nat; +code {CAR; UNPAIR ; UNPAIR ; UNPAIR ; UNPAIR ; DIG 4 ; DIP { DROP ; DROP ; DROP ; DROP } ; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/dip.tz b/src/bin_client/test/contracts/opcodes/dip.tz new file mode 100644 index 0000000000000000000000000000000000000000..f0c32a838747fe221cbb5570ae32383f6c8fb5d0 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/dip.tz @@ -0,0 +1,8 @@ +parameter (pair nat nat); +storage (pair nat nat); +code{ + CAR; UNPAIR; + DUP; DIP { ADD }; + PAIR; + NIL operation; + PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/dipn.tz b/src/bin_client/test/contracts/opcodes/dipn.tz new file mode 100644 index 0000000000000000000000000000000000000000..55d088e5518f3bff8321669c94bbd1689a00c796 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/dipn.tz @@ -0,0 +1,3 @@ +parameter (pair (pair (pair (pair nat nat) nat) nat) nat); +storage nat; +code {CAR; UNPAIR ; UNPAIR ; UNPAIR ; UNPAIR ; DIP 5 {PUSH nat 6} ; DROP ; DROP ; DROP ; DROP ; DROP ; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/dropn.tz b/src/bin_client/test/contracts/opcodes/dropn.tz new file mode 100644 index 0000000000000000000000000000000000000000..4b5379b3a3b3ee3f12d1ff9110d58b2683aa953e --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/dropn.tz @@ -0,0 +1,3 @@ +parameter (pair (pair (pair (pair nat nat) nat) nat) nat); +storage nat; +code {CAR; UNPAIR ; UNPAIR ; UNPAIR ; UNPAIR ; DROP 4 ; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/dugn.tz b/src/bin_client/test/contracts/opcodes/dugn.tz new file mode 100644 index 0000000000000000000000000000000000000000..521c052f1fcd593c2707ae9698df9992cab55367 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/dugn.tz @@ -0,0 +1,3 @@ +parameter (pair (pair (pair (pair nat nat) nat) nat) nat); +storage nat; +code {CAR; UNPAIR ; UNPAIR ; UNPAIR ; UNPAIR ; DUG 4 ; DROP ; DROP ; DROP ; DROP ; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/ediv.tz b/src/bin_client/test/contracts/opcodes/ediv.tz new file mode 100644 index 0000000000000000000000000000000000000000..ee577a4dc4a0f92279b4390be89c2130afd811a0 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/ediv.tz @@ -0,0 +1,13 @@ +parameter (pair int int); +storage (pair (option (pair int nat)) (pair (option (pair int nat)) (pair (option (pair int nat)) (option (pair nat nat))))); +code { CAR; + # :: nat : nat : 'S -> option (pair nat nat) : 'S + DUP; UNPAIR; ABS; DIP { ABS; }; EDIV; SWAP; + # :: nat : int : 'S -> option (pair int nat) : 'S + DUP; UNPAIR; ABS; EDIV; SWAP; + # :: int : nat : 'S -> option (pair int nat) : 'S + DUP; UNPAIR; DIP { ABS; }; EDIV; SWAP; + # :: int : int : 'S -> option (pair int nat) : 'S + UNPAIR; EDIV; + PAPAPAIR; + NIL operation; PAIR} diff --git a/src/bin_client/test/contracts/opcodes/ediv_mutez.tz b/src/bin_client/test/contracts/opcodes/ediv_mutez.tz new file mode 100644 index 0000000000000000000000000000000000000000..2df73dd4a0e3b6cdd3a2451b82f21c7751ece275 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/ediv_mutez.tz @@ -0,0 +1,12 @@ +parameter (pair mutez (or mutez nat)); +storage (or (option (pair nat mutez)) (option (pair mutez mutez))); +code { CAR; + UNPAIR; + SWAP; + IF_LEFT { + SWAP; EDIV; LEFT (option (pair mutez mutez)); + } + { + SWAP; EDIV; RIGHT (option (pair nat mutez)); + }; + NIL operation; PAIR} diff --git a/src/bin_client/test/contracts/opcodes/get_big_map_value.tz b/src/bin_client/test/contracts/opcodes/get_big_map_value.tz new file mode 100644 index 0000000000000000000000000000000000000000..4ca52343d45afabdfa0b19671d45bbf74b642de2 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/get_big_map_value.tz @@ -0,0 +1,6 @@ +parameter string; +storage (pair (big_map string string) (option string)); +# retrieves the values stored in the big_map on the left side of the +# pair at the key denoted by the parameter and puts it in the right +# hand side of the storage +code {DUP; CAR; DIP{CDAR; DUP}; GET; SWAP; PAIR; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/int.tz b/src/bin_client/test/contracts/opcodes/int.tz new file mode 100644 index 0000000000000000000000000000000000000000..3f199881392ae45abe9ae7332c5b63ba6b735b36 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/int.tz @@ -0,0 +1,5 @@ +parameter nat; +storage (option int); +# this contract takes a natural number as parameter, converts it to an +# integer and stores it. +code { CAR; INT; SOME; NIL operation; PAIR }; diff --git a/src/bin_client/test/contracts/opcodes/list_size.tz b/src/bin_client/test/contracts/opcodes/list_size.tz new file mode 100644 index 0000000000000000000000000000000000000000..6ced12799187fa76705a31e3f07bb9dc7c493d6b --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/list_size.tz @@ -0,0 +1,3 @@ +parameter (list int); +storage nat; +code {CAR; SIZE; NIL operation; PAIR} diff --git a/src/bin_client/test/contracts/opcodes/map_map.tz b/src/bin_client/test/contracts/opcodes/map_map.tz new file mode 100644 index 0000000000000000000000000000000000000000..4acbd63c32c4d5409e051c6c1eed5703c19c9a10 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/map_map.tz @@ -0,0 +1,8 @@ +parameter nat; +storage (map string nat); +# this contract adds the value passed by parameter to each entry in +# the stored map. +code { UNPAIR; SWAP; + MAP { CDR; DIP {DUP}; ADD; }; + DIP { DROP; }; + NIL operation; PAIR; } diff --git a/src/bin_client/test/contracts/opcodes/map_mem_nat.tz b/src/bin_client/test/contracts/opcodes/map_mem_nat.tz new file mode 100644 index 0000000000000000000000000000000000000000..0c245d7e0a652d8430d71d47a1511e6a0d9c874f --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/map_mem_nat.tz @@ -0,0 +1,7 @@ +parameter nat; +storage (pair (map nat nat) (option bool)) ; +# stores (map, Some flag) where flag = parameter is a member of +# the map in first component of storage +code { UNPAIR; + DIP { CAR; DUP }; + MEM; SOME; SWAP; PAIR; NIL operation; PAIR;} diff --git a/src/bin_client/test/contracts/opcodes/map_mem_string.tz b/src/bin_client/test/contracts/opcodes/map_mem_string.tz new file mode 100644 index 0000000000000000000000000000000000000000..3fa5cd5b579f534b9df0b33d5d46d525b56fbbe8 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/map_mem_string.tz @@ -0,0 +1,7 @@ +parameter string; +storage (pair (map string nat) (option bool)) ; +# stores (map, Some flag) where flag = parameter is a member of +# the map in first component of storage +code { UNPAIR; + DIP { CAR; DUP }; + MEM; SOME; SWAP; PAIR; NIL operation; PAIR;} diff --git a/src/bin_client/test/contracts/opcodes/mul.tz b/src/bin_client/test/contracts/opcodes/mul.tz new file mode 100644 index 0000000000000000000000000000000000000000..8432394b526d75ee295a4c79d134cc85525cb2ad --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/mul.tz @@ -0,0 +1,48 @@ +parameter unit ; +storage unit ; +code { CAR ; + DROP ; + # tez-nat, no overflow + PUSH nat 7987 ; + PUSH mutez 10 ; + MUL ; + PUSH mutez 79870 ; + COMPARE ; + ASSERT_EQ ; + # nat-tez, no overflow + PUSH mutez 10 ; + PUSH nat 7987 ; + MUL ; + PUSH mutez 79870 ; + COMPARE ; + ASSERT_EQ ; + # int-int, no overflow + PUSH int 10 ; + PUSH int -7987 ; + MUL ; + PUSH int -79870 ; + COMPARE ; + ASSERT_EQ ; + # int-nat, no overflow + PUSH nat 10 ; + PUSH int -7987 ; + MUL ; + PUSH int -79870 ; + COMPARE ; + ASSERT_EQ ; + # nat-int, no overflow + PUSH int -10 ; + PUSH nat 7987 ; + MUL ; + PUSH int -79870 ; + COMPARE ; + ASSERT_EQ ; + # nat-nat, no overflow + PUSH nat 10 ; + PUSH nat 7987 ; + MUL ; + PUSH nat 79870 ; + COMPARE ; + ASSERT_EQ ; + + UNIT ; NIL operation ; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/mul_overflow.tz b/src/bin_client/test/contracts/opcodes/mul_overflow.tz new file mode 100644 index 0000000000000000000000000000000000000000..5d2b3a3dcff20b81817c52bd99a8738c12120f3f --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/mul_overflow.tz @@ -0,0 +1,18 @@ +parameter (or unit unit) ; +storage unit ; +code { CAR ; + IF_LEFT + { + PUSH nat 922337203685477580700 ; + PUSH mutez 10 ; + MUL ; # FAILURE + DROP + } + { + PUSH mutez 10 ; + PUSH nat 922337203685477580700 ; + MUL ; # FAILURE + DROP + } ; + + NIL operation ; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/neg.tz b/src/bin_client/test/contracts/opcodes/neg.tz new file mode 100644 index 0000000000000000000000000000000000000000..9cedf765f1b2ef0c79a102b505037a9cb0c591b7 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/neg.tz @@ -0,0 +1,8 @@ +parameter (or int nat); +storage int; +code { + CAR; + IF_LEFT {NEG} {NEG}; + NIL operation; + PAIR + } diff --git a/src/bin_client/test/contracts/opcodes/none.tz b/src/bin_client/test/contracts/opcodes/none.tz new file mode 100644 index 0000000000000000000000000000000000000000..473a288b492662a3c80c9ff127a9a31bfb95a760 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/none.tz @@ -0,0 +1,3 @@ +parameter unit; +storage (option nat); +code { DROP; NONE nat; NIL operation; PAIR; }; diff --git a/src/bin_client/test/contracts/opcodes/not_binary.tz b/src/bin_client/test/contracts/opcodes/not_binary.tz new file mode 100644 index 0000000000000000000000000000000000000000..c1e0f97979d73983ff363a12f66ff0c1df94aa22 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/not_binary.tz @@ -0,0 +1,12 @@ +parameter (or int nat); +storage (option int); +code { CAR; + IF_LEFT + { + NOT; + } + { + NOT; + } ; + SOME; NIL operation ; PAIR + } diff --git a/src/bin_client/test/contracts/opcodes/or_binary.tz b/src/bin_client/test/contracts/opcodes/or_binary.tz new file mode 100644 index 0000000000000000000000000000000000000000..a31f109827efa3a00b776eb1fa473e1a6800bbe9 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/or_binary.tz @@ -0,0 +1,9 @@ +parameter (pair nat nat); +storage (option nat); +# This contract takes a pair of natural numbers as argument and +# stores the result of their binary OR. +code { CAR; + UNPAIR; + OR; + SOME; NIL operation; PAIR + } diff --git a/src/bin_client/test/contracts/opcodes/packunpack_rev.tz b/src/bin_client/test/contracts/opcodes/packunpack_rev.tz new file mode 100644 index 0000000000000000000000000000000000000000..86871a5c6287d6ee851ba63a0f41f3174524a258 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/packunpack_rev.tz @@ -0,0 +1,41 @@ +parameter (pair + int + (pair + nat + (pair + string + (pair bytes (pair mutez (pair bool (pair key_hash (pair timestamp address)))))))); +storage unit ; +code { CAR; + # Check the int + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK int; ASSERT_SOME; ASSERT_CMPEQ; + # Check the nat + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK nat; ASSERT_SOME; ASSERT_CMPEQ; + # Check the string + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK string; ASSERT_SOME; ASSERT_CMPEQ; + # Check the bytes + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK bytes; ASSERT_SOME; ASSERT_CMPEQ; + # Check the mutez + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK mutez; ASSERT_SOME; ASSERT_CMPEQ; + # Check the bool + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK bool; ASSERT_SOME; ASSERT_CMPEQ; + # Check the key_hash + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK key_hash; ASSERT_SOME; ASSERT_CMPEQ; + # Check the timestamp + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK timestamp; ASSERT_SOME; ASSERT_CMPEQ; + # Check the address + DUP; PACK; UNPACK address; ASSERT_SOME; ASSERT_CMPEQ; + + # Assert failure modes of unpack + PUSH int 0; PACK; UNPACK nat; ASSERT_SOME; DROP; + PUSH int -1; PACK; UNPACK nat; ASSERT_NONE; + + # Try deserializing invalid byte sequence (no magic number) + PUSH bytes 0x; UNPACK nat; ASSERT_NONE; + PUSH bytes 0x04; UNPACK nat; ASSERT_NONE; + + # Assert failure for byte sequences that do not correspond to + # any micheline value + PUSH bytes 0x05; UNPACK nat; ASSERT_NONE; + + UNIT ; NIL operation ; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/packunpack_rev_cty.tz b/src/bin_client/test/contracts/opcodes/packunpack_rev_cty.tz new file mode 100644 index 0000000000000000000000000000000000000000..5e32b8a6f6aa03f1c4cce9700e4634b0f298d21c --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/packunpack_rev_cty.tz @@ -0,0 +1,31 @@ +parameter (pair key (pair unit (pair signature (pair (option signature) (pair (list unit) (pair (set bool) (pair (pair int int) (pair (or key_hash timestamp) (pair (map int string) (lambda string bytes)))))))))); +storage unit ; +# for each uncomparable type t (we take an arbitrary parameter for +# parametric data-types e.g. pair, list), +# that is packable (which excludes big_map, operation, and contract) +# this contract receives a parameter v_t. +# it verifies that pack v_t == pack (unpack (pack v_t)) +code { CAR; + # packable uncomparable types + # checking: key + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK key; ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: unit + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK unit; ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: signature + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (signature); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: option signature + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (option signature); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: list unit + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (list unit); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: set bool + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (set bool); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: pair int int + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (pair int int); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: or key_hash timestamp + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (or key_hash timestamp); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: map int string + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (map int string); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: lambda string bytes + DUP; PACK; DIP { PACK; UNPACK (lambda string bytes); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + + UNIT ; NIL operation ; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/pexec.tz b/src/bin_client/test/contracts/opcodes/pexec.tz new file mode 100644 index 0000000000000000000000000000000000000000..eab0c71b4f59d31213510ca84f01e59c58be61bb --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/pexec.tz @@ -0,0 +1,6 @@ +parameter nat; +storage nat; +code { + LAMBDA (pair nat nat) nat + {UNPAIR ; ADD}; + SWAP; UNPAIR ; DIP { APPLY } ; EXEC ; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/pexec_2.tz b/src/bin_client/test/contracts/opcodes/pexec_2.tz new file mode 100644 index 0000000000000000000000000000000000000000..d64f7442f50e1a70e0f8e7a5b19d4e3518c6ab84 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/pexec_2.tz @@ -0,0 +1,11 @@ +parameter int; +storage (list int); +code { + UNPAIR @p @s ; # p :: s + LAMBDA (pair int (pair int int)) int + { UNPAIR ; DIP { UNPAIR } ; ADD ; MUL }; # l :: p :: s + SWAP ; APPLY ; # l :: s + PUSH int 3 ; APPLY ; # l :: s + SWAP ; MAP { DIP { DUP } ; EXEC } ; # s :: l + DIP { DROP } ; # s + NIL operation; PAIR }; diff --git a/src/bin_client/test/contracts/opcodes/proxy.tz b/src/bin_client/test/contracts/opcodes/proxy.tz new file mode 100644 index 0000000000000000000000000000000000000000..a9f17836e3c0566d0e6b0f95dde3938b1221990b --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/proxy.tz @@ -0,0 +1,13 @@ +/* This proxy contract transfers the recieved amount to the contract given as parameter. + It is used to test the SOURCE and SENDER opcodes; see source.tz and sender.tz. */ +parameter (contract unit) ; +storage unit ; +code{ + UNPAIR; + AMOUNT ; + UNIT ; + TRANSFER_TOKENS; + DIP {NIL operation} ; + CONS; + PAIR + } \ No newline at end of file diff --git a/src/bin_client/test/contracts/opcodes/self.tz b/src/bin_client/test/contracts/opcodes/self.tz index 728cd5f1dbdb671093a30b1d0783f4a60b30e31f..d96457fd1331035930298a1fdbeafd81b2840d29 100644 --- a/src/bin_client/test/contracts/opcodes/self.tz +++ b/src/bin_client/test/contracts/opcodes/self.tz @@ -1,3 +1,3 @@ parameter unit ; -storage (contract unit) ; -code { DROP ; SELF ; NIL operation ; PAIR } +storage address ; +code { DROP ; SELF ; ADDRESS ; NIL operation ; PAIR } diff --git a/src/bin_client/test/contracts/opcodes/sender.tz b/src/bin_client/test/contracts/opcodes/sender.tz new file mode 100644 index 0000000000000000000000000000000000000000..fb174179aca53f366f19723e6df11924d597f26a --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/sender.tz @@ -0,0 +1,8 @@ +parameter unit ; +storage address ; +code{ + DROP ; + SENDER; + NIL operation ; + PAIR + } diff --git a/src/bin_client/test/contracts/opcodes/set_delegate.tz b/src/bin_client/test/contracts/opcodes/set_delegate.tz new file mode 100644 index 0000000000000000000000000000000000000000..a7e051e50494a6c87e9e020ccf7500bc45ffbc60 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/set_delegate.tz @@ -0,0 +1,9 @@ +parameter (option key_hash); +storage unit; +code { + UNPAIR; + SET_DELEGATE; + DIP {NIL operation}; + CONS; + PAIR + } diff --git a/src/bin_client/test/contracts/opcodes/shifts.tz b/src/bin_client/test/contracts/opcodes/shifts.tz new file mode 100644 index 0000000000000000000000000000000000000000..71964750c0b8070272f0039332cca69b02219c45 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/shifts.tz @@ -0,0 +1,18 @@ +parameter (or (pair nat nat) (pair nat nat)); +storage (option nat); +# this contract takes either (Left a b) and stores (a << b) +# or (Right a b) and stores (a >> b). +# i.e., in the first case, the first component shifted to the left by +# the second, and the second case, component shifted to the right by +# the second. +code { CAR; + IF_LEFT { + UNPAIR; LSL; + } + { + UNPAIR; LSR; + }; + SOME; + NIL operation; + PAIR; + }; diff --git a/src/bin_client/test/contracts/opcodes/slice.tz b/src/bin_client/test/contracts/opcodes/slice.tz new file mode 100644 index 0000000000000000000000000000000000000000..3461bb5533d1cb3d52b98575474431cb4bc38588 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/slice.tz @@ -0,0 +1,5 @@ +parameter (pair nat nat); +storage (option string); +code { UNPAIR; SWAP; + IF_SOME {SWAP; UNPAIR; SLICE;} {DROP; NONE string;}; + NIL operation; PAIR} diff --git a/src/bin_client/test/contracts/opcodes/slice_bytes.tz b/src/bin_client/test/contracts/opcodes/slice_bytes.tz new file mode 100644 index 0000000000000000000000000000000000000000..c0f60f358765de3ce16d2bec7b32e7f1f51b7454 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/slice_bytes.tz @@ -0,0 +1,5 @@ +parameter (pair nat nat); +storage (option bytes); +code { UNPAIR; SWAP; + IF_SOME {SWAP; UNPAIR; SLICE;} {DROP; NONE bytes;}; + NIL operation; PAIR} diff --git a/src/bin_client/test/contracts/opcodes/source.tz b/src/bin_client/test/contracts/opcodes/source.tz new file mode 100644 index 0000000000000000000000000000000000000000..fc3c642027d3b9d0985dc0a97fdfdf7c097d0b35 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/source.tz @@ -0,0 +1,10 @@ +parameter unit ; + +storage address ; + +code{ + DROP ; + SOURCE; + NIL operation ; + PAIR + } \ No newline at end of file diff --git a/src/bin_client/test/contracts/opcodes/steps_to_quota.tz b/src/bin_client/test/contracts/opcodes/steps_to_quota.tz deleted file mode 100644 index 4981864be9b173608628be5894620b526d674edb..0000000000000000000000000000000000000000 --- a/src/bin_client/test/contracts/opcodes/steps_to_quota.tz +++ /dev/null @@ -1,3 +0,0 @@ -parameter unit; -storage nat; -code {DROP; STEPS_TO_QUOTA; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/update_big_map.tz b/src/bin_client/test/contracts/opcodes/update_big_map.tz new file mode 100644 index 0000000000000000000000000000000000000000..c403975a38fb1d0570b61a2c1fa90668a16f6b80 --- /dev/null +++ b/src/bin_client/test/contracts/opcodes/update_big_map.tz @@ -0,0 +1,6 @@ +storage (pair (big_map string string) unit); +parameter (map string (option string)); +# this contract the stored big_map according to the map taken in parameter +code { UNPAPAIR; + ITER { UNPAIR; UPDATE; } ; + PAIR; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/opcodes/xor.tz b/src/bin_client/test/contracts/opcodes/xor.tz index ab8dcf57d086d72d07366466534908de2092a394..557eaa642b9a2a8b53857ed7ef529e3fefc58d23 100644 --- a/src/bin_client/test/contracts/opcodes/xor.tz +++ b/src/bin_client/test/contracts/opcodes/xor.tz @@ -1,3 +1,13 @@ -parameter (pair bool bool); -storage (option bool); -code {CAR; DUP; CAR; DIP{CDR}; XOR; SOME; NIL operation ; PAIR}; +parameter (or (pair bool bool) (pair nat nat)); +storage (option (or bool nat)); +code { + CAR; + IF_LEFT + { + UNPAIR; XOR; LEFT nat + } + { + UNPAIR; XOR; RIGHT bool + } ; + SOME; NIL operation ; PAIR + } diff --git a/src/bin_client/test/dune b/src/bin_client/test/dune index 34664e10daa44a36a412c2f5a4ddd2c09334d1c8..5e2969269faf0979e533fe9c74f9bd5cb4158f63 100644 --- a/src/bin_client/test/dune +++ b/src/bin_client/test/dune @@ -21,38 +21,6 @@ %{bin:tezos-client} %{bin:tezos-admin-client}))) -(alias - (name runtest_contracts.sh) - (deps sandbox.json - protocol_parameters.json - test_lib.inc.sh - (glob_files contracts/attic/*)) - (locks /tcp-port/18731 - /tcp-port/19731) - (action - (run bash %{dep:test_contracts.sh} - %{bin:tezos-sandboxed-node.sh} - %{bin:tezos-node} - %{bin:tezos-init-sandboxed-client.sh} - %{bin:tezos-client} - %{bin:tezos-admin-client}))) - -(alias - (name runtest_contracts_opcode.sh) - (deps sandbox.json - protocol_parameters.json - test_lib.inc.sh - (glob_files contracts/opcodes/*)) - (locks /tcp-port/18731 - /tcp-port/19731) - (action - (run bash %{dep:test_contracts_opcode.sh} - %{bin:tezos-sandboxed-node.sh} - %{bin:tezos-node} - %{bin:tezos-init-sandboxed-client.sh} - %{bin:tezos-client} - %{bin:tezos-admin-client}))) - (alias (name runtest_contracts_macros.sh) (deps sandbox.json @@ -69,22 +37,6 @@ %{bin:tezos-client} %{bin:tezos-admin-client}))) -(alias - (name runtest_contracts_mini_scenarios.sh) - (deps sandbox.json - protocol_parameters.json - test_lib.inc.sh - (glob_files contracts/mini_scenarios/*)) - (locks /tcp-port/18731 - /tcp-port/19731) - (action - (run bash %{dep:test_contracts_mini_scenarios.sh} - %{bin:tezos-sandboxed-node.sh} - %{bin:tezos-node} - %{bin:tezos-init-sandboxed-client.sh} - %{bin:tezos-client} - %{bin:tezos-admin-client}))) - (alias (name runtest_multinode.sh) (deps sandbox.json @@ -170,10 +122,7 @@ (alias (name runtest) (deps (alias runtest_basic.sh) - (alias runtest_contracts.sh) - (alias runtest_contracts_opcode.sh) (alias runtest_contracts_macros.sh) - (alias runtest_contracts_mini_scenarios.sh) (alias runtest_multinode.sh) (alias runtest_injection.sh) (alias runtest_tls.sh) diff --git a/src/bin_client/test/test_basic.sh b/src/bin_client/test/test_basic.sh index 69eddfe82894633261836ccb54b1eef7a8ee466b..c685714b9ed23a4095b3f5a5faf5ee0cd8868897 100755 --- a/src/bin_client/test/test_basic.sh +++ b/src/bin_client/test/test_basic.sh @@ -62,26 +62,18 @@ bake $client remember script noop file:contracts/opcodes/noop.tz $client typecheck script file:contracts/opcodes/noop.tz bake_after $client originate contract noop \ - for $key1 transferring 1,000 from bootstrap1 \ + transferring 1,000 from bootstrap1 \ running file:contracts/opcodes/noop.tz --burn-cap 0.295 bake_after $client transfer 10 from bootstrap1 to noop --arg "Unit" bake_after $client originate contract hardlimit \ - for $key1 transferring 1,000 from bootstrap1 \ + transferring 1,000 from bootstrap1 \ running file:contracts/mini_scenarios/hardlimit.tz --init "3" --burn-cap 0.341 bake_after $client transfer 10 from bootstrap1 to hardlimit --arg "Unit" bake_after $client transfer 10 from bootstrap1 to hardlimit --arg "Unit" -bake_after $client originate account free_account for $key1 \ - transferring 1,000 from bootstrap1 --delegatable --burn-cap 0.257 -$client get delegate for free_account - -bake_after $client register key $key2 as delegate -bake_after $client set delegate for free_account to $key2 -$client get delegate for free_account - $client get balance for bootstrap5 | assert "4000000 ꜩ" bake_after $client transfer 400,000 from bootstrap5 to bootstrap1 --fee 0 --force-low-fee bake_after $client transfer 400,000 from bootstrap1 to bootstrap5 --fee 0 --force-low-fee @@ -101,7 +93,7 @@ echo echo "-- Origination --" echo -bake_after $client deploy multisig msig for bootstrap1 transferring 100 from bootstrap1 with threshold 2 on public keys $key1 $key2 $key3 --burn-cap 100 +bake_after $client deploy multisig msig transferring 100 from bootstrap1 with threshold 2 on public keys $key1 $key2 $key3 --burn-cap 100 echo echo "-- Transfer --" diff --git a/src/bin_client/test/test_contracts.sh b/src/bin_client/test/test_contracts.sh deleted file mode 100755 index 28ce61827970e8c9d70e572ec2530bffb862f3c2..0000000000000000000000000000000000000000 --- a/src/bin_client/test/test_contracts.sh +++ /dev/null @@ -1,87 +0,0 @@ -#!/bin/bash - -set -e -set -o pipefail - -test_dir="$(cd "$(dirname "$0")" && echo "$(pwd -P)")" -source $test_dir/test_lib.inc.sh "$@" - -start_node 1 -activate_alpha - -$client -w none config update - -bake - -key1=foo -key2=bar - -$client gen keys $key1 -$client gen keys $key2 - -printf "\n\n" - -# Assert all contracts typecheck -if [ ! $NO_TYPECHECK ] ; then - for contract in `ls $contract_attic_dir/*.tz`; do - printf "[Typechecking %s]\n" "$contract"; - ${client} typecheck script "$contract"; - done - printf "All contracts are well typed\n\n" -fi - -# Typing gas bounds checks -tee /tmp/first_explosion.tz < parse_expression arg >>=? fun {expanded = arg; _} -> return_some arg | None -> return_none ) >>=? fun parameters -> - let parameters = Option.map ~f:Script.lazy_expr parameters in - let contents = Transaction {amount; parameters; destination} in + let parameters = + Option.unopt_map + ~f:Script.lazy_expr + ~default:Script.unit_parameter + parameters + in + let contents = Transaction {amount; parameters; destination; entrypoint} in Injection.inject_manager_operation cctxt ~chain @@ -88,7 +102,7 @@ let reveal cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch >>=? fun pcounter -> let counter = Z.succ pcounter in Alpha_services.Contract.manager_key cctxt (chain, block) source - >>=? fun (_, key) -> + >>=? fun key -> match key with | Some _ -> failwith "The manager key was previously revealed." @@ -123,65 +137,6 @@ let reveal cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch -> return (oph, op, result) ) -let originate cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing - ?branch ~source ~src_pk ~src_sk ?fee ?gas_limit ?storage_limit - ~fee_parameter contents = - Injection.inject_manager_operation - cctxt - ~chain - ~block - ?confirmations - ?dry_run - ?verbose_signing - ?branch - ~source - ?fee - ?gas_limit - ?storage_limit - ~src_pk - ~src_sk - ~fee_parameter - contents - >>=? fun ((_oph, _op, result) as res) -> - Lwt.return (Injection.originated_contracts (Single_result result)) - >>=? function - | [contract] -> - return (res, contract) - | contracts -> - failwith - "The origination introduced %d contracts instead of one." - (List.length contracts) - -let originate_account cctxt ~chain ~block ?confirmations ?dry_run - ?verbose_signing ?branch ~source ~src_pk ~src_sk ~manager_pkh - ?(delegatable = false) ?delegate ~balance ?fee ~fee_parameter () = - let origination = - Origination - { - manager = manager_pkh; - delegate; - script = None; - spendable = true; - delegatable; - credit = balance; - preorigination = None; - } - in - originate - cctxt - ~chain - ~block - ?confirmations - ?dry_run - ?verbose_signing - ?branch - ~source - ~src_pk - ~src_sk - ?fee - ~fee_parameter - origination - let delegate_contract cctxt ~chain ~block ?branch ?confirmations ?dry_run ?verbose_signing ~source ~src_pk ~src_sk ?fee ~fee_parameter delegate_opt = let operation = Delegation delegate_opt in @@ -241,13 +196,6 @@ let list_contract_labels cctxt ~chain ~block = let message_added_contract (cctxt : #full) name = cctxt#message "Contract memorized as %s." name -let get_manager (cctxt : #full) ~chain ~block source = - Client_proto_contracts.get_manager cctxt ~chain ~block source - >>=? fun src_pkh -> - Client_keys.get_key cctxt src_pkh - >>=? fun (src_name, src_pk, src_sk) -> - return (src_name, src_pkh, src_pk, src_sk) - let set_delegate cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing ?fee contract ~src_pk ~manager_sk ~fee_parameter opt_delegate = delegate_contract @@ -274,17 +222,13 @@ let register_as_delegate cctxt ~chain ~block ?confirmations ?dry_run ?confirmations ?dry_run ?verbose_signing - ~source:(Contract.implicit_contract source) + ~source ~src_pk ~src_sk:manager_sk ?fee ~fee_parameter (Some source) -let source_to_keys (wallet : #full) ~chain ~block source = - get_manager wallet ~chain ~block source - >>=? fun (_src_name, _src_pkh, src_pk, src_sk) -> return (src_pk, src_sk) - let save_contract ~force cctxt alias_name contract = RawContractAlias.add ~force cctxt alias_name contract >>=? fun () -> @@ -292,8 +236,9 @@ let save_contract ~force cctxt alias_name contract = let originate_contract (cctxt : #full) ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch ?fee ?gas_limit ?storage_limit ~delegate - ?(delegatable = true) ?(spendable = false) ~initial_storage ~manager - ~balance ~source ~src_pk ~src_sk ~code ~fee_parameter () = + ~initial_storage ~balance ~source ~src_pk ~src_sk ~code ~fee_parameter () = + (* With the change of making implicit accounts delegatable, the following + 3 arguments are being defaulted before they can be safely removed. *) Lwt.return (Michelson_v1_parser.parse_expression initial_storage) >>= fun result -> Lwt.return (Micheline_parser.no_parsing_error result) @@ -302,16 +247,13 @@ let originate_contract (cctxt : #full) ~chain ~block ?confirmations ?dry_run let origination = Origination { - manager; delegate; - script = Some {code; storage}; - spendable; - delegatable; + script = {code; storage}; credit = balance; preorigination = None; } in - originate + Injection.inject_manager_operation cctxt ~chain ~block @@ -320,13 +262,22 @@ let originate_contract (cctxt : #full) ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch ~source - ~src_pk - ~src_sk ?fee ?gas_limit ?storage_limit + ~src_pk + ~src_sk ~fee_parameter origination + >>=? fun ((_oph, _op, result) as res) -> + Lwt.return (Injection.originated_contracts (Single_result result)) + >>=? function + | [contract] -> + return (res, contract) + | contracts -> + failwith + "The origination introduced %d contracts instead of one." + (List.length contracts) type activation_key = { pkh : Ed25519.Public_key_hash.t; diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index e5cbc1ec373c62999aba9c61f8e5e544f82a1abf..22fa21272ca946db521d40a75129137223ce5a72 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -39,7 +39,7 @@ val get_storage : Contract.t -> Script.expr option tzresult Lwt.t -val get_big_map_value : +val get_contract_big_map_value : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> @@ -47,19 +47,20 @@ val get_big_map_value : Script.expr * Script.expr -> Script.expr option tzresult Lwt.t -val get_script : +val get_big_map_value : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> - Contract.t -> - Script.t option tzresult Lwt.t + Z.t -> + Script_expr_hash.t -> + Script.expr tzresult Lwt.t -val get_manager : - #Protocol_client_context.full -> +val get_script : + #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> Contract.t -> - (string * public_key_hash * public_key * Client_keys.sk_uri) tzresult Lwt.t + Script.t option tzresult Lwt.t val get_balance : #Protocol_client_context.rpc_context -> @@ -76,7 +77,7 @@ val set_delegate : ?dry_run:bool -> ?verbose_signing:bool -> ?fee:Tez.tez -> - Contract.t -> + public_key_hash -> src_pk:public_key -> manager_sk:Client_keys.sk_uri -> fee_parameter:Injection.fee_parameter -> @@ -96,33 +97,6 @@ val register_as_delegate : public_key -> Kind.delegation Kind.manager Injection.result tzresult Lwt.t -val source_to_keys : - #Protocol_client_context.full -> - chain:Shell_services.chain -> - block:Shell_services.block -> - Contract.t -> - (public_key * Client_keys.sk_uri) tzresult Lwt.t - -val originate_account : - #Protocol_client_context.full -> - chain:Shell_services.chain -> - block:Shell_services.block -> - ?confirmations:int -> - ?dry_run:bool -> - ?verbose_signing:bool -> - ?branch:int -> - source:Contract.t -> - src_pk:public_key -> - src_sk:Client_keys.sk_uri -> - manager_pkh:public_key_hash -> - ?delegatable:bool -> - ?delegate:public_key_hash -> - balance:Tez.tez -> - ?fee:Tez.tez -> - fee_parameter:Injection.fee_parameter -> - unit -> - (Kind.origination Kind.manager Injection.result * Contract.t) tzresult Lwt.t - val save_contract : force:bool -> #Protocol_client_context.full -> @@ -142,12 +116,9 @@ val originate_contract : ?gas_limit:Z.t -> ?storage_limit:Z.t -> delegate:public_key_hash option -> - ?delegatable:bool -> - ?spendable:bool -> initial_storage:string -> - manager:public_key_hash -> balance:Tez.t -> - source:Contract.t -> + source:public_key_hash -> src_pk:public_key -> src_sk:Client_keys.sk_uri -> code:Script.expr -> @@ -163,10 +134,11 @@ val transfer : ?dry_run:bool -> ?verbose_signing:bool -> ?branch:int -> - source:Contract.t -> + source:public_key_hash -> src_pk:public_key -> src_sk:Client_keys.sk_uri -> destination:Contract.t -> + ?entrypoint:string -> ?arg:string -> amount:Tez.t -> ?fee:Tez.t -> @@ -186,7 +158,7 @@ val reveal : ?dry_run:bool -> ?verbose_signing:bool -> ?branch:int -> - source:Contract.t -> + source:public_key_hash -> src_pk:public_key -> src_sk:Client_keys.sk_uri -> ?fee:Tez.t -> diff --git a/src/proto_alpha/lib_client/client_proto_contracts.ml b/src/proto_alpha/lib_client/client_proto_contracts.ml index e9f47f166c4829e56883c859f45a4b0d669409a2..d3866ebf330fa0d779e68a16cea048e4c4da4b25 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts.ml +++ b/src/proto_alpha/lib_client/client_proto_contracts.ml @@ -124,7 +124,7 @@ module ContractAlias = struct | Ok v -> return (s, v) | Error c_errs -> - Lwt.return (Error (k_errs @ c_errs)) ) )) + Lwt.return_error (k_errs @ c_errs) ) )) let destination_param ?(name = "dst") ?(desc = "destination contract") next = let desc = @@ -170,12 +170,5 @@ let list_contracts cctxt = keys >>=? fun accounts -> return (contracts @ accounts) -let get_manager cctxt ~chain ~block source = - match Contract.is_implicit source with - | Some hash -> - return hash - | None -> - Alpha_services.Contract.manager cctxt (chain, block) source - let get_delegate cctxt ~chain ~block source = Alpha_services.Contract.delegate_opt cctxt (chain, block) source diff --git a/src/proto_alpha/lib_client/client_proto_contracts.mli b/src/proto_alpha/lib_client/client_proto_contracts.mli index 968f33f64a74e8db66698d204f03d35a3c269ada..6e1427c4c81b8e4c86757345fa68e0f1f24e8637 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts.mli +++ b/src/proto_alpha/lib_client/client_proto_contracts.mli @@ -63,13 +63,6 @@ val list_contracts : #Client_context.wallet -> (string * string * RawContractAlias.t) list tzresult Lwt.t -val get_manager : - #Protocol_client_context.rpc_context -> - chain:Shell_services.chain -> - block:Shell_services.block -> - Contract.t -> - public_key_hash tzresult Lwt.t - val get_delegate : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> diff --git a/src/proto_alpha/lib_client/client_proto_multisig.ml b/src/proto_alpha/lib_client/client_proto_multisig.ml index 96b362eef57a01299442f53b467ba1d6dbcbf0f4..1d34bed924b71ebed0e0a30a99c61fa061c763c0 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.ml +++ b/src/proto_alpha/lib_client/client_proto_multisig.ml @@ -29,7 +29,8 @@ open Alpha_context type error += Contract_has_no_script of Contract.t -type error += Not_a_supported_multisig_contract of Script.expr +type error += + | Not_a_supported_multisig_contract of (Script_expr_hash.t * Script.expr) type error += Contract_has_no_storage of Contract.t @@ -72,15 +73,23 @@ let () = ~description: "A multisig command has referenced a smart contract whose script is not \ one of the known multisig contract scripts." - ~pp:(fun ppf script -> + ~pp:(fun ppf (hash, script) -> Format.fprintf ppf - "Not a supported multisig contract %a." + "Not a supported multisig contract %a.@\n\ + The hash of this script is 0x%a, it was not found among in the list \ + of known multisig script hashes." Michelson_v1_printer.print_expr - script) - Data_encoding.(obj1 (req "script" Script.expr_encoding)) - (function Not_a_supported_multisig_contract c -> Some c | _ -> None) - (fun c -> Not_a_supported_multisig_contract c) ; + script + Hex.pp + (Hex.of_bytes (Script_expr_hash.to_bytes hash))) + Data_encoding.( + obj2 + (req "hash" Script_expr_hash.encoding) + (req "script" Script.expr_encoding)) + (function + | Not_a_supported_multisig_contract (h, c) -> Some (h, c) | _ -> None) + (fun (h, c) -> Not_a_supported_multisig_contract (h, c)) ; register_error_kind `Permanent ~id:"contractHasNoStorage" @@ -244,6 +253,7 @@ let () = (* The multisig contract script written by Arthur Breitman https://github.com/murbard/smart-contracts/blob/master/multisig/michelson/multisig.tz *) +(* Updated to take the chain id into account *) let multisig_script_string = "parameter (pair\n\ \ (pair :payload\n\ @@ -272,7 +282,7 @@ let multisig_script_string = \ # pair the payload with the current contract address, to ensure \ signatures\n\ \ # can't be replayed accross different contracts if a key is reused.\n\ - \ DUP ; SELF ; ADDRESS ; PAIR ;\n\ + \ DUP ; SELF ; ADDRESS ; CHAIN_ID ; PAIR ; PAIR ;\n\ \ PACK ; # form the binary payload that we expect to be signed\n\ \ DIP { UNPAIR @counter ; DIP { SWAP } } ; SWAP\n\ \ } ;\n\n\ @@ -347,23 +357,80 @@ let multisig_script_hash = let hash = Script_expr_hash.hash_bytes [bytes] in ok hash -let known_multisig_hashes = multisig_script_hash >>? fun hash -> ok [hash] +(* The previous multisig script is the only one that the client can + originate but the client knows how to interact with several + versions of the multisig contract. For each version, the description + indicates which features are available and how to interact with + the contract. *) + +type multisig_contract_description = { + hash : Script_expr_hash.t; + (* The hash of the contract script *) + requires_chain_id : bool; + (* The signatures should contain the chain identifier *) + generic : bool; + (* False means that the contract uses a custom action type, true + means that the contract expects the action as a (lambda unit + (list operation)). *) +} -let check_multisig_script script : unit tzresult Lwt.t = +let script_hash_of_hex_string s = + Script_expr_hash.of_bytes_exn @@ MBytes.of_hex @@ `Hex s + +(* List of known multisig contracts hashes with their kinds *) +let known_multisig_contracts : multisig_contract_description list tzresult = + multisig_script_hash + >>? fun hash -> + ok + [ {hash; requires_chain_id = true; generic = false}; + { + hash = + script_hash_of_hex_string + "36cf0b376c2d0e21f0ed42b2974fedaafdcafb9b7f8eb9254ef811b37cb46d94"; + requires_chain_id = true; + generic = false; + }; + { + hash = + script_hash_of_hex_string + "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31"; + requires_chain_id = false; + generic = false; + } ] + +let known_multisig_hashes = + known_multisig_contracts + >>? fun l -> ok (List.map (fun descr -> descr.hash) l) + +let check_multisig_script script : multisig_contract_description tzresult Lwt.t + = let bytes = Data_encoding.force_bytes script in let hash = Script_expr_hash.hash_bytes [bytes] in - Lwt.return known_multisig_hashes + Lwt.return known_multisig_contracts >>=? fun l -> - fold_left_s (fun b h -> return (b || Script_expr_hash.(h = hash))) false l - >>=? fun hash_found -> - fail_unless - hash_found - (Not_a_supported_multisig_contract - ( match Data_encoding.force_decode script with - | Some s -> - s - | None -> - assert false )) + fold_left_s + (fun descr_opt d -> + return + @@ + match descr_opt with + | Some descr -> + Some descr + | None -> + if Script_expr_hash.(d.hash = hash) then Some d else None) + None + l + >>=? function + | None -> + fail + (Not_a_supported_multisig_contract + ( hash, + match Data_encoding.force_decode script with + | Some s -> + s + | None -> + assert false )) + | Some d -> + return d (* Returns [Ok ()] if [~contract] is an originated contract whose code is [multisig_script] *) @@ -608,14 +675,23 @@ let mutlisig_param_string ~counter ~action ~optional_signatures () = >>=? fun expr -> return @@ Format.asprintf "%a" Michelson_v1_printer.print_expr expr -let multisig_bytes ~counter ~action ~contract () = +let get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract = + let address = + bytes ~loc (Data_encoding.Binary.to_bytes_exn Contract.encoding contract) + in + if descr.requires_chain_id then + let chain_id_bytes = + bytes ~loc (Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id) + in + pair ~loc chain_id_bytes address + else address + +let multisig_bytes ~counter ~action ~contract ~chain_id ~descr () = let loc = Tezos_micheline.Micheline_parser.location_zero in let triple = pair ~loc - (bytes - ~loc - (Data_encoding.Binary.to_bytes_exn Contract.encoding contract)) + (get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract) (pair ~loc (int ~loc counter) (action_to_expr ~loc action)) in let bytes = @@ -635,8 +711,7 @@ let check_threshold ~threshold ~keys () = let originate_multisig (cctxt : #Protocol_client_context.full) ~chain ~block ?confirmations ?dry_run ?branch ?fee ?gas_limit ?storage_limit ~delegate - ?(delegatable = false) ?(spendable = false) ~threshold ~keys ~manager - ~balance ~source ~src_pk ~src_sk ~fee_parameter () = + ~threshold ~keys ~balance ~source ~src_pk ~src_sk ~fee_parameter () = Lwt.return multisig_script >>=? fun code -> multisig_storage_string ~counter:Z.zero ~threshold ~keys () @@ -654,10 +729,7 @@ let originate_multisig (cctxt : #Protocol_client_context.full) ~chain ~block ?gas_limit ?storage_limit ~delegate - ~delegatable - ~spendable ~initial_storage - ~manager ~balance ~source ~src_pk @@ -684,12 +756,14 @@ let prepare_multisig_transaction (cctxt : #Protocol_client_context.full) ~chain ~block ~multisig_contract ~action () = let contract = multisig_contract in check_multisig_contract cctxt ~chain ~block contract - >>=? fun () -> + >>=? fun descr -> check_action ~action () >>=? fun () -> multisig_get_information cctxt ~chain ~block contract >>=? fun {counter; threshold; keys} -> - multisig_bytes ~counter ~action ~contract () + Chain_services.chain_id cctxt ~chain () + >>=? fun chain_id -> + multisig_bytes ~counter ~action ~contract ~descr ~chain_id () >>=? fun bytes -> return {bytes; threshold; keys; counter} let check_multisig_signatures ~bytes ~threshold ~keys signatures = @@ -760,7 +834,7 @@ let call_multisig (cctxt : #Protocol_client_context.full) ~chain ~block ~fee_parameter () -let action_of_bytes ~multisig_contract ~stored_counter bytes = +let action_of_bytes ~multisig_contract ~stored_counter ~descr ~chain_id bytes = if Compare.Int.(Bytes.length bytes >= 1) && Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05) @@ -780,7 +854,8 @@ let action_of_bytes ~multisig_contract ~stored_counter bytes = Script.D_Pair, [Tezos_micheline.Micheline.Int (_, counter); e], [] ) ], - [] ) -> + [] ) + when not descr.requires_chain_id -> let contract = Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes in @@ -788,6 +863,33 @@ let action_of_bytes ~multisig_contract ~stored_counter bytes = if multisig_contract = contract then action_of_expr e else fail (Bad_deserialized_contract (contract, multisig_contract)) else fail (Bad_deserialized_counter (counter, stored_counter)) + | Tezos_micheline.Micheline.Prim + ( _, + Script.D_Pair, + [ Tezos_micheline.Micheline.Prim + ( _, + Script.D_Pair, + [ Tezos_micheline.Micheline.Bytes (_, chain_id_bytes); + Tezos_micheline.Micheline.Bytes (_, contract_bytes) ], + [] ); + Tezos_micheline.Micheline.Prim + ( _, + Script.D_Pair, + [Tezos_micheline.Micheline.Int (_, counter); e], + [] ) ], + [] ) + when descr.requires_chain_id -> + let contract = + Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes + in + let cid = + Data_encoding.Binary.of_bytes_exn Chain_id.encoding chain_id_bytes + in + if counter = stored_counter then + if multisig_contract = contract && chain_id = cid then + action_of_expr e + else fail (Bad_deserialized_contract (contract, multisig_contract)) + else fail (Bad_deserialized_counter (counter, stored_counter)) | _ -> fail (Bytes_deserialisation_error bytes) ) else fail (Bytes_deserialisation_error bytes) @@ -798,7 +900,16 @@ let call_multisig_on_bytes (cctxt : #Protocol_client_context.full) ~chain ?storage_limit ?counter ~fee_parameter () = multisig_get_information cctxt ~chain ~block multisig_contract >>=? fun info -> - action_of_bytes ~multisig_contract ~stored_counter:info.counter bytes + check_multisig_contract cctxt ~chain ~block multisig_contract + >>=? fun descr -> + Chain_services.chain_id cctxt ~chain () + >>=? fun chain_id -> + action_of_bytes + ~multisig_contract + ~stored_counter:info.counter + ~chain_id + ~descr + bytes >>=? fun action -> call_multisig cctxt diff --git a/src/proto_alpha/lib_client/client_proto_multisig.mli b/src/proto_alpha/lib_client/client_proto_multisig.mli index fcd496e045468a45bfc97c395b1251d394c60373..f7fa5a4f30ed94f55b1de46b8fe4924a410a8f01 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.mli +++ b/src/proto_alpha/lib_client/client_proto_multisig.mli @@ -39,6 +39,8 @@ type multisig_prepared_action = { counter : Z.t; } +val known_multisig_hashes : Script_expr_hash.t list tzresult + val originate_multisig : full -> chain:Shell_services.chain -> @@ -50,13 +52,10 @@ val originate_multisig : ?gas_limit:Z.t -> ?storage_limit:Z.t -> delegate:public_key_hash option -> - ?delegatable:bool -> - ?spendable:bool -> threshold:Z.t -> keys:public_key list -> - manager:public_key_hash -> balance:Tez.t -> - source:Contract.t -> + source:public_key_hash -> src_pk:public_key -> src_sk:Client_keys.sk_uri -> fee_parameter:Injection.fee_parameter -> @@ -79,7 +78,7 @@ val call_multisig : ?confirmations:int -> ?dry_run:bool -> ?branch:int -> - source:Contract.t -> + source:public_key_hash -> src_pk:public_key -> src_sk:Client_keys.sk_uri -> multisig_contract:Contract.t -> @@ -102,7 +101,7 @@ val call_multisig_on_bytes : ?confirmations:int -> ?dry_run:bool -> ?branch:int -> - source:Contract.t -> + source:public_key_hash -> src_pk:public_key -> src_sk:Client_keys.sk_uri -> multisig_contract:Contract.t -> diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 90cc415b33ec82cb4b18e568f7177b4f63384793..9d18eb069534c21026da349570163aa1cfe1ea32 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -54,27 +54,6 @@ let print_errors (cctxt : #Client_context.printer) errs ~show_source ~parsed = errs >>= fun () -> cctxt#error "error running script" >>= fun () -> return_unit -let print_big_map_diff ppf = function - | None -> - () - | Some diff -> - Format.fprintf - ppf - "@[map diff:@,%a@]@," - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf Contract.{diff_key; diff_value; _} -> - Format.fprintf - ppf - "%s %a%a" - (match diff_value with None -> "-" | Some _ -> "+") - print_expr - diff_key - (fun ppf -> function None -> () | Some x -> - Format.fprintf ppf "-> %a" print_expr x) - diff_value)) - diff - let print_run_result (cctxt : #Client_context.printer) ~show_source ~parsed = function | Ok (storage, operations, maybe_diff) -> @@ -83,12 +62,14 @@ let print_run_result (cctxt : #Client_context.printer) ~show_source ~parsed = %a@]@,\ @[emitted operations@,\ %a@]@,\ - @[%a@]@]@." + @[big_map diff@,\ + %a@]@]@." print_expr storage (Format.pp_print_list Operation_result.pp_internal_operation) operations - print_big_map_diff + (fun ppf -> function None -> () | Some diff -> + print_big_map_diff ppf diff) maybe_diff >>= fun () -> return_unit | Error errs -> @@ -102,13 +83,16 @@ let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed = %a@]@,\ @[emitted operations@,\ %a@]@,\ - %a@[@[trace@,\ + @[big_map diff@,\ + %a@]@,\ + @[trace@,\ %a@]@]@." print_expr storage (Format.pp_print_list Operation_result.pp_internal_operation) operations - print_big_map_diff + (fun ppf -> function None -> () | Some diff -> + print_big_map_diff ppf diff) maybe_big_map_diff print_execution_trace trace @@ -120,23 +104,43 @@ let run (cctxt : #Protocol_client_context.rpc_context) ~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents) ~(program : Michelson_v1_parser.parsed) ~(storage : Michelson_v1_parser.parsed) - ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas () = + ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas + ?(entrypoint = "default") () = + Chain_services.chain_id cctxt ~chain () + >>=? fun chain_id -> Alpha_services.Helpers.Scripts.run_code cctxt (chain, block) program.expanded - (storage.expanded, input.expanded, amount, source, payer, gas) + ( storage.expanded, + input.expanded, + amount, + chain_id, + source, + payer, + gas, + entrypoint ) let trace (cctxt : #Protocol_client_context.rpc_context) ~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents) ~(program : Michelson_v1_parser.parsed) ~(storage : Michelson_v1_parser.parsed) - ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas () = + ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas + ?(entrypoint = "default") () = + Chain_services.chain_id cctxt ~chain () + >>=? fun chain_id -> Alpha_services.Helpers.Scripts.trace_code cctxt (chain, block) program.expanded - (storage.expanded, input.expanded, amount, source, payer, gas) + ( storage.expanded, + input.expanded, + amount, + chain_id, + source, + payer, + gas, + entrypoint ) let typecheck_data cctxt ~(chain : Chain_services.chain) ~block ?gas ~(data : Michelson_v1_parser.parsed) ~(ty : Michelson_v1_parser.parsed) () diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index 97dde1f884382b289cdfca3300f4d715bcca68d5..c9fbb1be2b726dbeabd5a0c9d3de22407cf016f8 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -42,6 +42,7 @@ val run : ?source:Contract.t -> ?payer:Contract.t -> ?gas:Z.t -> + ?entrypoint:string -> unit -> (Script.expr * packed_internal_operation list * Contract.big_map_diff option) tzresult @@ -58,6 +59,7 @@ val trace : ?source:Contract.t -> ?payer:Contract.t -> ?gas:Z.t -> + ?entrypoint:string -> unit -> ( Script.expr * packed_internal_operation list diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index e4aa4c6c21416c2f1db565ead9bd3425dfd5a82b..5ce1a32517496c26e3949f892aee4c20f202dff9 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -293,10 +293,12 @@ let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block {shell = {branch}; protocol_data = {contents; signature = None}} in let oph = Operation.hash op in + Chain_services.chain_id cctxt ~chain () + >>=? fun chain_id -> Alpha_services.Helpers.Scripts.run_operation cctxt (chain, block) - (Operation.pack op) + (Operation.pack op, chain_id) >>=? function | (Operation_data op', Operation_metadata result) -> ( match @@ -821,7 +823,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations return counter ) >>=? fun counter -> Alpha_services.Contract.manager_key cctxt (chain, block) source - >>=? fun (_, key) -> + >>=? fun key -> let is_reveal : type kind. kind manager_operation -> bool = function | Reveal _ -> true diff --git a/src/proto_alpha/lib_client/injection.mli b/src/proto_alpha/lib_client/injection.mli index 01859b9b0d56a5c868ba3c64a64caf668da5a7c6..150d0c91df5b67151d6232e82d7b99bb833a8524 100644 --- a/src/proto_alpha/lib_client/injection.mli +++ b/src/proto_alpha/lib_client/injection.mli @@ -79,7 +79,7 @@ val inject_manager_operation : ?confirmations:int -> ?dry_run:bool -> ?verbose_signing:bool -> - source:Contract.t -> + source:Signature.Public_key_hash.t -> src_pk:Signature.public_key -> src_sk:Client_keys.sk_uri -> ?fee:Tez.t -> diff --git a/src/proto_alpha/lib_client/michelson_v1_emacs.ml b/src/proto_alpha/lib_client/michelson_v1_emacs.ml index 80a9988157d62dcba6afbff43dc02ff638ade92f..b142177e0bc755e59ff367a5be2a597879be565f 100644 --- a/src/proto_alpha/lib_client/michelson_v1_emacs.ml +++ b/src/proto_alpha/lib_client/michelson_v1_emacs.ml @@ -126,6 +126,7 @@ let first_error_location errs = | Bad_stack (loc, _, _, _) | Unmatched_branches (loc, _, _) | Invalid_constant (loc, _, _) + | Invalid_syntactic_constant (loc, _, _) | Invalid_contract (loc, _) | Comparable_type_expected (loc, _) | Michelson_v1_primitives.Invalid_primitive_name (_, loc) ) diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index a48d1232e8295280ac5c50eba48dddd7a45d2ed9..2c476aa68b1e52ae1f2786502a29e6bc2ff39c3d 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -85,6 +85,9 @@ let collect_error_locations errs = let rec collect acc = function | Environment.Ecoproto_error ( Ill_formed_type (_, _, _) + | No_such_entrypoint _ + | Duplicate_entrypoint _ + | Unreachable_entrypoint _ | Runtime_contract_error (_, _) | Michelson_v1_primitives.Invalid_primitive_name (_, _) | Ill_typed_data (_, _, _) @@ -112,6 +115,7 @@ let collect_error_locations errs = | Unmatched_branches (loc, _, _) | Self_in_lambda loc | Invalid_constant (loc, _, _) + | Invalid_syntactic_constant (loc, _, _) | Invalid_contract (loc, _) | Comparable_type_expected (loc, _) | Overflow (loc, _) @@ -207,6 +211,23 @@ let report_errors ~details ~show_source ?parsed ppf errs = ty ; if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest + | Environment.Ecoproto_error (No_such_entrypoint entrypoint) :: rest -> + Format.fprintf ppf "Contract has no entrypoint named %s" entrypoint ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace locations rest + | Environment.Ecoproto_error (Duplicate_entrypoint entrypoint) :: rest -> + Format.fprintf ppf "Contract has two entrypoints named %s" entrypoint ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace locations rest + | Environment.Ecoproto_error (Unreachable_entrypoint path) :: rest -> + let path = + String.concat + "/" + (List.map Michelson_v1_primitives.string_of_prim path) + in + Format.fprintf ppf "Entrypoint at path %s is not reachable" path ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace locations rest | Environment.Ecoproto_error (Ill_formed_type (_, expr, loc)) :: rest -> let parsed = match parsed with @@ -261,6 +282,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = "Error too big to serialize within the provided gas bounds." ; if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest + | Environment.Ecoproto_error (Deprecated_instruction prim) :: rest -> + Format.fprintf + ppf + "@[Use of deprecated instruction: %s@]" + (Michelson_v1_primitives.string_of_prim prim) ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace locations rest | Environment.Ecoproto_error Cannot_serialize_storage :: rest -> Format.fprintf ppf @@ -287,7 +315,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = | Environment.Ecoproto_error (Unexpected_big_map loc) :: rest -> Format.fprintf ppf - "%abig_map type only allowed on the left of the toplevel storage pair" + "%abig_map type not allowed inside another big_map" print_loc loc ; if rest <> [] then Format.fprintf ppf "@," ; @@ -300,6 +328,14 @@ let report_errors ~details ~show_source ?parsed ppf errs = loc ; if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest + | Environment.Ecoproto_error (Unexpected_contract loc) :: rest -> + Format.fprintf + ppf + "%acontract type forbidden in storage and constants" + print_loc + loc ; + if rest <> [] then Format.fprintf ppf "@," ; + print_trace locations rest | Environment.Ecoproto_error (Runtime_contract_error (contract, expr)) :: rest -> let parsed = @@ -588,6 +624,16 @@ let report_errors ~details ~show_source ?parsed ppf errs = got print_ty exp + | Invalid_syntactic_constant (loc, got, exp) -> + Format.fprintf + ppf + "@[@[%avalue@ %a@]@ @[is invalid, \ + expected@ %s@]@]" + print_loc + loc + print_expr + got + exp | Invalid_contract (loc, contract) -> Format.fprintf ppf diff --git a/src/proto_alpha/lib_client/michelson_v1_macros.ml b/src/proto_alpha/lib_client/michelson_v1_macros.ml index 5dfd5bb2db52a004e299bef96f33b82855548227..c16b2b08db4ea1517b1831325061a47054526c92 100644 --- a/src/proto_alpha/lib_client/michelson_v1_macros.ml +++ b/src/proto_alpha/lib_client/michelson_v1_macros.ml @@ -60,19 +60,22 @@ let expand_caddadr original = | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) ) >>? fun () -> - let rec parse i annot acc = + let path_annot = + List.filter (function "@%" | "@%%" -> true | _ -> false) annot + in + let rec parse i acc = if i = 0 then Seq (loc, acc) else - let annot = if i = len - 2 then annot else [] in + let annot = if i = len - 2 then annot else path_annot in match str.[i] with | 'A' -> - parse (i - 1) [] (Prim (loc, "CAR", [], annot) :: acc) + parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc) | 'D' -> - parse (i - 1) [] (Prim (loc, "CDR", [], annot) :: acc) + parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc) | _ -> assert false in - ok (Some (parse (len - 2) annot [])) + ok (Some (parse (len - 2) [])) else ok None | _ -> ok None @@ -351,20 +354,22 @@ let decimal_of_roman roman = done ; !arabic -let expand_dxiiivp original = +let dip ~loc ?(annot = []) depth instr = + assert (depth >= 0) ; + if depth = 1 then Prim (loc, "DIP", [instr], annot) + else Prim (loc, "DIP", [Int (loc, Z.of_int depth); instr], annot) + +let expand_deprecated_dxiiivp original = + (* transparently expands deprecated macro [DI...IP] to instruction [DIP n] *) match original with | Prim (loc, str, args, annot) -> let len = String.length str in if len > 3 && str.[0] = 'D' && str.[len - 1] = 'P' then try let depth = decimal_of_roman (String.sub str 1 (len - 2)) in - let rec make i acc = - if i = 0 then acc - else make (i - 1) (Seq (loc, [Prim (loc, "DIP", [acc], annot)])) - in match args with | [(Seq (_, _) as arg)] -> - ok @@ Some (make depth arg) + ok @@ Some (dip ~loc ~annot depth arg) | [_] -> error (Sequence_expected str) | [] | _ :: _ :: _ -> @@ -376,10 +381,6 @@ let expand_dxiiivp original = exception Not_a_pair -let rec dip ~loc depth instr = - if depth <= 0 then instr - else dip ~loc (depth - 1) (Prim (loc, "DIP", [Seq (loc, [instr])], [])) - type pair_item = A | I | P of int * pair_item * pair_item let parse_pair_substr str ~len start = @@ -474,7 +475,10 @@ let expand_pappaiir original = car_annot @ cdr_annot in let acc = - dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc + if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc + else + dip ~loc depth (Seq (loc, [Prim (loc, "PAIR", [], annot)])) + :: acc in (depth, acc) |> parse left |> parse right | A | I -> @@ -512,7 +516,8 @@ let expand_unpappaiir original = ( loc, [ Prim (loc, "DUP", [], []); Prim (loc, "CAR", [], car_annot); - dip ~loc 1 (Prim (loc, "CDR", [], cdr_annot)) ] ) + dip ~loc 1 (Seq (loc, [Prim (loc, "CDR", [], cdr_annot)])) ] + ) in let ast = parse_pair_substr str ~len 2 in let annots_pos = pappaiir_annots_pos ast annot in @@ -526,7 +531,12 @@ let expand_unpappaiir original = | Some (car_annot, cdr_annot) -> (car_annot, cdr_annot) in - let acc = dip ~loc depth (unpair car_annot cdr_annot) :: acc in + let acc = + if depth = 0 then unpair car_annot cdr_annot :: acc + else + dip ~loc depth (Seq (loc, [unpair car_annot cdr_annot])) + :: acc + in (depth, acc) |> parse left |> parse right | A | I -> (depth + 1, acc) @@ -546,7 +556,34 @@ let expand_unpappaiir original = exception Not_a_dup -let expand_duuuuup original = +let dupn loc nloc n annot = + assert (n > 1) ; + if n = 2 then + (* keep the old expansion, shorter for [DUP 2] *) + Seq + ( loc, + [ Prim (loc, "DIP", [Seq (loc, [Prim (nloc, "DUP", [], annot)])], []); + Prim (loc, "SWAP", [], []) ] ) + else + Seq + ( loc, + [ Prim + ( loc, + "DIP", + [ Int (loc, Z.of_int (n - 1)); + Seq (loc, [Prim (loc, "DUP", [], annot)]) ], + [] ); + Prim (loc, "DIG", [Int (nloc, Z.of_int n)], []) ] ) + +let expand_dupn original = + match original with + | Prim (loc, "DUP", [Int (nloc, n)], annot) -> + ok (Some (dupn loc nloc (Z.to_int n) annot)) + | _ -> + ok None + +let expand_deprecated_duuuuup original = + (* transparently expands deprecated macro [DU...UP] to [{ DIP n { DUP } ; DIG n }] *) match original with | Prim (loc, str, args, annot) -> let len = String.length str in @@ -563,19 +600,12 @@ let expand_duuuuup original = error (Invalid_arity (str, List.length args, 0)) ) >>? fun () -> try - let rec parse i acc = - if i = 1 then acc - else if str.[i] = 'U' then - parse - (i - 1) - (Seq - ( loc, - [Prim (loc, "DIP", [acc], []); Prim (loc, "SWAP", [], [])] - )) + let rec parse i = + if i = 1 then dupn loc loc (len - 2) annot + else if str.[i] = 'U' then parse (i - 1) else raise_notrace Not_a_dup in - ok - (Some (parse (len - 2) (Seq (loc, [Prim (loc, "DUP", [], annot)])))) + ok (Some (parse (len - 2))) with Not_a_dup -> ok None else ok None | _ -> @@ -787,12 +817,13 @@ let expand original = [ expand_caddadr; expand_set_caddadr; expand_map_caddadr; - expand_dxiiivp; + expand_deprecated_dxiiivp; (* expand_paaiair ; *) expand_pappaiir; (* expand_unpaaiair ; *) expand_unpappaiir; - expand_duuuuup; + expand_deprecated_duuuuup; + expand_dupn; expand_compare; expand_asserts; expand_if_some; @@ -972,48 +1003,8 @@ let unexpand_map_caddadr expanded = | None -> None -let roman_of_decimal decimal = - (* http://rosettacode.org/wiki/Roman_numerals/Encode#OCaml *) - let digit x y z = function - | 1 -> - [x] - | 2 -> - [x; x] - | 3 -> - [x; x; x] - | 4 -> - [x; y] - | 5 -> - [y] - | 6 -> - [y; x] - | 7 -> - [y; x; x] - | 8 -> - [y; x; x; x] - | 9 -> - [x; z] - | _ -> - assert false - in - let rec to_roman x = - if x = 0 then [] - else if x < 0 then invalid_arg "Negative roman numeral" - else if x >= 1000 then "M" :: to_roman (x - 1000) - else if x >= 100 then digit "C" "D" "M" (x / 100) @ to_roman (x mod 100) - else if x >= 10 then digit "X" "L" "C" (x / 10) @ to_roman (x mod 10) - else digit "I" "V" "X" x - in - String.concat "" (to_roman decimal) - -let dxiiivp_roman_of_decimal decimal = - let roman = roman_of_decimal decimal in - if String.length roman = 1 then - (* too short for D*P, fall back to IIIII... *) - String.concat "" (List.init decimal (fun _ -> "I")) - else roman - -let unexpand_dxiiivp expanded = +let unexpand_deprecated_dxiiivp expanded = + (* transparently turn the old expansion of deprecated [DI...IP] to [DIP n] *) match expanded with | Seq ( loc, @@ -1026,32 +1017,34 @@ let unexpand_dxiiivp expanded = (acc, sub) in let (depth, sub) = count 1 sub in - let name = "D" ^ dxiiivp_roman_of_decimal depth ^ "P" in - Some (Prim (loc, name, [sub], [])) + Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) | _ -> None -let unexpand_duuuuup expanded = - let rec help expanded = - match expanded with - | Seq (loc, [Prim (_, "DUP", [], [])]) -> - Some (loc, 1) - | Seq (_, [Prim (_, "DIP", [expanded'], []); Prim (_, "SWAP", [], [])]) - -> ( - match help expanded' with - | None -> - None - | Some (loc, n) -> - Some (loc, n + 1) ) +let unexpand_dupn expanded = + match expanded with + | Seq + ( loc, + [ Prim + (_, "DIP", [Int (_, np); Seq (_, [Prim (_, "DUP", [], annot)])], []); + Prim (_, "DIG", [Int (nloc, ng)], []) ] ) + when Z.equal np (Z.pred ng) -> + Some (Prim (loc, "DUP", [Int (nloc, ng)], annot)) + | _ -> + None + +let unexpand_deprecated_duuuuup expanded = + (* transparently turn the old expansion of deprecated [DU...UP] to [DUP n] *) + let rec expand n = function + | Seq (loc, [Prim (nloc, "DUP", [], annot)]) -> + if n = 1 then None + else Some (Prim (loc, "DUP", [Int (nloc, Z.of_int n)], annot)) + | Seq (_, [Prim (_, "DIP", [expanded'], []); Prim (_, "SWAP", [], [])]) -> + expand (n + 1) expanded' | _ -> None in - let rec dupn = function 0 -> "P" | n -> "U" ^ dupn (n - 1) in - match help expanded with - | None -> - None - | Some (loc, n) -> - Some (Prim (loc, "D" ^ dupn n, [], [])) + expand 1 expanded let rec normalize_pair_item ?(right = false) = function | P (i, a, b) -> @@ -1072,6 +1065,35 @@ let unexpand_pappaiir expanded = match (nodes, stack) with | ([], _) -> stack + (* support new expansion using [DIP n] *) + | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, + a :: rstack ) + when Z.to_int n > 1 -> + exec + ( a + :: exec + rstack + [ Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []) + ] ) + rest + | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + when Z.to_int n = 1 -> + exec (a :: exec rstack sub) rest + | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + when Z.to_int n > 1 -> + exec + ( A + :: exec + [] + [ Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []) + ] ) + rest + | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + when Z.to_int n = 1 -> + exec (A :: exec [] sub) rest + (* support old expansion using [DIP] *) | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> exec (a :: exec rstack sub) rest | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> @@ -1104,6 +1126,35 @@ let unexpand_unpappaiir expanded = match (nodes, stack) with | ([], _) -> stack + (* support new expansion using [DIP n] *) + | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, + a :: rstack ) + when Z.to_int n > 1 -> + exec + ( a + :: exec + rstack + [ Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []) + ] ) + rest + | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + when Z.to_int n = 1 -> + exec (a :: exec rstack sub) rest + | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + when Z.to_int n > 1 -> + exec + ( A + :: exec + [] + [ Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []) + ] ) + rest + | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + when Z.to_int n = 1 -> + exec (A :: exec [] sub) rest + (* support old expansion using [DIP] *) | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> exec (a :: exec rstack sub) rest | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> @@ -1417,10 +1468,11 @@ let unexpand original = unexpand_caddadr; unexpand_set_caddadr; unexpand_map_caddadr; - unexpand_dxiiivp; + unexpand_deprecated_dxiiivp; unexpand_pappaiir; unexpand_unpappaiir; - unexpand_duuuuup; + unexpand_deprecated_duuuuup; + unexpand_dupn; unexpand_compare; unexpand_if_some; unexpand_if_right; @@ -1485,8 +1537,8 @@ let () = ppf "Macro %s expects %d arguments, was given %d." name - got - exp) + exp + got) (obj3 (req "macro_name" string) (req "given_number_of_arguments" uint16) diff --git a/src/proto_alpha/lib_client/michelson_v1_macros.mli b/src/proto_alpha/lib_client/michelson_v1_macros.mli index 2e68d9d0633166100524d02c3fddfca0cde7dabc..352a59b00a9e9f00c927b90690d1189874510d90 100644 --- a/src/proto_alpha/lib_client/michelson_v1_macros.mli +++ b/src/proto_alpha/lib_client/michelson_v1_macros.mli @@ -43,11 +43,11 @@ val expand_set_caddadr : 'l node -> 'l node option tzresult val expand_map_caddadr : 'l node -> 'l node option tzresult -val expand_dxiiivp : 'l node -> 'l node option tzresult +val expand_deprecated_dxiiivp : 'l node -> 'l node option tzresult val expand_pappaiir : 'l node -> 'l node option tzresult -val expand_duuuuup : 'l node -> 'l node option tzresult +val expand_deprecated_duuuuup : 'l node -> 'l node option tzresult val expand_compare : 'l node -> 'l node option tzresult @@ -69,11 +69,11 @@ val unexpand_set_caddadr : 'l node -> 'l node option val unexpand_map_caddadr : 'l node -> 'l node option -val unexpand_dxiiivp : 'l node -> 'l node option +val unexpand_deprecated_dxiiivp : 'l node -> 'l node option val unexpand_pappaiir : 'l node -> 'l node option -val unexpand_duuuuup : 'l node -> 'l node option +val unexpand_deprecated_duuuuup : 'l node -> 'l node option val unexpand_compare : 'l node -> 'l node option diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.ml b/src/proto_alpha/lib_client/michelson_v1_printer.ml index 991a1de9f195355b9ab9406f560fb9f50be23c20..f091a1a0c0b5177eec92b94926ff8ab23e615c1c 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.ml +++ b/src/proto_alpha/lib_client/michelson_v1_printer.ml @@ -78,6 +78,45 @@ let print_execution_trace ppf trace = ppf trace +let print_big_map_diff ppf diff = + let pp_map ppf id = + if Compare.Z.(id < Z.zero) then + Format.fprintf ppf "temp(%s)" (Z.to_string (Z.neg id)) + else Format.fprintf ppf "map(%s)" (Z.to_string id) + in + Format.fprintf + ppf + "@[%a@]" + (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf -> + function + | Contract.Clear id -> + Format.fprintf ppf "Clear %a" pp_map id + | Contract.Alloc {big_map; key_type; value_type} -> + Format.fprintf + ppf + "New %a of type (big_map %a %a)" + pp_map + big_map + print_expr + key_type + print_expr + value_type + | Contract.Copy (src, dst) -> + Format.fprintf ppf "Copy %a to %a" pp_map src pp_map dst + | Contract.Update {big_map; diff_key; diff_value; _} -> + Format.fprintf + ppf + "%s %a[%a]%a" + (match diff_value with None -> "Unset" | Some _ -> "Set") + pp_map + big_map + print_expr + diff_key + (fun ppf -> function None -> () | Some x -> + Format.fprintf ppf " to %a" print_expr x) + diff_value)) + diff + let inject_types type_map parsed = let rec inject_expr = function | Seq (loc, items) -> diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.mli b/src/proto_alpha/lib_client/michelson_v1_printer.mli index 673a29bc7900e4579ed07877ee1a124a85692daa..769a6817fe06680c961dd23f38eaf97e4b38f9ad 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.mli +++ b/src/proto_alpha/lib_client/michelson_v1_printer.mli @@ -36,6 +36,8 @@ val print_execution_trace : (Script.location * Gas.t * (Script.expr * string option) list) list -> unit +val print_big_map_diff : Format.formatter -> Contract.big_map_diff -> unit + (** Insert the type map returned by the typechecker as comments in a printable Micheline AST. *) val inject_types : diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index 3ca22e865f115b35d1053787a114ef8c5b7f1e1c..b86516d3a9cffdcb672bace57eba5b1908ff7492 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -31,7 +31,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ((operation, result) : kind manager_operation * _) = Format.fprintf ppf "@[" ; ( match operation with - | Transaction {destination; amount; parameters} -> + | Transaction {destination; amount; parameters; entrypoint} -> Format.fprintf ppf "@[%s:@,Amount: %s%a@,From: %a@,To: %a" @@ -43,63 +43,53 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf source Contract.pp destination ; - ( match parameters with - | None -> + ( match entrypoint with + | "default" -> () - | Some expr -> - let expr = - Option.unopt_exn - (Failure "ill-serialized argument") - (Data_encoding.force_decode expr) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr ) ; + | _ -> + Format.fprintf ppf "@,Entrypoint: %s" entrypoint ) ; + ( if not (Script_repr.is_unit_parameter parameters) then + let expr = + Option.unopt_exn + (Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr ) ; pp_result ppf result ; Format.fprintf ppf "@]" - | Origination - { manager; - delegate; - credit; - spendable; - delegatable; - script; - preorigination = _ } -> + | Origination {delegate; credit; script = {code; storage}; preorigination = _} + -> Format.fprintf ppf - "@[%s:@,From: %a@,For: %a@,Credit: %s%a" + "@[%s:@,From: %a@,Credit: %s%a" (if internal then "Internal origination" else "Origination") Contract.pp source - Signature.Public_key_hash.pp - manager Client_proto_args.tez_sym Tez.pp credit ; - ( match script with - | None -> - Format.fprintf ppf "@,No script (accepts all transactions)" - | Some {code; storage} -> - let code = - Option.unopt_exn - (Failure "ill-serialized code") - (Data_encoding.force_decode code) - and storage = - Option.unopt_exn - (Failure "ill-serialized storage") - (Data_encoding.force_decode storage) - in - let {Michelson_v1_parser.source; _} = - Michelson_v1_printer.unparse_toplevel code - in - Format.fprintf - ppf - "@,@[Script:@ @[%a@]@,@[Initial storage:@ %a@]" - Format.pp_print_text - source - Michelson_v1_printer.print_expr - storage ) ; + let code = + Option.unopt_exn + (Failure "ill-serialized code") + (Data_encoding.force_decode code) + and storage = + Option.unopt_exn + (Failure "ill-serialized storage") + (Data_encoding.force_decode storage) + in + let {Michelson_v1_parser.source; _} = + Michelson_v1_printer.unparse_toplevel code + in + Format.fprintf + ppf + "@,@[Script:@ @[%a@]@,@[Initial storage:@ %a@]" + Format.pp_print_text + source + Michelson_v1_printer.print_expr + storage ; ( match delegate with | None -> Format.fprintf ppf "@,No delegate for this contract" @@ -109,11 +99,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf "@,Delegate: %a" Signature.Public_key_hash.pp delegate ) ; - if spendable then Format.fprintf ppf "@,Spendable by the manager" ; - if delegatable then - Format.fprintf ppf "@,Delegate can be changed by the manager" ; - pp_result ppf result ; - Format.fprintf ppf "@]" + pp_result ppf result ; Format.fprintf ppf "@]" | Reveal key -> Format.fprintf ppf @@ -220,7 +206,7 @@ let pp_manager_operation_contents_and_result ppf originated_contracts; storage_size; paid_storage_size_diff; - big_map_diff = _; + big_map_diff; allocated_destination_contract = _ }) = ( match originated_contracts with | [] -> @@ -240,6 +226,15 @@ let pp_manager_operation_contents_and_result ppf "@,@[Updated storage:@ %a@]" Michelson_v1_printer.print_expr expr ) ; + ( match big_map_diff with + | None | Some [] -> + () + | Some diff -> + Format.fprintf + ppf + "@,@[Updated big_maps:@ %a@]" + Michelson_v1_printer.print_big_map_diff + diff ) ; if storage_size <> Z.zero then Format.fprintf ppf "@,Storage size: %s bytes" (Z.to_string storage_size) ; if paid_storage_size_diff <> Z.zero then @@ -260,7 +255,8 @@ let pp_manager_operation_contents_and_result ppf in let pp_origination_result (Origination_result - { balance_updates; + { big_map_diff; + balance_updates; consumed_gas; originated_contracts; storage_size; @@ -276,6 +272,15 @@ let pp_manager_operation_contents_and_result ppf contracts ) ; if storage_size <> Z.zero then Format.fprintf ppf "@,Storage size: %s bytes" (Z.to_string storage_size) ; + ( match big_map_diff with + | None | Some [] -> + () + | Some diff -> + Format.fprintf + ppf + "@,@[Updated big_maps:@ %a@]" + Michelson_v1_printer.print_big_map_diff + diff ) ; if paid_storage_size_diff <> Z.zero then Format.fprintf ppf @@ -342,7 +347,7 @@ let pp_manager_operation_contents_and_result ppf Expected counter: %s@,\ Gas limit: %s@,\ Storage limit: %s bytes" - Contract.pp + Signature.Public_key_hash.pp source Client_proto_args.tez_sym Tez.pp @@ -362,7 +367,10 @@ let pp_manager_operation_contents_and_result ppf Format.fprintf ppf "@,%a" - (pp_manager_operation_content source false pp_result) + (pp_manager_operation_content + (Contract.implicit_contract source) + false + pp_result) (operation, operation_result) ; ( match internal_operation_results with | [] -> diff --git a/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml b/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml index f2a287707ee1fa2850410395b6c63b4d30e910c5..73f3a569e91cdcb6a16b0278e25929e424aed470 100644 --- a/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml +++ b/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml @@ -265,10 +265,17 @@ let test_assert_right () = let test_diip () = let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - let dip = Prim (zero_loc, "DIP", [code], []) in + assert_expands + (Prim (zero_loc, "DIP", [code], [])) + (Prim (zero_loc, "DIP", [code], [])) + >>? fun () -> + assert_expands + (Prim (zero_loc, "DIIIIIIIIP", [code], [])) + (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 8); code], [])) + >>? fun () -> assert_expands (Prim (zero_loc, "DIIP", [code], [])) - (Seq (zero_loc, [Prim (zero_loc, "DIP", [Seq (zero_loc, [dip])], [])])) + (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])) (* pair *) @@ -698,7 +705,7 @@ let test_unexpand_duup () = [Seq (zero_loc, [Prim (zero_loc, "DUP", [], [])])], [] ); Prim (zero_loc, "SWAP", [], []) ] )) - (Prim (zero_loc, "DUUP", [], [])) + (Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], [])) let test_unexpand_caddadr () = let car = Prim (zero_loc, "CAR", [], []) in @@ -822,10 +829,9 @@ let test_unexpand_map_car () = let test_unexpand_diip () = let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - let dip = Prim (zero_loc, "DIP", [code], []) in assert_unexpansion (Prim (zero_loc, "DIIP", [code], [])) - (Seq (zero_loc, [Prim (zero_loc, "DIP", [Seq (zero_loc, [dip])], [])])) + (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])) let test_unexpand_map_cdr () = let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in @@ -922,7 +928,9 @@ let test_unexpand_diip_duup1 () = let cst str = Prim (zero_loc, str, [], []) in let app str code = Prim (zero_loc, str, [code], []) in let dip = app "DIP" in - let diip = app "DIIP" in + let diip code = + Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []) + in let dup = cst "DUP" in let swap = cst "SWAP" in let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in @@ -937,9 +945,11 @@ let test_unexpand_diip_duup2 () = let cst str = Prim (zero_loc, str, [], []) in let app str code = Prim (zero_loc, str, [code], []) in let dip = app "DIP" in - let diip = app "DIIP" in + let diip code = + Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []) + in let dup = cst "DUP" in - let duup = cst "DUUP" in + let duup = Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], []) in let swap = cst "SWAP" in let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in assert_unexpansion diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index d04221b24f7bcc0edab79eca17fd7b09935c57b7..f7f5d9989a2285575db5e857c7b448ed54b89404 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -158,7 +158,7 @@ let commands version () = ~group ~desc: "Get the value associated to a key in the big map storage of a \ - contract." + contract (deprecated)." no_options ( prefixes ["get"; "big"; "map"; "value"; "for"] @@ Clic.param ~name:"key" ~desc:"the key to look for" data_parameter @@ -168,7 +168,7 @@ let commands version () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop ) (fun () key key_type (_, contract) (cctxt : Protocol_client_context.full) -> - get_big_map_value + get_contract_big_map_value cctxt ~chain:cctxt#chain ~block:cctxt#block @@ -180,6 +180,32 @@ let commands version () = | Some value -> cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value >>= fun () -> return_unit); + command + ~group + ~desc:"Get a value in a big map." + no_options + ( prefixes ["get"; "element"] + @@ Clic.param + ~name:"key" + ~desc:"the key to look for" + (Clic.parameter (fun _ s -> + return (Script_expr_hash.of_b58check_exn s))) + @@ prefixes ["of"; "big"; "map"] + @@ Clic.param + ~name:"big_map" + ~desc:"identifier of the big_map" + int_parameter + @@ stop ) + (fun () key id (cctxt : Protocol_client_context.full) -> + get_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + (Z.of_int id) + key + >>=? fun value -> + cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value + >>= fun () -> return_unit); command ~group ~desc:"Get the storage of a contract." @@ -206,29 +232,6 @@ let commands version () = Michelson_v1_printer.unparse_toplevel code in cctxt#answer "%a" Format.pp_print_text source >>= return )); - command - ~group - ~desc:"Get the manager of a contract." - no_options - ( prefixes ["get"; "manager"; "for"] - @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" - @@ stop ) - (fun () (_, contract) (cctxt : Protocol_client_context.full) -> - Client_proto_contracts.get_manager - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - contract - >>=? fun manager -> - Public_key_hash.rev_find cctxt manager - >>=? fun mn -> - Public_key_hash.to_source manager - >>=? fun m -> - cctxt#message - "%s (%s)" - m - (match mn with None -> "unknown" | Some n -> "known as " ^ n) - >>= fun () -> return_unit); command ~group ~desc:"Get the delegate of a contract." @@ -297,22 +300,26 @@ let commands version () = burn_cap; } in - source_to_keys cctxt ~chain:cctxt#chain ~block:cctxt#block contract - >>=? fun (src_pk, manager_sk) -> - set_delegate - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - ?fee - contract - (Some delegate) - ~src_pk - ~manager_sk - >>=? fun _ -> return_unit); + match Contract.is_implicit contract with + | None -> + failwith "only implicit accounts can be delegated" + | Some mgr -> + Client_keys.get_key cctxt mgr + >>=? fun (_, src_pk, manager_sk) -> + set_delegate + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ?fee + mgr + (Some delegate) + ~src_pk + ~manager_sk + >>=? fun _ -> return_unit); command ~group ~desc:"Withdraw the delegate from a contract." @@ -340,236 +347,240 @@ let commands version () = burn_cap ) (_, contract) (cctxt : Protocol_client_context.full) -> - source_to_keys cctxt ~chain:cctxt#chain ~block:cctxt#block contract - >>=? fun (src_pk, manager_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - set_delegate - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - contract - None - ?fee - ~src_pk - ~manager_sk - >>=? fun _ -> return_unit); + match Contract.is_implicit contract with + | None -> + failwith "only implicit accounts can be delegated" + | Some mgr -> + Client_keys.get_key cctxt mgr + >>=? fun (_, src_pk, manager_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + set_delegate + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + mgr + None + ?fee + ~src_pk + ~manager_sk + >>=? fun _ -> return_unit); command ~group - ~desc:"Open a new account." - (args12 + ~desc:"Launch a smart contract on the blockchain." + (args15 fee_arg dry_run_switch verbose_signing_switch + gas_limit_arg + storage_limit_arg delegate_arg - delegatable_switch (Client_keys.force_switch ()) + init_arg + no_print_source_flag minimal_fees_arg minimal_nanotez_per_byte_arg minimal_nanotez_per_gas_unit_arg force_low_fee_arg fee_cap_arg burn_cap_arg) - ( prefixes ["originate"; "account"] + ( prefixes ["originate"; "contract"] @@ RawContractAlias.fresh_alias_param ~name:"new" ~desc:"name of the new contract" - @@ prefix "for" - @@ Public_key_hash.source_param - ~name:"mgr" - ~desc:"manager of the new contract" @@ prefix "transferring" @@ tez_param ~name:"qty" ~desc:"amount taken from source" @@ prefix "from" @@ ContractAlias.destination_param ~name:"src" ~desc:"name of the source contract" + @@ prefix "running" + @@ Program.source_param + ~name:"prg" + ~desc: + "script of the account\n\ + Combine with -init if the storage type is not unit." @@ stop ) (fun ( fee, dry_run, verbose_signing, + gas_limit, + storage_limit, delegate, - delegatable, force, + initial_storage, + no_print_source, minimal_fees, minimal_nanotez_per_byte, minimal_nanotez_per_gas_unit, force_low_fee, fee_cap, burn_cap ) - new_contract - manager_pkh + alias_name balance (_, source) + program (cctxt : Protocol_client_context.full) -> - RawContractAlias.of_fresh cctxt force new_contract + RawContractAlias.of_fresh cctxt force alias_name >>=? fun alias_name -> - source_to_keys cctxt ~chain:cctxt#chain ~block:cctxt#block source - >>=? fun (src_pk, src_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - originate_account - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ?fee - ?delegate - ~delegatable - ~manager_pkh - ~balance - ~fee_parameter - ~source - ~src_pk - ~src_sk - () - >>=? fun (_res, contract) -> - if dry_run then return_unit - else - save_contract ~force cctxt alias_name contract - >>=? fun () -> return_unit); + Lwt.return (Micheline_parser.no_parsing_error program) + >>=? fun {expanded = code; _} -> + match Contract.is_implicit source with + | None -> + failwith + "only implicit accounts can be the source of an origination" + | Some source -> ( + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + originate_contract + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ?fee + ?gas_limit + ?storage_limit + ~delegate + ~initial_storage + ~balance + ~source + ~src_pk + ~src_sk + ~code + ~fee_parameter + () + >>= fun errors -> + report_michelson_errors + ~no_print_source + ~msg:"origination simulation failed" + cctxt + errors + >>= function + | None -> + return_unit + | Some (_res, contract) -> + if dry_run then return_unit + else + save_contract ~force cctxt alias_name contract + >>=? fun () -> return_unit )); command ~group - ~desc:"Launch a smart contract on the blockchain." - (args17 + ~desc:"Transfer tokens / call a smart contract." + (args15 fee_arg dry_run_switch verbose_signing_switch gas_limit_arg storage_limit_arg - delegate_arg - (Client_keys.force_switch ()) - delegatable_switch - spendable_switch - init_arg + counter_arg + arg_arg no_print_source_flag minimal_fees_arg minimal_nanotez_per_byte_arg minimal_nanotez_per_gas_unit_arg force_low_fee_arg fee_cap_arg - burn_cap_arg) - ( prefixes ["originate"; "contract"] - @@ RawContractAlias.fresh_alias_param - ~name:"new" - ~desc:"name of the new contract" - @@ prefix "for" - @@ Public_key_hash.source_param - ~name:"mgr" - ~desc:"manager of the new contract" - @@ prefix "transferring" + burn_cap_arg + entrypoint_arg) + ( prefixes ["transfer"] @@ tez_param ~name:"qty" ~desc:"amount taken from source" @@ prefix "from" @@ ContractAlias.destination_param ~name:"src" ~desc:"name of the source contract" - @@ prefix "running" - @@ Program.source_param - ~name:"prg" - ~desc: - "script of the account\n\ - Combine with -init if the storage type is not unit." + @@ prefix "to" + @@ ContractAlias.destination_param + ~name:"dst" + ~desc:"name/literal of the destination contract" @@ stop ) (fun ( fee, dry_run, verbose_signing, gas_limit, storage_limit, - delegate, - force, - delegatable, - spendable, - initial_storage, + counter, + arg, no_print_source, minimal_fees, minimal_nanotez_per_byte, minimal_nanotez_per_gas_unit, force_low_fee, fee_cap, - burn_cap ) - alias_name - manager - balance + burn_cap, + entrypoint ) + amount (_, source) - program - (cctxt : Protocol_client_context.full) -> - RawContractAlias.of_fresh cctxt force alias_name - >>=? fun alias_name -> - Lwt.return (Micheline_parser.no_parsing_error program) - >>=? fun {expanded = code; _} -> - source_to_keys cctxt ~chain:cctxt#chain ~block:cctxt#block source - >>=? fun (src_pk, src_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - originate_contract - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ?fee - ?gas_limit - ?storage_limit - ~delegate - ~delegatable - ~spendable - ~initial_storage - ~manager - ~balance - ~source - ~src_pk - ~src_sk - ~code - ~fee_parameter - () - >>= fun errors -> - report_michelson_errors - ~no_print_source - ~msg:"origination simulation failed" - cctxt - errors - >>= function + (_, destination) + cctxt -> + match Contract.is_implicit source with | None -> - return_unit - | Some (_res, contract) -> - if dry_run then return_unit - else - save_contract ~force cctxt alias_name contract - >>=? fun () -> return_unit); + failwith "only implicit accounts can be the source of a transfer" + | Some source -> ( + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + transfer + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~destination + ?entrypoint + ?arg + ~amount + ?gas_limit + ?storage_limit + ?counter + () + >>= report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + >>= function + | None -> return_unit | Some (_res, _contracts) -> return_unit )); command ~group - ~desc:"Transfer tokens / call a smart contract." + ~desc:"Call a smart contract (same as 'transfer 0')." (args14 fee_arg dry_run_switch @@ -585,8 +596,7 @@ let commands version () = force_low_fee_arg fee_cap_arg burn_cap_arg) - ( prefixes ["transfer"] - @@ tez_param ~name:"qty" ~desc:"amount taken from source" + ( prefixes ["call"] @@ prefix "from" @@ ContractAlias.destination_param ~name:"src" @@ -610,47 +620,51 @@ let commands version () = force_low_fee, fee_cap, burn_cap ) - amount (_, source) (_, destination) cctxt -> - source_to_keys cctxt ~chain:cctxt#chain ~block:cctxt#block source - >>=? fun (src_pk, src_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - transfer - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~destination - ?arg - ~amount - ?gas_limit - ?storage_limit - ?counter - () - >>= report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" + match Contract.is_implicit source with + | None -> + failwith "only implicit accounts can be the source of a transfer" + | Some source -> ( + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + let amount = Tez.zero in + transfer cctxt - >>= function - | None -> return_unit | Some (_res, _contracts) -> return_unit); + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~destination + ?arg + ~amount + ?gas_limit + ?storage_limit + ?counter + () + >>= report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + >>= function + | None -> return_unit | Some (_res, _contracts) -> return_unit )); command ~group ~desc:"Reveal the public key of the contract manager." @@ -680,32 +694,36 @@ let commands version () = burn_cap ) (_, source) cctxt -> - source_to_keys cctxt ~chain:cctxt#chain ~block:cctxt#block source - >>=? fun (src_pk, src_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - reveal - cctxt - ~dry_run - ~verbose_signing - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~source - ?fee - ~src_pk - ~src_sk - ~fee_parameter - () - >>=? fun _res -> return_unit); + match Contract.is_implicit source with + | None -> + failwith "only implicit accounts can be revealed" + | Some source -> + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + reveal + cctxt + ~dry_run + ~verbose_signing + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~source + ?fee + ~src_pk + ~src_sk + ~fee_parameter + () + >>=? fun _res -> return_unit); command ~group ~desc:"Register the public key hash as a delegate." @@ -765,7 +783,7 @@ let commands version () = cctxt#message "Delegate already activated." >>= fun () -> return_unit | Error el -> - Lwt.return (Error el)) ] + Lwt.return_error el) ] @ ( if version = Some `Mainnet then [] else [ command @@ -949,7 +967,7 @@ let commands version () = ~long:"force" ())) ( prefixes ["submit"; "proposals"; "for"] - @@ ContractAlias.destination_param + @@ Client_keys.Secret_key.alias_param ~name:"delegate" ~desc:"the delegate who makes the proposal" @@ seq_of_param @@ -963,9 +981,13 @@ let commands version () = | Some hash -> return hash))) ) (fun (dry_run, verbose_signing, force) - (_name, source) + (src_name, src_sk) proposals (cctxt : Protocol_client_context.full) -> + Client_keys.neuterize src_sk + >>=? fun src_pk -> + Client_keys.public_key_hash src_pk + >>=? fun (src_pkh, _) -> get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt >>=? fun info -> ( match info.current_period_kind with @@ -980,12 +1002,6 @@ let commands version () = >>=? fun known_proposals -> Alpha_services.Voting.listings cctxt (cctxt#chain, cctxt#block) >>=? fun listings -> - Client_proto_context.get_manager - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - source - >>=? fun (src_name, src_pkh, _src_pk, src_sk) -> (* for a proposal to be valid it must either a protocol that was already proposed by somebody else or a protocol known by the node, because the user is the first proposer and just injected it with @@ -1105,7 +1121,7 @@ let commands version () = ~desc:"Submit a ballot" (args2 verbose_signing_switch dry_run_switch) ( prefixes ["submit"; "ballot"; "for"] - @@ ContractAlias.destination_param + @@ Client_keys.Secret_key.alias_param ~name:"delegate" ~desc:"the delegate who votes" @@ param @@ -1135,10 +1151,14 @@ let commands version () = failwith "Invalid ballot: '%s'" s)) @@ stop ) (fun (verbose_signing, dry_run) - (_name, source) + (_, src_sk) proposal ballot (cctxt : Protocol_client_context.full) -> + Client_keys.neuterize src_sk + >>=? fun src_pk -> + Client_keys.public_key_hash src_pk + >>=? fun (src_pkh, _) -> get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt >>=? fun info -> ( match info.current_period_kind with @@ -1147,12 +1167,6 @@ let commands version () = | _ -> cctxt#error "Not in a Testing_vote or Promotion_vote period" ) >>=? fun () -> - Client_proto_context.get_manager - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - source - >>=? fun (_src_name, src_pkh, _src_pk, src_sk) -> submit_ballot cctxt ~chain:cctxt#chain diff --git a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml index 598ed43bea4f9e4de61638ad34893cfb073fd2dc..e7487e272c0a4289293cd95eacdc41fad50bb94a 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml @@ -85,15 +85,13 @@ let commands () : #Protocol_client_context.full Clic.command list = [ command ~group ~desc:"Originate a new multisig contract." - (args15 + (args13 Client_proto_args.fee_arg Client_proto_context_commands.dry_run_switch Client_proto_args.gas_limit_arg Client_proto_args.storage_limit_arg Client_proto_args.delegate_arg (Client_keys.force_switch ()) - Client_proto_args.delegatable_switch - Client_proto_args.spendable_switch Client_proto_args.no_print_source_flag Client_proto_args.minimal_fees_arg Client_proto_args.minimal_nanotez_per_byte_arg @@ -105,10 +103,6 @@ let commands () : #Protocol_client_context.full Clic.command list = @@ Client_proto_contracts.RawContractAlias.fresh_alias_param ~name:"new_multisig" ~desc:"name of the new multisig contract" - @@ prefix "for" - @@ Client_keys.Public_key_hash.source_param - ~name:"mgr" - ~desc:"manager of the new multisig contract" @@ prefix "transferring" @@ Client_proto_args.tez_param ~name:"qty" @@ -127,8 +121,6 @@ let commands () : #Protocol_client_context.full Clic.command list = storage_limit, delegate, force, - delegatable, - spendable, no_print_source, minimal_fees, minimal_nanotez_per_byte, @@ -137,7 +129,6 @@ let commands () : #Protocol_client_context.full Clic.command list = fee_cap, burn_cap ) alias_name - manager balance (_, source) threshold @@ -148,63 +139,61 @@ let commands () : #Protocol_client_context.full Clic.command list = force alias_name >>=? fun alias_name -> - Client_proto_context.source_to_keys - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - source - >>=? fun (src_pk, src_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) keys - >>=? fun keys -> - Client_proto_multisig.originate_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ?fee - ?gas_limit - ?storage_limit - ~delegate - ~delegatable - ~spendable - ~threshold:(Z.of_int threshold) - ~keys - ~manager - ~balance - ~source - ~src_pk - ~src_sk - ~fee_parameter - () - >>= fun errors -> - Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"multisig origination simulation failed" - cctxt - errors - >>= function + match Contract.is_implicit source with | None -> - return_unit - | Some (_res, contract) -> - if dry_run then return_unit - else - Client_proto_context.save_contract - ~force - cctxt - alias_name - contract - >>=? fun () -> return_unit); + failwith + "only implicit accounts can be the source of an origination" + | Some source -> ( + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) keys + >>=? fun keys -> + Client_proto_multisig.originate_multisig + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ?fee + ?gas_limit + ?storage_limit + ~delegate + ~threshold:(Z.of_int threshold) + ~keys + ~balance + ~source + ~src_pk + ~src_sk + ~fee_parameter + () + >>= fun errors -> + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"multisig origination simulation failed" + cctxt + errors + >>= function + | None -> + return_unit + | Some (_res, contract) -> + if dry_run then return_unit + else + Client_proto_context.save_contract + ~force + cctxt + alias_name + contract + >>=? fun () -> return_unit )); command ~group ~desc: @@ -607,47 +596,48 @@ let commands () : #Protocol_client_context.full Clic.command list = (_, source) signatures (cctxt : #Protocol_client_context.full) -> - Client_proto_context.source_to_keys - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - source - >>=? fun (src_pk, src_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - Client_proto_multisig.call_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~action:(Client_proto_multisig.Transfer (amount, destination)) - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" + match Contract.is_implicit source with + | None -> + failwith + "only implicit accounts can be the source of a contract call" + | Some source -> ( + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + Client_proto_multisig.call_multisig cctxt - >>= function - | None -> return_unit | Some (_res, _contracts) -> return_unit); + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~action:(Client_proto_multisig.Transfer (amount, destination)) + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + >>= Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + >>= function + | None -> return_unit | Some (_res, _contracts) -> return_unit )); command ~group ~desc:"Change the delegate of a multisig contract." @@ -683,47 +673,48 @@ let commands () : #Protocol_client_context.full Clic.command list = (_, source) signatures (cctxt : #Protocol_client_context.full) -> - Client_proto_context.source_to_keys - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - source - >>=? fun (src_pk, src_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - Client_proto_multisig.call_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~action:(Client_proto_multisig.Change_delegate (Some delegate)) - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" + match Contract.is_implicit source with + | None -> + failwith + "only implicit accounts can be the source of a contract call" + | Some source -> ( + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + Client_proto_multisig.call_multisig cctxt - >>= function - | None -> return_unit | Some (_res, _contracts) -> return_unit); + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~action:(Client_proto_multisig.Change_delegate (Some delegate)) + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + >>= Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + >>= function + | None -> return_unit | Some (_res, _contracts) -> return_unit )); command ~group ~desc:"Withdrow the delegate of a multisig contract." @@ -754,47 +745,48 @@ let commands () : #Protocol_client_context.full Clic.command list = (_, source) signatures (cctxt : #Protocol_client_context.full) -> - Client_proto_context.source_to_keys - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - source - >>=? fun (src_pk, src_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - Client_proto_multisig.call_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~action:(Client_proto_multisig.Change_delegate None) - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" + match Contract.is_implicit source with + | None -> + failwith + "only implicit accounts can be the source of a contract call" + | Some source -> ( + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + Client_proto_multisig.call_multisig cctxt - >>= function - | None -> return_unit | Some (_res, _contracts) -> return_unit); + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~action:(Client_proto_multisig.Change_delegate None) + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + >>= Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + >>= function + | None -> return_unit | Some (_res, _contracts) -> return_unit )); (* Unfortunately, Clic does not support non terminal lists of parameters so we cannot pass both a list of public keys and a list of signatures on the command line. This would permit a @@ -842,44 +834,62 @@ let commands () : #Protocol_client_context.full Clic.command list = (_, source) signatures (cctxt : #Protocol_client_context.full) -> - Client_proto_context.source_to_keys - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - source - >>=? fun (src_pk, src_sk) -> - let fee_parameter = - { - Injection.minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee; - fee_cap; - burn_cap; - } - in - Client_proto_multisig.call_multisig_on_bytes - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~bytes - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" + match Contract.is_implicit source with + | None -> + failwith + "only implicit accounts can be the source of a contract call" + | Some source -> ( + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + Client_proto_multisig.call_multisig_on_bytes cctxt - >>= function - | None -> return_unit | Some (_res, _contracts) -> return_unit) ] + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~bytes + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + >>= Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + >>= function + | None -> return_unit | Some (_res, _contracts) -> return_unit )); + command + ~group + ~desc:"Show the hashes of the supported multisig contracts." + no_options + (fixed ["show"; "supported"; "multisig"; "hashes"]) + (fun () _cctxt -> + Lwt.return Client_proto_multisig.known_multisig_hashes + >>=? fun l -> + Format.printf "Hashes of supported multisig contracts:@." ; + List.iter + (fun h -> + Format.printf + " 0x%a@." + Hex.pp + (Hex.of_bytes (Script_expr_hash.to_bytes h))) + l ; + return_unit) ] diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index 7544427272e8d03705521149fbeb056e0f9975f4..693c8c9f8c1598fc02059f4a04842e6b48320e25 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -149,13 +149,14 @@ let commands () = command ~group ~desc:"Ask the node to run a script." - (args6 + (args7 trace_stack_switch amount_arg source_arg payer_arg no_print_source_flag - custom_gas_flag) + custom_gas_flag + entrypoint_arg) ( prefixes ["run"; "script"] @@ Program.source_param @@ prefixes ["on"; "storage"] @@ -163,7 +164,7 @@ let commands () = @@ prefixes ["and"; "input"] @@ Clic.param ~name:"input" ~desc:"the input data" data_parameter @@ stop ) - (fun (trace_exec, amount, source, payer, no_print_source, gas) + (fun (trace_exec, amount, source, payer, no_print_source, gas, entrypoint) program storage input @@ -185,6 +186,7 @@ let commands () = ?source ?payer ?gas + ?entrypoint () >>= fun res -> print_trace_result cctxt ~show_source ~parsed:program res @@ -200,6 +202,7 @@ let commands () = ?source ?payer ?gas + ?entrypoint () >>= fun res -> print_run_result cctxt ~show_source ~parsed:program res); diff --git a/src/proto_alpha/lib_delegate/client_baking_blocks.ml b/src/proto_alpha/lib_delegate/client_baking_blocks.ml index 784b79d8cb357ba087b99183a39bbad29ff16a3a..eb2faacf9015218e312da3ad33891bb73f39e231 100644 --- a/src/proto_alpha/lib_delegate/client_baking_blocks.ml +++ b/src/proto_alpha/lib_delegate/client_baking_blocks.ml @@ -172,7 +172,7 @@ let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = >>=? fun {level; _} -> Alpha_services.Helpers.levels_in_current_cycle cctxt ~offset (chain, block) >>= function - | Error [RPC_context.Not_found _] -> + | Error (RPC_context.Not_found _ :: _) -> return_nil | Error _ as err -> Lwt.return err diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index 8ecf60182abb244b87c5222ebf498b7c5c0e3073..150ae4569226d269c9c224a540de3d9167a81c23 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -59,7 +59,8 @@ let default_minimal_nanotez_per_gas_unit = Z.of_int 100 let default_minimal_nanotez_per_byte = Z.of_int 1000 -let default_await_endorsements = true +type slot = + Time.Protocol.t * (Client_baking_blocks.block_info * int * public_key_hash) type state = { context_path : string; @@ -76,20 +77,14 @@ type state = { minimal_nanotez_per_gas_unit : Z.t; (* Minimal operation fee per byte required to include an operation in a block *) minimal_nanotez_per_byte : Z.t; - (* Await endorsements *) - await_endorsements : bool; (* truly mutable *) - mutable best_slot : - ( Time.Protocol.t - * (Client_baking_blocks.block_info * int * public_key_hash) ) - option; + mutable best_slot : slot option; } let create_state ?(minimal_fees = default_minimal_fees) ?(minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit) - ?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) - ?(await_endorsements = default_await_endorsements) context_path index - nonces_location delegates constants = + ?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) context_path + index nonces_location delegates constants = { context_path; index; @@ -99,7 +94,6 @@ let create_state ?(minimal_fees = default_minimal_fees) minimal_fees; minimal_nanotez_per_gas_unit; minimal_nanotez_per_byte; - await_endorsements; best_slot = None; } @@ -161,6 +155,23 @@ let assert_valid_operations_hash shell_header operations = shell_header.Tezos_base.Block_header.operations_hash) (failure "Client_baking_forge.inject_block: inconsistent header.") +let compute_endorsing_power cctxt ~chain ~block operations = + Shell_services.Chain.chain_id cctxt ~chain () + >>=? fun chain_id -> + fold_left_s + (fun sum -> function + | { Alpha_context.protocol_data = + Operation_data {contents = Single (Endorsement _); _}; + _ } as op -> + Delegate_services.Endorsing_power.get + cctxt + (chain, block) + op + chain_id + >>=? fun power -> return (sum + power) | _ -> return sum) + 0 + operations + let inject_block cctxt ?(force = false) ?seed_nonce_hash ~chain ~shell_header ~priority ~delegate_pkh ~delegate_sk ~level operations = assert_valid_operations_hash shell_header operations @@ -448,20 +459,15 @@ let all_ops_valid (results : error Preapply_result.t list) = && is_empty result.branch_delayed) results -let decode_priority cctxt chain block = function +let decode_priority cctxt chain block ~priority ~endorsing_power = + match priority with | `Set priority -> - Alpha_services.Delegate.Baking_rights.get + Alpha_services.Delegate.Minimal_valid_time.get cctxt - ~all:true - ~max_priority:(priority + 1) (chain, block) - >>=? fun rights -> - let time = - Option.apply - ~f:(fun r -> r.Alpha_services.Delegate.Baking_rights.timestamp) - (List.nth_opt rights priority) - in - return (priority, time) + priority + endorsing_power + >>=? fun minimal_timestamp -> return (priority, minimal_timestamp) | `Auto (src_pkh, max_priority) -> ( Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block) >>=? fun {level; _} -> @@ -473,34 +479,36 @@ let decode_priority cctxt chain block = function (chain, block) >>=? fun possibilities -> try - let { Alpha_services.Delegate.Baking_rights.priority = prio; - timestamp = time; - _ } = + let {Alpha_services.Delegate.Baking_rights.priority = prio; _} = List.find (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level) possibilities in - return (prio, time) + Alpha_services.Delegate.Minimal_valid_time.get + cctxt + (chain, block) + prio + endorsing_power + >>=? fun minimal_timestamp -> return (prio, minimal_timestamp) with Not_found -> failwith "No slot found at level %a" Raw_level.pp level ) -let unopt_timestamp timestamp minimal_timestamp = - match (timestamp, minimal_timestamp) with - | (None, None) -> - return (Time.System.to_protocol (Systime_os.now ())) - | (None, Some timestamp) -> - return timestamp - | (Some timestamp, None) -> - return timestamp - | (Some timestamp, Some minimal_timestamp) -> - if timestamp < minimal_timestamp then - failwith - "Proposed timestamp %a is earlier than minimal timestamp %a" - Time.Protocol.pp_hum - timestamp - Time.Protocol.pp_hum - minimal_timestamp - else return timestamp +let unopt_timestamp ?(force = false) timestamp minimal_timestamp = + let timestamp = + match timestamp with + | None -> + minimal_timestamp + | Some timestamp -> + timestamp + in + if (not force) && timestamp < minimal_timestamp then + failwith + "Proposed timestamp %a is earlier than minimal timestamp %a" + Time.Protocol.pp_hum + timestamp + Time.Protocol.pp_hum + minimal_timestamp + else return timestamp let merge_preapps (old : error Preapply_result.t) (neu : error Preapply_result.t) = @@ -542,17 +550,25 @@ let error_of_op (result : error Preapply_result.t) op = (op, snd @@ Operation_hash.Map.find h result.branch_delayed)) with Not_found -> None ) ) -let filter_and_apply_operations state block_info ~timestamp ?protocol_data +let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority + ?protocol_data ((operations : packed_operation list list), overflowing_operations) = + (* Retrieve the minimal valid time for when the block can be baked with 0 endorsements *) + Delegate_services.Minimal_valid_time.get cctxt (chain, block) priority 0 + >>=? fun min_valid_timestamp -> let open Client_baking_simulator in lwt_debug Tag.DSL.( fun f -> - f "Starting client-side validation %a" + f "starting client-side validation after %a" -% t event "baking_local_validation_start" -% a Block_hash.Logging.tag block_info.Client_baking_blocks.hash) >>= fun () -> - begin_construction ~timestamp ?protocol_data state.index block_info + begin_construction + ~timestamp:min_valid_timestamp + ?protocol_data + state.index + block_info >>= (function | Ok inc -> return inc @@ -572,7 +588,11 @@ let filter_and_apply_operations state block_info ~timestamp ?protocol_data Client_baking_simulator.load_context ~context_path:state.context_path >>= fun index -> - begin_construction ~timestamp ?protocol_data index block_info + begin_construction + ~timestamp:min_valid_timestamp + ?protocol_data + index + block_info >>=? fun inc -> state.index <- index ; return inc) @@ -610,38 +630,24 @@ let filter_and_apply_operations state block_info ~timestamp ?protocol_data (inc, []) ops in - (* Invalid endorsements are detected during block finalization *) - let is_valid_endorsement inc endorsement = - validate_operation inc endorsement - >>= function - | None -> - Lwt.return_none - | Some inc' -> ( - finalize_construction inc' - >>= function - | Ok _ -> Lwt.return_some endorsement | Error _ -> Lwt.return_none ) - in - filter_valid_operations initial_inc votes + (* First pass : we filter out invalid operations by applying them in the correct order *) + filter_valid_operations initial_inc endorsements + >>= fun (inc, endorsements) -> + filter_valid_operations inc votes >>= fun (inc, votes) -> filter_valid_operations inc anonymous - >>= fun (inc, anonymous) -> + >>= fun (manager_inc, anonymous) -> (* Retrieve the correct index order *) let managers = List.sort Protocol.compare_operations managers in let overflowing_operations = List.sort Protocol.compare_operations overflowing_operations in - filter_valid_operations inc (managers @ overflowing_operations) + filter_valid_operations manager_inc (managers @ overflowing_operations) >>= fun (inc, managers) -> - (* Gives a chance to the endorser to fund their deposit in the current block *) - Lwt_list.filter_map_s (is_valid_endorsement inc) endorsements - >>= fun endorsements -> finalize_construction inc >>=? fun _ -> let quota : Environment.Updater.quota list = Main.validation_passes in - let {Constants.endorsers_per_block; hard_gas_limit_per_block; _} = - state.constants.parametric - in - let endorsements = List.sub (List.rev endorsements) endorsers_per_block in + let {Constants.hard_gas_limit_per_block; _} = state.constants.parametric in let votes = retain_operations_up_to_quota (List.rev votes) (List.nth quota votes_index) in @@ -650,19 +656,6 @@ let filter_and_apply_operations state block_info ~timestamp ?protocol_data (List.rev anonymous) (List.nth quota anonymous_index) in - let is_evidence = function - | { protocol_data = - Operation_data {contents = Single (Double_baking_evidence _); _}; - _ } -> - true - | { protocol_data = - Operation_data {contents = Single (Double_endorsement_evidence _); _}; - _ } -> - true - | _ -> - false - in - let (evidences, anonymous) = List.partition is_evidence anonymous in trim_manager_operations ~max_size:(List.nth quota managers_index).max_size ~hard_gas_limit_per_block @@ -672,37 +665,43 @@ let filter_and_apply_operations state block_info ~timestamp ?protocol_data let accepted_managers = List.sort Protocol.compare_operations accepted_managers in - (* Make sure we only keep valid operations *) - filter_valid_operations initial_inc votes - >>= fun (inc, votes) -> - filter_valid_operations inc anonymous - >>= fun (inc, anonymous) -> - filter_valid_operations inc accepted_managers - >>= fun (inc, accepted_managers) -> - Lwt_list.filter_map_s (is_valid_endorsement inc) endorsements - >>= fun endorsements -> - (* Endorsements won't fail now *) + (* Second pass : make sure we only keep valid operations *) + filter_valid_operations manager_inc accepted_managers + >>= fun (_, accepted_managers) -> + (* Put the operations back in order *) + let operations = + List.map List.rev [endorsements; votes; anonymous; accepted_managers] + in + (* Construct a context with the valid operations and a correct timestamp *) + compute_endorsing_power cctxt ~chain ~block endorsements + >>=? fun current_endorsing_power -> + Delegate_services.Minimal_valid_time.get + cctxt + (chain, block) + priority + current_endorsing_power + >>=? fun expected_validity -> + (* Finally, we construct a block with the minimal possible timestamp + given the endorsing power *) + begin_construction + ~timestamp:expected_validity + ?protocol_data + state.index + block_info + >>=? fun inc -> fold_left_s (fun inc op -> add_operation inc op >>=? fun (inc, _receipt) -> return inc) inc - endorsements - >>=? fun inc -> - (* Endorsement and double baking/endorsement evidence do not commute: - we apply denunciation operations after endorsements. *) - filter_valid_operations inc evidences - >>= fun (final_inc, evidences) -> - let operations = - List.map - List.rev - [endorsements; votes; anonymous @ evidences; accepted_managers] - in + (List.flatten operations) + >>=? fun final_inc -> finalize_construction final_inc >>=? fun (validation_result, metadata) -> - return (final_inc, (validation_result, metadata), operations) + return + (final_inc, (validation_result, metadata), operations, expected_validity) (* Build the block header : mimics node prevalidation *) -let finalize_block_header pred_shell_header ~timestamp validation_result - operations = +let finalize_block_header shell_header ~timestamp validation_result operations + = let {Tezos_protocol_environment.context; fitness; message; _} = validation_result in @@ -732,8 +731,8 @@ let finalize_block_header pred_shell_header ~timestamp validation_result let header = Tezos_base.Block_header. { - pred_shell_header with - level = Int32.succ pred_shell_header.level; + shell_header with + level = Int32.succ shell_header.level; validation_passes; operations_hash; fitness; @@ -745,16 +744,17 @@ let finalize_block_header pred_shell_header ~timestamp validation_result let forge_block cctxt ?force ?operations ?(best_effort = operations = None) ?(sort = best_effort) ?(minimal_fees = default_minimal_fees) ?(minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit) - ?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) - ?(await_endorsements = default_await_endorsements) ?timestamp ?mempool - ?context_path ?seed_nonce_hash ~chain ~priority ~delegate_pkh ~delegate_sk - block = + ?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) ?timestamp + ?mempool ?context_path ?seed_nonce_hash ~chain ~priority ~delegate_pkh + ~delegate_sk block = (* making the arguments usable *) unopt_operations cctxt chain mempool operations >>=? fun operations_arg -> - decode_priority cctxt chain block priority + compute_endorsing_power cctxt ~chain ~block operations_arg + >>=? fun endorsing_power -> + decode_priority cctxt chain block ~priority ~endorsing_power >>=? fun (priority, minimal_timestamp) -> - unopt_timestamp timestamp minimal_timestamp + unopt_timestamp ?force timestamp minimal_timestamp >>=? fun timestamp -> (* get basic building blocks *) let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in @@ -832,19 +832,24 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) constants; delegates = []; best_slot = None; - await_endorsements; minimal_fees = default_minimal_fees; minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit; minimal_nanotez_per_byte = default_minimal_nanotez_per_byte; } in filter_and_apply_operations - ~timestamp - ~protocol_data + cctxt state + ~chain + ~block + ~priority + ~protocol_data bi (operations, overflowing_ops) - >>=? fun (final_context, (validation_result, _), operations) -> + >>=? fun ( final_context, + (validation_result, _), + operations, + min_valid_timestamp ) -> let current_protocol = bi.next_protocol in let context = Shell_context.unwrap_disk_context validation_result.context @@ -854,16 +859,16 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) if Protocol_hash.equal current_protocol next_protocol then finalize_block_header final_context.header - ~timestamp + ~timestamp:min_valid_timestamp validation_result operations >>= function - | Error [Forking_test_chain] -> + | Error (Forking_test_chain :: _) -> Alpha_block_services.Helpers.Preapply.block cctxt ~chain ~block - ~timestamp + ~timestamp:min_valid_timestamp ~sort ~protocol_data operations @@ -884,7 +889,7 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) cctxt ~chain ~block - ~timestamp + ~timestamp:min_valid_timestamp ~sort ~protocol_data operations @@ -898,8 +903,7 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) Tag.DSL.( fun f -> f - "Found %d valid operations (%d refused) for timestamp %a. Computed \ - fitness %a." + "found %d valid operations (%d refused) for timestamp %a (fitness %a)" -% t event "found_valid_operations" -% s valid_ops valid_op_count -% s refused_ops (total_op_count - valid_op_count) @@ -913,7 +917,7 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) lwt_log_error Tag.DSL.( fun f -> - f "@[Error on raw_level conversion : %a@]" + f "Error on raw_level conversion : %a" -% t event "block_injection_failed" -% a errs_tag errs) >>= fun () -> Lwt.return err ) @@ -945,8 +949,8 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) >>= fun () -> Lwt.return error let shell_prevalidation (cctxt : #Protocol_client_context.full) ~chain ~block - seed_nonce_hash operations ((timestamp, (bi, priority, delegate)) as _slot) - = + ~timestamp seed_nonce_hash operations + ((_, (bi, priority, delegate)) as _slot) = let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in Alpha_block_services.Helpers.Preapply.block cctxt @@ -985,62 +989,11 @@ let filter_outdated_endorsements expected_level ops = true) ops -let next_baking_delay state priority = - let {Constants.parametric = {time_between_blocks; _}; _} = state.constants in - let rec associated_period durations prio = - if List.length durations = 0 then - (* Mimic [Baking.minimal_time] behaviour *) - associated_period [Period.one_minute] prio - else - match durations with - | [] -> - assert false - | [last] -> - Period.to_seconds last - | first :: durations -> - if prio = 0 then Period.to_seconds first - else associated_period durations (prio - 1) - in - let span = associated_period time_between_blocks (priority + 1) in - return span - -let count_slots_endorsements inc (_timestamp, (head, _priority, _delegate)) - operations = - Lwt_list.fold_left_s - (fun acc -> function - | { Alpha_context.protocol_data = - Operation_data {contents = Single (Endorsement {level; _}); _}; - _ } as op - when Raw_level.(level = head.Client_baking_blocks.level) -> ( - let open Apply_results in - Client_baking_simulator.add_operation inc op - >>= function - | Ok - ( _inc, - Operation_metadata - {contents = Single_result (Endorsement_result {slots; _})} ) - -> - Lwt.return (acc + List.length slots) - | Error _ | _ -> - (* We do not handle errors here *) - Lwt.return acc ) | _ -> Lwt.return acc) - 0 - operations - -let rec filter_limits tnow limits = - match limits with - | [] -> - [] - | (time, _) :: _ as limits when Time.Protocol.(tnow < time) -> - limits - | _ :: limits -> - filter_limits tnow limits - (** [fetch_operations] retrieve the operations present in the mempool. If no endorsements are present in the initial set, it - waits until [state.max_waiting_time] seconds after its injection range start date. *) -let fetch_operations (cctxt : #Protocol_client_context.full) ~chain state - ((timestamp, (head, priority, _delegate)) as slot) = + waits until it's able to build a valid block. *) +let fetch_operations (cctxt : #Protocol_client_context.full) ~chain + (_, (head, priority, _delegate)) = Alpha_block_services.Mempool.monitor_operations cctxt ~chain @@ -1054,139 +1007,79 @@ let fetch_operations (cctxt : #Protocol_client_context.full) ~chain state Lwt_stream.get operation_stream >>= function | None -> - (* New head received : not supposed to happen. *) + (* New head received : aborting block construction *) return_none | Some current_mempool -> + let block = `Hash (head.Client_baking_blocks.hash, 0) in let operations = - ref - (filter_outdated_endorsements - head.Client_baking_blocks.level - current_mempool) + ref (filter_outdated_endorsements head.level current_mempool) in - Client_baking_simulator.begin_construction ~timestamp state.index head - >>=? fun inc -> - count_slots_endorsements inc slot !operations - >>= fun nb_arrived_endorsements -> - (* If 100% of the endorsements arrived, we don't need to wait *) - let endorsers_per_block = - state.constants.parametric.endorsers_per_block + (* Actively request our peers' for missing operations *) + Shell_services.Mempool.request_operations cctxt ~chain () + >>=? fun () -> + let compute_minimal_valid_time () = + compute_endorsing_power cctxt ~chain ~block !operations + >>=? fun current_endorsing_power -> + Delegate_services.Minimal_valid_time.get + cctxt + (chain, block) + priority + current_endorsing_power in - if - (not state.await_endorsements) - || nb_arrived_endorsements = endorsers_per_block - then return_some !operations - else - next_baking_delay state priority - >>=? fun next_slot_delay -> - let hard_delay = Int64.div next_slot_delay 2L in - (* The time limit is defined as 1/2 of the next baking slot's time *) - let limit_date = Time.Protocol.add timestamp hard_delay in - (* Time limits : - - We expect all of the endorsements until 1/3 of the time limit has passed ; - - We expect 2/3 of the endorsements until 2/3 of the time limit has passed ; - - We expect 1/3 of the endorsements until the time limit has passed ; - - We bake with what we have when the time limit has been reached. - *) - let limits = - [ ( Time.Protocol.add timestamp (Int64.div hard_delay 3L), - endorsers_per_block ); - ( Time.Protocol.add - timestamp - (Int64.div (Int64.mul hard_delay 2L) 3L), - 2 * endorsers_per_block / 3 ); - (limit_date, endorsers_per_block / 3) ] - in - let timespan = - let timespan = - Ptime.diff - (Time.System.of_protocol_exn limit_date) - (Systime_os.now ()) - in - if Ptime.Span.compare timespan Ptime.Span.zero > 0 then timespan - else Ptime.Span.zero - in - lwt_log_notice - Tag.DSL.( - fun f -> - f - "Waiting until %a (%a) for more endorsements in the mempool \ - (%a/%a arrived)." - -% t event "waiting_operations" - -% a timestamp_tag (Time.System.of_protocol_exn limit_date) - -% a timespan_tag timespan - -% a op_count nb_arrived_endorsements - -% a op_count endorsers_per_block) - >>= fun () -> - Shell_services.Mempool.request_operations cctxt ~chain () - >>=? fun () -> - let timeout = - match Client_baking_scheduling.sleep_until limit_date with - | None -> - Lwt.return_unit - | Some timeout -> - timeout - in - let last_get_event = ref None in - let get_event () = - match !last_get_event with - | None -> - let t = Lwt_stream.get operation_stream in - last_get_event := Some t ; - t - | Some t -> - t - in - let rec loop nb_arrived_endorsements limits = - Lwt.choose - [ (timeout >|= fun () -> `Timeout); - (get_event () >|= fun e -> `Event e) ] - >>= function - | `Event (Some op_list) -> - last_get_event := None ; - operations := op_list @ !operations ; - count_slots_endorsements inc slot op_list - >>= fun new_endorsements -> - let nb_arrived_endorsements = - nb_arrived_endorsements + new_endorsements - in - let limits = - filter_limits - (Time.System.to_protocol (Systime_os.now ())) - limits - in - let required = - match limits with - | [] -> - 0 (* If we are late, we do not require endorsements *) - | (_time, required) :: _ -> - required - in - let enough = nb_arrived_endorsements >= required in - if enough then - let remaining_ops = - List.flatten (Lwt_stream.get_available operation_stream) - in - let filtered_ops = - filter_outdated_endorsements - head.level - (remaining_ops @ !operations) - in - return_some filtered_ops - else loop nb_arrived_endorsements limits - | `Timeout -> - return_some !operations - | `Event None -> - (* New head received. Should not happen : let the - caller handle this case. *) - return_none - in - loop nb_arrived_endorsements limits + let compute_timeout () = + compute_minimal_valid_time () + >>=? fun expected_validity -> + match Client_baking_scheduling.sleep_until expected_validity with + | None -> + return_unit + | Some timeout -> + timeout >>= fun () -> return_unit + in + let last_get_event = ref None in + let get_event () = + match !last_get_event with + | None -> + let t = Lwt_stream.get operation_stream in + last_get_event := Some t ; + t + | Some t -> + t + in + let rec loop () = + Lwt.choose + [ (compute_timeout () >|= fun _ -> `Timeout); + (get_event () >|= fun e -> `Event e) ] + >>= function + | `Event (Some op_list) -> + last_get_event := None ; + let op_list = filter_outdated_endorsements head.level op_list in + operations := op_list @ !operations ; + loop () + | `Timeout -> + (* Retrieve the remaining operations present in the stream + before block construction *) + let remaining_operations = + filter_outdated_endorsements + head.level + (List.flatten (Lwt_stream.get_available operation_stream)) + in + operations := remaining_operations @ !operations ; + compute_minimal_valid_time () + >>=? fun expected_validity -> + return_some (!operations, expected_validity) + | `Event None -> + (* Got new head while waiting: + - not enough endorsements received ; + - late at baking *) + return_none + in + loop () (** Given a delegate baking slot [build_block] constructs a full block with consistent operations that went through the client-side validation *) let build_block cctxt state seed_nonce_hash - ((timestamp, (bi, priority, delegate)) as slot) = + ((slot_timestamp, (bi, priority, delegate)) as slot) = let chain = `Hash bi.Client_baking_blocks.chain_id in let block = `Hash (bi.hash, 0) in Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block) @@ -1204,9 +1097,9 @@ let build_block cctxt state seed_nonce_hash -% a Block_hash.Logging.tag bi.hash -% s bake_priority_tag priority -% s Client_keys.Logging.tag name - -% a timestamp_tag (Time.System.of_protocol_exn timestamp)) + -% a timestamp_tag (Time.System.of_protocol_exn slot_timestamp)) >>= fun () -> - fetch_operations cctxt ~chain state slot + fetch_operations cctxt ~chain slot >>=? function | None -> lwt_log_notice @@ -1217,7 +1110,7 @@ let build_block cctxt state seed_nonce_hash this block." -% t event "new_head_received") >>= fun () -> return_none - | Some operations -> ( + | Some (operations, timestamp) -> ( let hard_gas_limit_per_block = state.constants.parametric.hard_gas_limit_per_block in @@ -1243,15 +1136,25 @@ let build_block cctxt state seed_nonce_hash in if Protocol_hash.(Protocol.hash <> next_version) then (* Let the shell validate this *) - shell_prevalidation cctxt ~chain ~block seed_nonce_hash operations slot + shell_prevalidation + cctxt + ~chain + ~block + ~timestamp + seed_nonce_hash + operations + slot else let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in filter_and_apply_operations - ~timestamp - ~protocol_data + cctxt state + ~chain + ~block + ~priority + ~protocol_data bi (operations, overflowing_ops) >>= function @@ -1276,10 +1179,33 @@ let build_block cctxt state seed_nonce_hash cctxt ~chain ~block + ~timestamp seed_nonce_hash operations slot - | Ok (final_context, (validation_result, _), operations) -> + | Ok + (final_context, (validation_result, _), operations, valid_timestamp) + -> + ( if + Time.System.(Systime_os.now () < of_protocol_exn valid_timestamp) + then + lwt_log_notice + Tag.DSL.( + fun f -> + f "[%a] not ready to inject yet, waiting until %a" + -% a timestamp_tag (Systime_os.now ()) + -% a + timestamp_tag + (Time.System.of_protocol_exn valid_timestamp) + -% t event "waiting_before_injection") + >>= fun () -> + match Client_baking_scheduling.sleep_until valid_timestamp with + | None -> + Lwt.return_unit + | Some timeout -> + timeout + else Lwt.return_unit ) + >>= fun () -> lwt_debug Tag.DSL.( fun f -> @@ -1301,15 +1227,16 @@ let build_block cctxt state seed_nonce_hash if Protocol_hash.equal current_protocol next_protocol then finalize_block_header final_context.header - ~timestamp + ~timestamp:valid_timestamp validation_result operations >>= function - | Error [Forking_test_chain] -> + | Error (Forking_test_chain :: _) -> shell_prevalidation cctxt ~chain ~block + ~timestamp seed_nonce_hash operations slot @@ -1317,14 +1244,13 @@ let build_block cctxt state seed_nonce_hash Lwt.return errs | Ok shell_header -> let raw_ops = List.map (List.map forge) operations in - return - (Some - ( bi, - priority, - shell_header, - raw_ops, - delegate, - seed_nonce_hash )) + return_some + ( bi, + priority, + shell_header, + raw_ops, + delegate, + seed_nonce_hash ) else lwt_log_notice Tag.DSL.( @@ -1336,6 +1262,7 @@ let build_block cctxt state seed_nonce_hash cctxt ~chain ~block + ~timestamp seed_nonce_hash operations slot ) @@ -1575,8 +1502,8 @@ let reveal_potential_nonces (cctxt : #Client_context.full) constants ~chain starts individual baking operations when baking-slots are available to any of the [delegates] *) let create (cctxt : #Protocol_client_context.full) ?minimal_fees - ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?await_endorsements - ?max_priority ~chain ~context_path delegates block_stream = + ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?max_priority + ~chain ~context_path delegates block_stream = let state_maker bi = Alpha_services.Constants.all cctxt (chain, `Head 0) >>=? fun constants -> @@ -1593,7 +1520,6 @@ let create (cctxt : #Protocol_client_context.full) ?minimal_fees ?minimal_fees ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte - ?await_endorsements context_path index nonces_location diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.mli b/src/proto_alpha/lib_delegate/client_baking_forge.mli index e4c71ca832688464850fe1978712fc4193ffb495..45e6b71596025c66a9729120c1c04ceb80ef30dd 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.mli +++ b/src/proto_alpha/lib_delegate/client_baking_forge.mli @@ -81,7 +81,6 @@ val forge_block : ?minimal_fees:Tez.t -> ?minimal_nanotez_per_gas_unit:Z.t -> ?minimal_nanotez_per_byte:Z.t -> - ?await_endorsements:bool -> ?timestamp:Time.Protocol.t -> ?mempool:string -> ?context_path:string -> @@ -98,7 +97,6 @@ val create : ?minimal_fees:Tez.t -> ?minimal_nanotez_per_gas_unit:Z.t -> ?minimal_nanotez_per_byte:Z.t -> - ?await_endorsements:bool -> ?max_priority:int -> chain:Chain_services.chain -> context_path:string -> diff --git a/src/proto_alpha/lib_delegate/client_baking_lib.ml b/src/proto_alpha/lib_delegate/client_baking_lib.ml index 7aa03834a1f2bb8c33addeb184f71fe2e0ec62d2..72f1b91a6d810885c37a10eb5ae057e81a9dcd28 100644 --- a/src/proto_alpha/lib_delegate/client_baking_lib.ml +++ b/src/proto_alpha/lib_delegate/client_baking_lib.ml @@ -27,10 +27,9 @@ open Protocol open Alpha_context let bake_block (cctxt : #Protocol_client_context.full) ?minimal_fees - ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte - ?(await_endorsements = false) ?force ?max_priority - ?(minimal_timestamp = false) ?mempool ?context_path ?src_sk ~chain ~head - delegate = + ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?force + ?max_priority ?(minimal_timestamp = false) ?mempool ?context_path ?src_sk + ~chain ~head delegate = ( match src_sk with | None -> Client_keys.get_key cctxt delegate @@ -57,7 +56,6 @@ let bake_block (cctxt : #Protocol_client_context.full) ?minimal_fees ?minimal_fees ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte - ~await_endorsements ?timestamp ?seed_nonce_hash ?mempool diff --git a/src/proto_alpha/lib_delegate/client_baking_lib.mli b/src/proto_alpha/lib_delegate/client_baking_lib.mli index fbbba42252633c4de2834ba8a7d5c7174c9b98a9..3933545ada7af0101a6a48b1d47155141d4786d3 100644 --- a/src/proto_alpha/lib_delegate/client_baking_lib.mli +++ b/src/proto_alpha/lib_delegate/client_baking_lib.mli @@ -32,7 +32,6 @@ val bake_block : ?minimal_fees:Tez.t -> ?minimal_nanotez_per_gas_unit:Z.t -> ?minimal_nanotez_per_byte:Z.t -> - ?await_endorsements:bool -> ?force:bool -> ?max_priority:int -> ?minimal_timestamp:bool -> diff --git a/src/proto_alpha/lib_delegate/client_daemon.ml b/src/proto_alpha/lib_delegate/client_daemon.ml index e7e1b91762a231a7d8c0ab89397ad29daf5c626b..0a14069af352d758ae67d39b35935dd3652a87c3 100644 --- a/src/proto_alpha/lib_delegate/client_daemon.ml +++ b/src/proto_alpha/lib_delegate/client_daemon.ml @@ -128,8 +128,8 @@ end module Baker = struct let run (cctxt : #Protocol_client_context.full) ?minimal_fees - ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte - ?await_endorsements ?max_priority ~chain ~context_path delegates = + ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?max_priority + ~chain ~context_path delegates = await_bootstrapped_node cctxt >>=? fun _ -> ( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:true @@ -147,7 +147,6 @@ module Baker = struct ?minimal_fees ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte - ?await_endorsements ?max_priority ~chain ~context_path diff --git a/src/proto_alpha/lib_delegate/client_daemon.mli b/src/proto_alpha/lib_delegate/client_daemon.mli index 64c0c1ae28d777073df3b55f19b40fa1b9d80f81..c43c1cb8f5d0364053e12988b816d76309a69b75 100644 --- a/src/proto_alpha/lib_delegate/client_daemon.mli +++ b/src/proto_alpha/lib_delegate/client_daemon.mli @@ -41,7 +41,6 @@ module Baker : sig ?minimal_fees:Tez.t -> ?minimal_nanotez_per_gas_unit:Z.t -> ?minimal_nanotez_per_byte:Z.t -> - ?await_endorsements:bool -> ?max_priority:int -> chain:Chain_services.chain -> context_path:string -> diff --git a/src/proto_alpha/lib_delegate/delegate_commands.ml b/src/proto_alpha/lib_delegate/delegate_commands.ml index 7b18a1efc88d27cdb5bff7cd324e46e9c7e98098..95577ad2c86852f1692c1f7bf0d16d32da01cc6b 100644 --- a/src/proto_alpha/lib_delegate/delegate_commands.ml +++ b/src/proto_alpha/lib_delegate/delegate_commands.ml @@ -82,12 +82,11 @@ let delegate_commands () = [ command ~group ~desc:"Forge and inject block using the delegate rights." - (args9 + (args8 max_priority_arg minimal_fees_arg minimal_nanotez_per_gas_unit_arg minimal_nanotez_per_byte_arg - await_endorsements_arg force_switch minimal_timestamp_switch mempool_arg @@ -101,7 +100,6 @@ let delegate_commands () = minimal_fees, minimal_nanotez_per_gas_unit, minimal_nanotez_per_byte, - await_endorsements, force, minimal_timestamp, mempool, @@ -113,7 +111,6 @@ let delegate_commands () = ~minimal_fees ~minimal_nanotez_per_gas_unit ~minimal_nanotez_per_byte - ~await_endorsements ~force ?max_priority ~minimal_timestamp @@ -241,13 +238,12 @@ let baker_commands () = [ command ~group ~desc:"Launch the baker daemon." - (args6 + (args5 pidfile_arg max_priority_arg minimal_fees_arg minimal_nanotez_per_gas_unit_arg - minimal_nanotez_per_byte_arg - no_waiting_for_endorsements_arg) + minimal_nanotez_per_byte_arg) ( prefixes ["run"; "with"; "local"; "node"] @@ param ~name:"context_path" @@ -258,8 +254,7 @@ let baker_commands () = max_priority, minimal_fees, minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - no_waiting_for_endorsements ) + minimal_nanotez_per_byte ) node_path delegates cctxt -> @@ -277,7 +272,6 @@ let baker_commands () = ~minimal_nanotez_per_gas_unit ~minimal_nanotez_per_byte ?max_priority - ~await_endorsements:(not no_waiting_for_endorsements) ~context_path:(Filename.concat node_path "context") (List.map snd delegates) )) ] diff --git a/src/proto_alpha/lib_parameters/default_parameters.ml b/src/proto_alpha/lib_parameters/default_parameters.ml index b9dcfcf3999018916a93e5ba3e959ec51e81afe0..1da7d964151db3dd1b23ddd1b5d815c50dcd7996 100644 --- a/src/proto_alpha/lib_parameters/default_parameters.ml +++ b/src/proto_alpha/lib_parameters/default_parameters.ml @@ -33,7 +33,7 @@ let constants_mainnet = blocks_per_commitment = 32l; blocks_per_roll_snapshot = 256l; blocks_per_voting_period = 32768l; - time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 75L]; + time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 40L]; endorsers_per_block = 32; hard_gas_limit_per_operation = Z.of_int 800_000; hard_gas_limit_per_block = Z.of_int 8_000_000; @@ -50,6 +50,12 @@ let constants_mainnet = hard_storage_limit_per_operation = Z.of_int 60_000; cost_per_byte = Tez_repr.of_mutez_exn 1_000L; test_chain_duration = Int64.mul 32768L 60L; + quorum_min = 20_00l; + (* quorum is in centile of a percentage *) + quorum_max = 70_00l; + min_proposal_quorum = 5_00l; + initial_endorsers = 24; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L; } let constants_sandbox = @@ -63,6 +69,8 @@ let constants_sandbox = blocks_per_voting_period = 64l; time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L]; proof_of_work_threshold = Int64.of_int (-1); + initial_endorsers = 1; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L; } let constants_test = @@ -75,6 +83,8 @@ let constants_test = blocks_per_voting_period = 256l; time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L]; proof_of_work_threshold = Int64.of_int (-1); + initial_endorsers = 1; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L; } let bootstrap_accounts_strings = diff --git a/src/proto_alpha/lib_protocol/.ocamlformat-ignore b/src/proto_alpha/lib_protocol/.ocamlformat-ignore index 638f365365846573269b8d01ae7dce01853cbdae..260409bcad38e54ecc85ab9fd42422fd2af21f73 100644 --- a/src/proto_alpha/lib_protocol/.ocamlformat-ignore +++ b/src/proto_alpha/lib_protocol/.ocamlformat-ignore @@ -45,6 +45,8 @@ gas_limit_repr.mli helpers_services.ml helpers_services.mli init_storage.ml +legacy_script_support_repr.ml +legacy_script_support_repr.mli level_repr.ml level_repr.mli level_storage.ml diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 227ece362d97efb3e4f489aeadb055094570f6c9..bede8002736390fc7dba081b4f8e8a4ff992c93f 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -25,6 +25,7 @@ "Script_timestamp_repr", "Michelson_v1_primitives", "Script_repr", + "Legacy_script_support_repr", "Contract_repr", "Roll_repr", "Vote_repr", diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 435d9920ecb8f3694722f929d91f91c21a3b710b..c5fd259f1e5b7e20d60efdc0469e4a5260d23b40 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -62,9 +62,16 @@ module Script_int = Script_int_repr module Script_timestamp = struct include Script_timestamp_repr let now ctxt = - Raw_context.current_timestamp ctxt - |> Timestamp.to_seconds - |> of_int64 + let { Constants_repr.time_between_blocks ; _ } = + Raw_context.constants ctxt in + match time_between_blocks with + | [] -> failwith "Internal error: 'time_between_block' constants \ + is an empty list." + | first_delay :: _ -> + let current_timestamp = Raw_context.predecessor_timestamp ctxt in + Time.add current_timestamp (Period_repr.to_seconds first_delay) + |> Timestamp.to_seconds + |> of_int64 end module Script = struct include Michelson_v1_primitives @@ -79,6 +86,7 @@ module Script = struct (Script_repr.force_bytes lexpr >>? fun (b, cost) -> Raw_context.consume_gas ctxt cost >|? fun ctxt -> (b, ctxt)) + module Legacy_support = Legacy_script_support_repr end module Fees = Fees_storage @@ -113,13 +121,30 @@ module Contract = struct include Contract_repr include Contract_storage - let originate c contract ~balance ~manager ?script ~delegate - ~spendable ~delegatable = - originate c contract ~balance ~manager ?script ~delegate - ~spendable ~delegatable + let originate c contract ~balance ~script ~delegate = + originate c contract ~balance ~script ~delegate let init_origination_nonce = Raw_context.init_origination_nonce let unset_origination_nonce = Raw_context.unset_origination_nonce end +module Big_map = struct + type id = Z.t + let fresh = Storage.Big_map.Next.incr + let fresh_temporary = Raw_context.fresh_temporary_big_map + let mem c m k = Storage.Big_map.Contents.mem (c, m) k + let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k + let rpc_arg = Storage.Big_map.rpc_arg + let cleanup_temporary c = + Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c >>= fun c -> + Lwt.return (Raw_context.reset_temporary_big_map c) + let exists c id = + Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) >>=? fun c -> + Storage.Big_map.Key_type.get_option c id >>=? fun kt -> + match kt with + | None -> return (c, None) + | Some kt -> + Storage.Big_map.Value_type.get c id >>=? fun kv -> + return (c, Some (kt, kv)) +end module Delegate = Delegate_storage module Roll = struct include Roll_repr @@ -148,8 +173,8 @@ module Commitment = struct end module Global = struct - let get_last_block_priority = Storage.Last_block_priority.get - let set_last_block_priority = Storage.Last_block_priority.set + let get_block_priority = Storage.Block_priority.get + let set_block_priority = Storage.Block_priority.set end let prepare_first_block = Init_storage.prepare_first_block @@ -169,6 +194,7 @@ let fork_test_chain = Raw_context.fork_test_chain let record_endorsement = Raw_context.record_endorsement let allowed_endorsements = Raw_context.allowed_endorsements let init_endorsements = Raw_context.init_endorsements +let included_endorsements = Raw_context.included_endorsements let reset_internal_nonce = Raw_context.reset_internal_nonce let fresh_internal_nonce = Raw_context.fresh_internal_nonce diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 62d3176213341fb1d1f473186515200e6b5f6a9d..b970ad11012c11625bb14055e82382276c859db8 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -65,11 +65,13 @@ module Period : sig include BASIC_DATA type period = t + val rpc_arg: period RPC_arg.arg val of_seconds: int64 -> period tzresult val to_seconds: period -> int64 val mult: int32 -> period -> period tzresult + val zero: period val one_second: period val one_minute: period val one_hour: period @@ -81,6 +83,7 @@ module Timestamp : sig include BASIC_DATA with type t = Time.t type time = t val (+?) : time -> Period.t -> time tzresult + val (-?) : time -> time -> Period.t tzresult val of_notation: string -> time option val to_notation: time -> string @@ -143,6 +146,7 @@ module Gas : sig type error += Gas_limit_too_high (* `Permanent *) val free : cost + val atomic_step_cost : int -> cost val step_cost : int -> cost val alloc_cost : int -> cost val alloc_bytes_cost : int -> cost @@ -209,6 +213,7 @@ module Script : sig | I_BALANCE | I_CAR | I_CDR + | I_CHAIN_ID | I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT @@ -220,10 +225,12 @@ module Script : sig | I_DROP | I_DUP | I_EDIV + | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC + | I_APPLY | I_FAILWITH | I_GE | I_GET @@ -275,6 +282,8 @@ module Script : sig | I_ISNAT | I_CAST | I_RENAME + | I_DIG + | I_DUG | T_bool | T_contract | T_int @@ -297,6 +306,8 @@ module Script : sig | T_unit | T_operation | T_address + | T_chain_id + type location = Micheline.canonical_location @@ -336,6 +347,27 @@ module Script : sig val minimal_deserialize_cost : lazy_expr -> Gas.cost val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t + + val unit_parameter : lazy_expr + + module Legacy_support : sig + val manager_script_code: lazy_expr + val add_do: + manager_pkh: Signature.Public_key_hash.t -> + script_code: lazy_expr -> + script_storage: lazy_expr -> + (lazy_expr * lazy_expr) tzresult Lwt.t + val add_set_delegate: + manager_pkh: Signature.Public_key_hash.t -> + script_code: lazy_expr -> + script_storage: lazy_expr -> + (lazy_expr * lazy_expr) tzresult Lwt.t + val has_default_entrypoint: lazy_expr -> bool + val add_root_entrypoint: + script_code: lazy_expr -> + lazy_expr tzresult Lwt.t + end + end module Constants : sig @@ -380,6 +412,11 @@ module Constants : sig cost_per_byte: Tez.t ; hard_storage_limit_per_operation: Z.t ; test_chain_duration: int64; + quorum_min: int32 ; + quorum_max: int32 ; + min_proposal_quorum : int32 ; + initial_endorsers: int ; + delay_per_missing_endorsement : Period.t ; } val parametric_encoding: parametric Data_encoding.t val parametric: context -> parametric @@ -390,6 +427,8 @@ module Constants : sig val blocks_per_voting_period: context -> int32 val time_between_blocks: context -> Period.t list val endorsers_per_block: context -> int + val initial_endorsers: context -> int + val delay_per_missing_endorsement: context -> Period.t val hard_gas_limit_per_operation: context -> Z.t val hard_gas_limit_per_block: context -> Z.t val cost_per_byte: context -> Tez.t @@ -404,6 +443,9 @@ module Constants : sig val block_security_deposit: context -> Tez.t val endorsement_security_deposit: context -> Tez.t val test_chain_duration: context -> int64 + val quorum_min: context -> int32 + val quorum_max: context -> int32 + val min_proposal_quorum: context -> int32 (** All constants: fixed and parametric *) type t = { @@ -531,6 +573,17 @@ module Seed : sig end +module Big_map: sig + type id = Z.t + val fresh : context -> (context * id) tzresult Lwt.t + val fresh_temporary : context -> context * id + val mem : context -> id -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t + val get_opt : context -> id -> Script_expr_hash.t -> (context * Script.expr option) tzresult Lwt.t + val rpc_arg : id RPC_arg.t + val cleanup_temporary : context -> context Lwt.t + val exists : context -> id -> (context * (Script.expr * Script.expr) option) tzresult Lwt.t +end + module Contract : sig include BASIC_DATA @@ -551,27 +604,22 @@ module Contract : sig val list: context -> contract list Lwt.t - val get_manager: - context -> contract -> public_key_hash tzresult Lwt.t - val get_manager_key: - context -> contract -> public_key tzresult Lwt.t + context -> public_key_hash -> public_key tzresult Lwt.t val is_manager_key_revealed: - context -> contract -> bool tzresult Lwt.t + context -> public_key_hash -> bool tzresult Lwt.t val reveal_manager_key: - context -> contract -> public_key -> context tzresult Lwt.t + context -> public_key_hash -> public_key -> context tzresult Lwt.t - val is_delegatable: - context -> contract -> bool tzresult Lwt.t - val is_spendable: - context -> contract -> bool tzresult Lwt.t + val get_script_code: + context -> contract -> (context * Script.lazy_expr option) tzresult Lwt.t val get_script: context -> contract -> (context * Script.t option) tzresult Lwt.t val get_storage: context -> contract -> (context * Script.expr option) tzresult Lwt.t - val get_counter: context -> contract -> Z.t tzresult Lwt.t + val get_counter: context -> public_key_hash -> Z.t tzresult Lwt.t val get_balance: context -> contract -> Tez.t tzresult Lwt.t @@ -580,29 +628,34 @@ module Contract : sig val fresh_contract_from_current_nonce : context -> (context * t) tzresult Lwt.t val originated_from_current_nonce: since: context -> until:context -> contract list tzresult Lwt.t - type big_map_diff_item = { - diff_key : Script_repr.expr; - diff_key_hash : Script_expr_hash.t; - diff_value : Script_repr.expr option; - } + type big_map_diff_item = + | Update of { + big_map : Big_map.id ; + diff_key : Script.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script.expr option; + } + | Clear of Big_map.id + | Copy of Big_map.id * Big_map.id + | Alloc of { + big_map : Big_map.id; + key_type : Script.expr; + value_type : Script.expr; + } type big_map_diff = big_map_diff_item list val big_map_diff_encoding : big_map_diff Data_encoding.t val originate: context -> contract -> balance: Tez.t -> - manager: public_key_hash -> - ?script: (Script.t * big_map_diff option) -> + script: (Script.t * big_map_diff option) -> delegate: public_key_hash option -> - spendable: bool -> - delegatable: bool -> context tzresult Lwt.t + context tzresult Lwt.t type error += Balance_too_low of contract * Tez.t * Tez.t val spend: context -> contract -> Tez.t -> context tzresult Lwt.t - val spend_from_script: - context -> contract -> Tez.t -> context tzresult Lwt.t val credit: context -> contract -> Tez.t -> context tzresult Lwt.t @@ -615,17 +668,10 @@ module Contract : sig val used_storage_space: context -> t -> Z.t tzresult Lwt.t val increment_counter: - context -> contract -> context tzresult Lwt.t + context -> public_key_hash -> context tzresult Lwt.t val check_counter_increment: - context -> contract -> Z.t -> unit tzresult Lwt.t - - module Big_map : sig - val mem: - context -> contract -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t - val get_opt: - context -> contract -> Script_expr_hash.t -> (context * Script_repr.expr option) tzresult Lwt.t - end + context -> public_key_hash -> Z.t -> unit tzresult Lwt.t (**/**) (* Only for testing *) @@ -658,9 +704,6 @@ module Delegate : sig val set: context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t - val set_from_script: - context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t - val fold: context -> init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t @@ -713,7 +756,7 @@ module Delegate : sig val delegated_contracts: context -> Signature.Public_key_hash.t -> - Contract_hash.t list Lwt.t + Contract_repr.t list Lwt.t val delegated_balance: context -> Signature.Public_key_hash.t -> @@ -775,7 +818,9 @@ module Vote : sig context -> Voting_period.kind -> context tzresult Lwt.t val get_current_quorum: context -> int32 tzresult Lwt.t - val set_current_quorum: context -> int32 -> context tzresult Lwt.t + + val get_participation_ema: context -> int32 tzresult Lwt.t + val set_participation_ema: context -> int32 -> context tzresult Lwt.t val get_current_proposal: context -> proposal tzresult Lwt.t @@ -892,7 +937,7 @@ and _ contents = ballot: Vote.ballot ; } -> Kind.ballot contents | Manager_operation : { - source: Contract.contract ; + source: Signature.Public_key_hash.t ; fee: Tez.tez ; counter: counter ; operation: 'kind manager_operation ; @@ -904,15 +949,13 @@ and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : { amount: Tez.tez ; - parameters: Script.lazy_expr option ; + parameters: Script.lazy_expr ; + entrypoint: string ; destination: Contract.contract ; } -> Kind.transaction manager_operation | Origination : { - manager: Signature.Public_key_hash.t ; delegate: Signature.Public_key_hash.t option ; - script: Script.t option ; - spendable: bool ; - delegatable: bool ; + script: Script.t ; credit: Tez.tez ; preorigination: Contract.t option ; } -> Kind.origination manager_operation @@ -1111,8 +1154,8 @@ end module Global : sig - val get_last_block_priority: context -> int tzresult Lwt.t - val set_last_block_priority: context -> int -> context tzresult Lwt.t + val get_block_priority: context -> int tzresult Lwt.t + val set_block_priority: context -> int -> context tzresult Lwt.t end @@ -1128,6 +1171,7 @@ val prepare_first_block: val prepare: Context.t -> level:Int32.t -> + predecessor_timestamp:Time.t -> timestamp:Time.t -> fitness:Fitness.t -> context tzresult Lwt.t @@ -1146,6 +1190,8 @@ val init_endorsements: context -> (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t -> context +val included_endorsements: + context -> int val reset_internal_nonce: context -> context val fresh_internal_nonce: context -> (context * int) tzresult diff --git a/src/proto_alpha/lib_protocol/amendment.ml b/src/proto_alpha/lib_protocol/amendment.ml index ec30af1105dd97c241a0047a9a54ad22b8e3e8ee..ba6d9ba646d4457ed1e96be95aeb44ad0ce0b5e9 100644 --- a/src/proto_alpha/lib_protocol/amendment.ml +++ b/src/proto_alpha/lib_protocol/amendment.ml @@ -26,34 +26,46 @@ open Alpha_context (** Returns the proposal submitted by the most delegates. - Returns None in case of a tie or if there are no proposals. *) -let select_winning_proposal proposals = + Returns None in case of a tie, if proposal quorum is below required + minimum or if there are no proposals. *) +let select_winning_proposal ctxt = + Vote.get_proposals ctxt >>=? fun proposals -> let merge proposal vote winners = match winners with | None -> Some ([proposal], vote) | Some (winners, winners_vote) as previous -> if Compare.Int32.(vote = winners_vote) then Some (proposal :: winners, winners_vote) - else if Compare.Int32.(vote >= winners_vote) then + else if Compare.Int32.(vote > winners_vote) then Some ([proposal], vote) else previous in match Protocol_hash.Map.fold merge proposals None with - | None -> None - | Some ([proposal], _) -> Some proposal - | Some _ -> None (* in case of a tie, lets do nothing. *) + | Some ([proposal], vote) -> + Vote.listing_size ctxt >>=? fun max_vote -> + let min_proposal_quorum = Constants.min_proposal_quorum ctxt in + let min_vote_to_pass = + Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l in + if Compare.Int32.(vote >= min_vote_to_pass) then + return_some proposal + else + return_none + | _ -> + return_none (* in case of a tie, let's do nothing. *) (** A proposal is approved if it has supermajority and the participation reaches the current quorum. Supermajority means the yays are more 8/10 of casted votes. The participation is the ratio of all received votes, including passes, with - respect to the number of possible votes. The quorum starts at 80% and at - each vote is updated using the last expected quorum and the current - participation with the following weights: - newQ = oldQ * 8/10 + participation * 2/10 *) -let check_approval_and_update_quorum ctxt = + respect to the number of possible votes. + The participation EMA (exponential moving average) uses the last + participation EMA and the current participation./ + The expected quorum is calculated using the last participation EMA, capped + by the min/max quorum protocol constants. *) +let check_approval_and_update_participation_ema ctxt = Vote.get_ballots ctxt >>=? fun ballots -> Vote.listing_size ctxt >>=? fun maximum_vote -> + Vote.get_participation_ema ctxt >>=? fun participation_ema -> Vote.get_current_quorum ctxt >>=? fun expected_quorum -> (* Note overflows: considering a maximum of 8e8 tokens, with roll size as small as 1e3, there is a maximum of 8e5 rolls and thus votes. @@ -64,15 +76,18 @@ let check_approval_and_update_quorum ctxt = let all_votes = Int32.add casted_votes ballots.pass in let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in let participation = (* in centile of percentage *) - Int64.to_int32 - (Int64.div - (Int64.mul (Int64.of_int32 all_votes) 100_00L) - (Int64.of_int32 maximum_vote)) in + Int64.(to_int32 + (div + (mul (of_int32 all_votes) 100_00L) + (of_int32 maximum_vote))) in let outcome = Compare.Int32.(participation >= expected_quorum && ballots.yay >= supermajority) in - let updated_quorum = - Int32.div (Int32.add (Int32.mul 8l expected_quorum) (Int32.mul 2l participation)) 10l in - Vote.set_current_quorum ctxt updated_quorum >>=? fun ctxt -> + let new_participation_ema = + Int32.(div (add + (mul 8l participation_ema) + (mul 2l participation)) + 10l) in + Vote.set_participation_ema ctxt new_participation_ema >>=? fun ctxt -> return (ctxt, outcome) (** Implements the state machine of the amendment procedure. @@ -82,10 +97,10 @@ let check_approval_and_update_quorum ctxt = let start_new_voting_period ctxt = Vote.get_current_period_kind ctxt >>=? function | Proposal -> begin - Vote.get_proposals ctxt >>=? fun proposals -> + select_winning_proposal ctxt >>=? fun proposal -> Vote.clear_proposals ctxt >>= fun ctxt -> Vote.clear_listings ctxt >>=? fun ctxt -> - match select_winning_proposal proposals with + match proposal with | None -> Vote.freeze_listings ctxt >>=? fun ctxt -> return ctxt @@ -96,7 +111,7 @@ let start_new_voting_period ctxt = return ctxt end | Testing_vote -> - check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) -> + check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) -> Vote.clear_ballots ctxt >>= fun ctxt -> Vote.clear_listings ctxt >>=? fun ctxt -> if approved then @@ -116,7 +131,7 @@ let start_new_voting_period ctxt = Vote.set_current_period_kind ctxt Promotion_vote >>=? fun ctxt -> return ctxt | Promotion_vote -> - check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) -> + check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) -> begin if approved then Vote.get_current_proposal ctxt >>=? fun proposal -> diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 984d1fee67f7603b04257764956774580ba7b08a..df4ba5b85fff607c806f0831d6b9029efcc9caf5 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -33,8 +33,6 @@ type error += Duplicate_endorsement of Signature.Public_key_hash.t (* `Branch *) type error += Invalid_endorsement_level type error += Invalid_commitment of { expected: bool } type error += Internal_operation_replay of packed_internal_operation -type error += Cannot_originate_spendable_smart_contract (* `Permanent *) -type error += Cannot_originate_non_spendable_account (* `Permanent *) type error += Invalid_double_endorsement_evidence (* `Permanent *) type error += Inconsistent_double_endorsement_evidence @@ -60,6 +58,12 @@ type error += Outdated_double_baking_evidence type error += Invalid_activation of { pkh : Ed25519.Public_key_hash.t } type error += Multiple_revelation type error += Gas_quota_exceeded_init_deserialize (* Permanent *) +type error += + Not_enough_endorsements_for_priority of + { required : int ; + priority : int ; + endorsements : int ; + timestamp: Time.t } let () = register_error_kind @@ -135,30 +139,6 @@ let () = Operation.internal_operation_encoding (function Internal_operation_replay op -> Some op | _ -> None) (fun op -> Internal_operation_replay op) ; - register_error_kind - `Permanent - ~id:"cannot_originate_non_spendable_account" - ~title:"Cannot originate non spendable account" - ~description:"An origination was attempted \ - that would create a non spendable, non scripted contract" - ~pp:(fun ppf () -> - Format.fprintf ppf "It is not possible anymore to originate \ - a non scripted contract that is not spendable.") - Data_encoding.empty - (function Cannot_originate_non_spendable_account -> Some () | _ -> None) - (fun () -> Cannot_originate_non_spendable_account) ; - register_error_kind - `Permanent - ~id:"cannot_originate_spendable_smart_contract" - ~title:"Cannot originate spendable smart contract" - ~description:"An origination was attempted \ - that would create a spendable scripted contract" - ~pp:(fun ppf () -> - Format.fprintf ppf "It is not possible anymore to originate \ - a scripted contract that is spendable.") - Data_encoding.empty - (function Cannot_originate_spendable_smart_contract -> Some () | _ -> None) - (fun () -> Cannot_originate_spendable_smart_contract) ; register_error_kind `Permanent ~id:"block.invalid_double_endorsement_evidence" @@ -372,34 +352,49 @@ let () = parse within the provided gas bounds." Data_encoding.empty (function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None) - (fun () -> Gas_quota_exceeded_init_deserialize) + (fun () -> Gas_quota_exceeded_init_deserialize) ; + register_error_kind + `Permanent + ~id:"operation.not_enought_endorsements_for_priority" + ~title:"Not enough endorsements for priority" + ~description:"The block being validated does not include the \ + required minimum number of endorsements for this priority." + ~pp:(fun ppf (required, endorsements, priority, timestamp) -> + Format.fprintf ppf "Wrong number of endorsements (%i) for \ + priority (%i), %i are expected at %a" + endorsements priority required Time.pp_hum timestamp) + Data_encoding.(obj4 + (req "required" int31) + (req "endorsements" int31) + (req "priority" int31) + (req "timestamp" Time.encoding)) + (function Not_enough_endorsements_for_priority + { required ; endorsements ; priority ; timestamp } -> + Some (required, endorsements, priority, timestamp) | _ -> None) + (fun (required, endorsements, priority, timestamp) -> + Not_enough_endorsements_for_priority + { required ; endorsements ; priority ; timestamp }) open Apply_results let apply_manager_operation_content : type kind. ( Alpha_context.t -> Script_ir_translator.unparsing_mode -> payer:Contract.t -> source:Contract.t -> - internal:bool -> kind manager_operation -> + chain_id:Chain_id.t -> internal:bool -> kind manager_operation -> (context * kind successful_manager_operation_result * packed_internal_operation list) tzresult Lwt.t ) = - fun ctxt mode ~payer ~source ~internal operation -> + fun ctxt mode ~payer ~source ~chain_id ~internal operation -> let before_operation = (* This context is not used for backtracking. Only to compute gas consumption and originations for the operation result. *) ctxt in Contract.must_exist ctxt source >>=? fun () -> - let spend = - (* Ignore the spendable flag for smart contracts. *) - if internal then Contract.spend_from_script else Contract.spend in - let set_delegate = - (* Ignore the delegatable flag for smart contracts. *) - if internal then Delegate.set_from_script else Delegate.set in Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation) >>=? fun ctxt -> match operation with | Reveal _ -> return (* No-op: action already performed by `precheck_manager_contents`. *) (ctxt, (Reveal_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt } : kind successful_manager_operation_result), []) - | Transaction { amount ; parameters ; destination } -> begin - spend ctxt source amount >>=? fun ctxt -> + | Transaction { amount ; parameters ; destination ; entrypoint } -> begin + Contract.spend ctxt source amount >>=? fun ctxt -> begin match Contract.is_implicit destination with | None -> return (ctxt, [], false) | Some _ -> @@ -413,20 +408,21 @@ let apply_manager_operation_content : Contract.get_script ctxt destination >>=? fun (ctxt, script) -> match script with | None -> begin - match parameters with - | None -> return ctxt - | Some arg -> - Script.force_decode ctxt arg >>=? fun (arg, ctxt) -> (* see [note] *) - (* [note]: for toplevel ops, cost is nil since the - lazy value has already been forced at precheck, so - we compute and consume the full cost again *) - let cost_arg = Script.deserialized_cost arg in - Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> - match Micheline.root arg with - | Prim (_, D_Unit, [], _) -> - (* Allow [Unit] parameter to non-scripted contracts. *) - return ctxt - | _ -> fail (Script_interpreter.Bad_contract_parameter destination) + begin match entrypoint with + | "default" -> return () + | entrypoint -> fail (Script_tc_errors.No_such_entrypoint entrypoint) + end >>=? fun () -> + Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *) + (* [note]: for toplevel ops, cost is nil since the + lazy value has already been forced at precheck, so + we compute and consume the full cost again *) + let cost_arg = Script.deserialized_cost arg in + Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> + match Micheline.root arg with + | Prim (_, D_Unit, [], _) -> + (* Allow [Unit] parameter to non-scripted contracts. *) + return ctxt + | _ -> fail (Script_interpreter.Bad_contract_parameter destination) end >>=? fun ctxt -> let result = Transaction_result @@ -445,20 +441,18 @@ let apply_manager_operation_content : } in return (ctxt, result, []) | Some script -> - begin match parameters with - | None -> - (* Forge a [Unit] parameter that will be checked by [execute]. *) - let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], [])) in - return (ctxt, unit) - | Some parameters -> - Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *) - let cost_arg = Script.deserialized_cost arg in - Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> - return (ctxt, arg) - end >>=? fun (ctxt, parameter) -> + Script.force_decode ctxt parameters >>=? fun (parameter, ctxt) -> (* see [note] *) + let cost_parameter = Script.deserialized_cost parameter in + Lwt.return (Gas.consume ctxt cost_parameter) >>=? fun ctxt -> + let step_constants = + let open Script_interpreter in + { source ; + payer ; + self = destination ; + amount ; + chain_id } in Script_interpreter.execute - ctxt mode - ~source ~payer ~self:(destination, script) ~amount ~parameter + ctxt mode step_constants ~script ~parameter ~entrypoint >>=? fun { ctxt ; storage ; big_map_diff ; operations } -> Contract.update_script_storage ctxt destination storage big_map_diff >>=? fun ctxt -> @@ -483,27 +477,20 @@ let apply_manager_operation_content : allocated_destination_contract } in return (ctxt, result, operations) end - | Origination { manager ; delegate ; script ; preorigination ; - spendable ; delegatable ; credit } -> - begin match script with - | None -> - if spendable then - return (None, ctxt) - else - fail Cannot_originate_non_spendable_account - | Some script -> - if spendable then - fail Cannot_originate_spendable_smart_contract - else - Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *) - Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt -> - Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *) - Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt -> - Script_ir_translator.parse_script ctxt script >>=? fun (ex_script, ctxt) -> - Script_ir_translator.big_map_initialization ctxt Optimized ex_script >>=? fun (big_map_diff, ctxt) -> - return (Some (script, big_map_diff), ctxt) - end >>=? fun (script, ctxt) -> - spend ctxt source credit >>=? fun ctxt -> + | Origination { delegate ; script ; preorigination ; credit } -> + Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt -> + Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt -> + Script_ir_translator.parse_script ctxt ~legacy:false script >>=? fun (Ex_script parsed_script, ctxt) -> + Script_ir_translator.collect_big_maps ctxt parsed_script.storage_type parsed_script.storage >>=? fun (to_duplicate, ctxt) -> + let to_update = Script_ir_translator.no_big_map_id in + Script_ir_translator.extract_big_map_diff ctxt Optimized parsed_script.storage_type parsed_script.storage + ~to_duplicate ~to_update ~temporary:false >>=? fun (storage, big_map_diff, ctxt) -> + Script_ir_translator.unparse_data ctxt Optimized parsed_script.storage_type storage >>=? fun (storage, ctxt) -> + let storage = Script.lazy_expr (Micheline.strip_locations storage) in + let script = { script with storage } in + Contract.spend ctxt source credit >>=? fun ctxt -> begin match preorigination with | Some contract -> assert internal ; @@ -515,14 +502,14 @@ let apply_manager_operation_content : Contract.fresh_contract_from_current_nonce ctxt end >>=? fun (ctxt, contract) -> Contract.originate ctxt contract - ~manager ~delegate ~balance:credit - ?script - ~spendable ~delegatable >>=? fun ctxt -> + ~delegate ~balance:credit + ~script:(script, big_map_diff) >>=? fun ctxt -> Fees.origination_burn ctxt >>=? fun (ctxt, origination_burn) -> Fees.record_paid_storage_space ctxt contract >>=? fun (ctxt, size, paid_storage_size_diff, fees) -> let result = Origination_result - { balance_updates = + { big_map_diff ; + balance_updates = Delegate.cleanup_balance_updates [ Contract payer, Debited fees ; Contract payer, Debited origination_burn ; @@ -534,10 +521,10 @@ let apply_manager_operation_content : paid_storage_size_diff } in return (ctxt, result, []) | Delegation delegate -> - set_delegate ctxt source delegate >>=? fun ctxt -> + Delegate.set ctxt source delegate >>=? fun ctxt -> return (ctxt, Delegation_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt }, []) -let apply_internal_manager_operations ctxt mode ~payer ops = +let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = let rec apply ctxt applied worklist = match worklist with | [] -> Lwt.return (`Success ctxt, List.rev applied) @@ -549,7 +536,7 @@ let apply_internal_manager_operations ctxt mode ~payer ops = else let ctxt = record_internal_nonce ctxt nonce in apply_manager_operation_content - ctxt mode ~source ~payer ~internal:true operation + ctxt mode ~source ~payer ~chain_id ~internal:true operation end >>= function | Error errors -> let result = @@ -573,20 +560,20 @@ let precheck_manager_contents Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () -> let ctxt = Gas.set_limit ctxt gas_limit in Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () -> - Contract.must_be_allocated ctxt source >>=? fun () -> + Contract.must_be_allocated ctxt (Contract.implicit_contract source) >>=? fun () -> Contract.check_counter_increment ctxt source counter >>=? fun () -> begin match operation with | Reveal pk -> Contract.reveal_manager_key ctxt source pk - | Transaction { parameters = Some arg ; _ } -> + | Transaction { parameters ; _ } -> (* Fail quickly if not enough gas for minimal deserialization cost *) Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ - Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () -> + Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters) >>=? fun () -> (* Fail if not enough gas for complete deserialization cost *) trace Gas_quota_exceeded_init_deserialize @@ - Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt - | Origination { script = Some script ; _ } -> + Script.force_decode ctxt parameters >>|? fun (_arg, ctxt) -> ctxt + | Origination { script ; _ } -> (* Fail quickly if not enough gas for minimal deserialization cost *) Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ (Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt -> @@ -606,12 +593,12 @@ let precheck_manager_contents sequence of transactions. *) Operation.check_signature public_key chain_id raw_operation >>=? fun () -> Contract.increment_counter ctxt source >>=? fun ctxt -> - Contract.spend ctxt source fee >>=? fun ctxt -> + Contract.spend ctxt (Contract.implicit_contract source) fee >>=? fun ctxt -> add_fees ctxt fee >>=? fun ctxt -> return ctxt let apply_manager_contents - (type kind) ctxt mode (op : kind Kind.manager contents) + (type kind) ctxt mode chain_id (op : kind Kind.manager contents) : ([ `Success of context | `Failure ] * kind manager_operation_result * packed_internal_operation_result list) Lwt.t = @@ -619,11 +606,12 @@ let apply_manager_contents { source ; operation ; gas_limit ; storage_limit } = op in let ctxt = Gas.set_limit ctxt gas_limit in let ctxt = Fees.start_counting_storage_fees ctxt in + let source = Contract.implicit_contract source in apply_manager_operation_content ctxt mode - ~source ~payer:source ~internal:false operation >>= function + ~source ~payer:source ~internal:false ~chain_id operation >>= function | Ok (ctxt, operation_results, internal_operations) -> begin apply_internal_manager_operations - ctxt mode ~payer:source internal_operations >>= function + ctxt mode ~payer:source ~chain_id internal_operations >>= function | (`Success ctxt, internal_operations_results) -> begin Fees.burn_storage_fees ctxt ~storage_limit ~payer:source >>= function | Ok ctxt -> @@ -654,6 +642,7 @@ let rec mark_skipped baker : Signature.Public_key_hash.t -> Level.t -> kind Kind.manager contents_list -> kind Kind.manager contents_result_list = fun ~baker level -> function | Single (Manager_operation { source ; fee ; operation } ) -> + let source = Contract.implicit_contract source in Single_result (Manager_operation_result { balance_updates = @@ -663,6 +652,7 @@ let rec mark_skipped operation_result = skipped_operation_result operation ; internal_operation_results = [] }) | Cons (Manager_operation { source ; fee ; operation } , rest) -> + let source = Contract.implicit_contract source in Cons_result (Manager_operation_result { balance_updates = @@ -688,14 +678,15 @@ let rec precheck_manager_contents_list let rec apply_manager_contents_list_rec : type kind. Alpha_context.t -> Script_ir_translator.unparsing_mode -> - public_key_hash -> kind Kind.manager contents_list -> + public_key_hash -> Chain_id.t -> kind Kind.manager contents_list -> ([ `Success of context | `Failure ] * kind Kind.manager contents_result_list) Lwt.t = - fun ctxt mode baker contents_list -> + fun ctxt mode baker chain_id contents_list -> let level = Level.current ctxt in match contents_list with | Single (Manager_operation { source ; fee ; _ } as op) -> begin - apply_manager_contents ctxt mode op + let source = Contract.implicit_contract source in + apply_manager_contents ctxt mode chain_id op >>= fun (ctxt_result, operation_result, internal_operation_results) -> let result = Manager_operation_result { @@ -709,7 +700,8 @@ let rec apply_manager_contents_list_rec Lwt.return (ctxt_result, Single_result (result)) end | Cons (Manager_operation { source ; fee ; _ } as op, rest) -> - apply_manager_contents ctxt mode op >>= function + let source = Contract.implicit_contract source in + apply_manager_contents ctxt mode chain_id op >>= function | (`Failure, operation_result, internal_operation_results) -> let result = Manager_operation_result { @@ -731,7 +723,7 @@ let rec apply_manager_contents_list_rec operation_result ; internal_operation_results ; } in - apply_manager_contents_list_rec ctxt mode baker rest >>= fun (ctxt_result, results) -> + apply_manager_contents_list_rec ctxt mode baker chain_id rest >>= fun (ctxt_result, results) -> Lwt.return (ctxt_result, Cons_result (result, results)) let mark_backtracked results = @@ -765,14 +757,16 @@ let mark_backtracked results = | Applied result -> Backtracked (result, None) in mark_contents_list results -let apply_manager_contents_list ctxt mode baker contents_list = - apply_manager_contents_list_rec ctxt mode baker contents_list >>= fun (ctxt_result, results) -> +let apply_manager_contents_list ctxt mode baker chain_id contents_list = + apply_manager_contents_list_rec ctxt mode baker chain_id contents_list >>= fun (ctxt_result, results) -> match ctxt_result with | `Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results) - | `Success ctxt -> Lwt.return (ctxt, results) + | `Success ctxt -> + Big_map.cleanup_temporary ctxt >>= fun ctxt -> + Lwt.return (ctxt, results) let apply_contents_list - (type kind) ctxt ~partial chain_id mode pred_block baker + (type kind) ctxt chain_id mode pred_block baker (operation : kind operation) (contents_list : kind contents_list) : (context * kind contents_result_list) tzresult Lwt.t = @@ -791,18 +785,12 @@ let apply_contents_list else let ctxt = record_endorsement ctxt delegate in let gap = List.length slots in - let ctxt = Fitness.increase ~gap ctxt in Lwt.return Tez.(Constants.endorsement_security_deposit ctxt *? Int64.of_int gap) >>=? fun deposit -> - begin - if partial then - Delegate.freeze_deposit ctxt delegate deposit - else - add_deposit ctxt delegate deposit - end >>=? fun ctxt -> - Global.get_last_block_priority ctxt >>=? fun block_priority -> - Baking.endorsement_reward ctxt ~block_priority gap >>=? fun reward -> + Delegate.freeze_deposit ctxt delegate deposit >>=? fun ctxt -> + Global.get_block_priority ctxt >>=? fun block_priority -> + Baking.endorsing_reward ctxt ~block_priority gap >>=? fun reward -> Delegate.freeze_rewards ctxt delegate reward >>=? fun ctxt -> let level = Level.from_raw ctxt level in return (ctxt, Single_result @@ -944,17 +932,17 @@ let apply_contents_list return (ctxt, Single_result Ballot_result) | Single (Manager_operation _) as op -> precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt -> - apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) -> + apply_manager_contents_list ctxt mode baker chain_id op >>= fun (ctxt, result) -> return (ctxt, result) | Cons (Manager_operation _, _) as op -> precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt -> - apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) -> + apply_manager_contents_list ctxt mode baker chain_id op >>= fun (ctxt, result) -> return (ctxt, result) -let apply_operation ctxt ~partial chain_id mode pred_block baker hash operation = +let apply_operation ctxt chain_id mode pred_block baker hash operation = let ctxt = Contract.init_origination_nonce ctxt hash in apply_contents_list - ctxt ~partial chain_id mode pred_block baker operation + ctxt chain_id mode pred_block baker operation operation.protocol_data.contents >>=? fun (ctxt, result) -> let ctxt = Gas.set_unlimited ctxt in let ctxt = Contract.unset_origination_nonce ctxt in @@ -983,15 +971,17 @@ let may_start_new_cycle ctxt = return (ctxt, update_balances, deactivated) let begin_full_construction ctxt pred_timestamp protocol_data = + Alpha_context.Global.set_block_priority ctxt + protocol_data.Block_header.priority >>=? fun ctxt -> Baking.check_baking_rights - ctxt protocol_data pred_timestamp >>=? fun delegate_pk -> + ctxt protocol_data pred_timestamp >>=? fun (delegate_pk, block_delay) -> let ctxt = Fitness.increase ctxt in match Level.pred ctxt (Level.current ctxt) with | None -> assert false (* genesis *) | Some pred_level -> Baking.endorsement_rights ctxt pred_level >>=? fun rights -> let ctxt = init_endorsements ctxt rights in - return (ctxt, protocol_data, delegate_pk) + return (ctxt, protocol_data, delegate_pk, block_delay) let begin_partial_construction ctxt = let ctxt = Fitness.increase ctxt in @@ -1003,11 +993,14 @@ let begin_partial_construction ctxt = return ctxt let begin_application ctxt chain_id block_header pred_timestamp = + Alpha_context.Global.set_block_priority ctxt + block_header.Block_header.protocol_data.contents.priority >>=? fun ctxt -> let current_level = Alpha_context.Level.current ctxt in Baking.check_proof_of_work_stamp ctxt block_header >>=? fun () -> Baking.check_fitness_gap ctxt block_header >>=? fun () -> Baking.check_baking_rights - ctxt block_header.protocol_data.contents pred_timestamp >>=? fun delegate_pk -> + ctxt block_header.protocol_data.contents pred_timestamp + >>=? fun (delegate_pk, block_delay) -> Baking.check_signature block_header chain_id delegate_pk >>=? fun () -> let has_commitment = match block_header.protocol_data.contents.seed_nonce_hash with @@ -1023,12 +1016,27 @@ let begin_application ctxt chain_id block_header pred_timestamp = | Some pred_level -> Baking.endorsement_rights ctxt pred_level >>=? fun rights -> let ctxt = init_endorsements ctxt rights in - return (ctxt, delegate_pk) + return (ctxt, delegate_pk, block_delay) -let finalize_application ctxt protocol_data delegate = +let check_minimum_endorsements ctxt protocol_data block_delay included_endorsements = + let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in + let timestamp = Timestamp.current ctxt in + fail_unless Compare.Int.(included_endorsements >= minimum) + (Not_enough_endorsements_for_priority + { required = minimum ; + priority = protocol_data.Block_header.priority ; + endorsements = included_endorsements ; + timestamp }) + +let finalize_application ctxt protocol_data delegate ~block_delay = + let included_endorsements = included_endorsements ctxt in + check_minimum_endorsements ctxt + protocol_data block_delay included_endorsements >>=? fun () -> let deposit = Constants.block_security_deposit ctxt in add_deposit ctxt delegate deposit >>=? fun ctxt -> - let reward = (Constants.block_reward ctxt) in + + Baking.baking_reward ctxt + ~block_priority:protocol_data.priority ~included_endorsements >>=? fun reward -> add_rewards ctxt reward >>=? fun ctxt -> Signature.Public_key_hash.Map.fold (fun delegate deposit ctxt -> @@ -1048,8 +1056,6 @@ let finalize_application ctxt protocol_data delegate = Nonce.record_hash ctxt { nonce_hash ; delegate ; rewards ; fees } end >>=? fun ctxt -> - Alpha_context.Global.set_last_block_priority - ctxt protocol_data.priority >>=? fun ctxt -> (* end of cycle *) may_snapshot_roll ctxt >>=? fun ctxt -> may_start_new_cycle ctxt >>=? fun (ctxt, balance_updates, deactivated) -> diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 0ef56ef6e36ff026839c2947ea2a8fc40854a8c6..d02de349ab6f7bcb7486542042423e73b6da8cb9 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -56,7 +56,8 @@ type _ successful_manager_operation_result = allocated_destination_contract : bool ; } -> Kind.transaction successful_manager_operation_result | Origination_result : - { balance_updates : Delegate.balance_updates ; + { big_map_diff : Contract.big_map_diff option ; + balance_updates : Delegate.balance_updates ; originated_contracts : Contract.t list ; consumed_gas : Z.t ; storage_size : Z.t ; @@ -215,7 +216,8 @@ module Manager_result = struct make ~op_case: Operation.Encoding.Manager_operations.origination_case ~encoding: - (obj5 + (obj6 + (opt "big_map_diff" Contract.big_map_diff_encoding) (dft "balance_updates" Delegate.balance_updates_encoding []) (dft "originated_contracts" (list Contract.encoding) []) (dft "consumed_gas" z Z.zero) @@ -234,19 +236,19 @@ module Manager_result = struct ~proj: (function | Origination_result - { balance_updates ; + { big_map_diff ; balance_updates ; originated_contracts ; consumed_gas ; storage_size ; paid_storage_size_diff } -> - (balance_updates, + (big_map_diff, balance_updates, originated_contracts, consumed_gas, storage_size, paid_storage_size_diff)) ~kind: Kind.Origination_manager_kind ~inj: - (fun (balance_updates, + (fun (big_map_diff, balance_updates, originated_contracts, consumed_gas, storage_size, paid_storage_size_diff) -> Origination_result - { balance_updates ; + { big_map_diff ; balance_updates ; originated_contracts ; consumed_gas ; storage_size ; paid_storage_size_diff }) diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index b4505f5021d01e330c366ce31b6ec3cc9619379b..a5f17d2ef56683ac8d582a23f14ebc5748f587af 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -100,7 +100,8 @@ and _ successful_manager_operation_result = allocated_destination_contract : bool ; } -> Kind.transaction successful_manager_operation_result | Origination_result : - { balance_updates : Delegate.balance_updates ; + { big_map_diff : Contract.big_map_diff option ; + balance_updates : Delegate.balance_updates ; originated_contracts : Contract.t list ; consumed_gas : Z.t ; storage_size : Z.t ; diff --git a/src/proto_alpha/lib_protocol/baking.ml b/src/proto_alpha/lib_protocol/baking.ml index d8d222c209a0469a1d6d71bfda82ca073783092b..168e707088df866d36d15d5435137667cf826e03 100644 --- a/src/proto_alpha/lib_protocol/baking.ml +++ b/src/proto_alpha/lib_protocol/baking.ml @@ -142,17 +142,19 @@ let earlier_predecessor_timestamp ctxt level = let check_timestamp c priority pred_timestamp = minimal_time c priority pred_timestamp >>=? fun minimal_time -> let timestamp = Alpha_context.Timestamp.current c in - fail_unless Timestamp.(minimal_time <= timestamp) - (Timestamp_too_early (minimal_time, timestamp)) + Lwt.return + (record_trace (Timestamp_too_early (minimal_time, timestamp)) + Timestamp.(timestamp -? minimal_time)) let check_baking_rights c { Block_header.priority ; _ } pred_timestamp = let level = Level.current c in Roll.baking_rights_owner c level ~priority >>=? fun delegate -> - check_timestamp c priority pred_timestamp >>=? fun () -> - return delegate + check_timestamp c priority pred_timestamp >>=? fun block_delay -> + return (delegate, block_delay) type error += Incorrect_priority (* `Permanent *) +type error += Incorrect_number_of_endorsements (* `Permanent *) let () = register_error_kind @@ -166,7 +168,34 @@ let () = (function Incorrect_priority -> Some () | _ -> None) (fun () -> Incorrect_priority) -let endorsement_reward ctxt ~block_priority:prio n = +let () = + let description = "The number of endorsements must be non-negative and \ + at most the endosers_per_block constant." in + register_error_kind + `Permanent + ~id:"incorrect_number_of_endorsements" + ~title:"Incorrect number of endorsements" + ~description + ~pp:(fun ppf () -> Format.fprintf ppf "%s" description) + Data_encoding.unit + (function Incorrect_number_of_endorsements -> Some () | _ -> None) + (fun () -> Incorrect_number_of_endorsements) + +let baking_reward ctxt ~block_priority:prio ~included_endorsements:num_endo = + fail_unless Compare.Int.(prio >= 0) Incorrect_priority >>=? fun () -> + let max_endorsements = Constants.endorsers_per_block ctxt in + fail_unless Compare.Int.(num_endo >= 0 && num_endo <= max_endorsements) + Incorrect_number_of_endorsements >>=? fun () -> + let prio_factor_denominator = Int64.(succ (of_int prio)) in + let endo_factor_numerator = Int64.of_int (8 + 2 * num_endo / max_endorsements) in + let endo_factor_denominator = 10L in + Lwt.return + Tez.( + Constants.block_reward ctxt *? endo_factor_numerator >>? fun val1 -> + val1 /? endo_factor_denominator >>? fun val2 -> + val2 /? prio_factor_denominator) + +let endorsing_reward ctxt ~block_priority:prio n = if Compare.Int.(prio >= 0) then Lwt.return @@ -271,9 +300,7 @@ let check_signature block chain_id key = fail (Invalid_block_signature (Block_header.hash block, Signature.Public_key.hash key)) -let max_fitness_gap ctxt = - let slots = Int64.of_int (Constants.endorsers_per_block ctxt + 1) in - Int64.add slots 1L +let max_fitness_gap _ctxt = 1L let check_fitness_gap ctxt (block : Block_header.t) = let current_fitness = Fitness.current ctxt in @@ -294,3 +321,36 @@ let dawn_of_a_new_cycle ctxt = return_some level.cycle else return_none + +let minimum_allowed_endorsements ctxt ~block_delay = + let minimum = Constants.initial_endorsers ctxt in + let delay_per_missing_endorsement = + Int64.to_int + (Period.to_seconds + (Constants.delay_per_missing_endorsement ctxt)) + in + let reduced_time_constraint = + let delay = Int64.to_int (Period.to_seconds block_delay) in + if Compare.Int.(delay_per_missing_endorsement = 0) then + delay + else + delay / delay_per_missing_endorsement + in + Compare.Int.max 0 (minimum - reduced_time_constraint) + +let minimal_valid_time ctxt ~priority ~endorsing_power = + let predecessor_timestamp = Timestamp.current ctxt in + minimal_time ctxt + priority predecessor_timestamp >>=? fun minimal_time -> + let minimal_required_endorsements = Constants.initial_endorsers ctxt in + let delay_per_missing_endorsement = + Constants.delay_per_missing_endorsement ctxt + in + let missing_endorsements = + Compare.Int.max 0 (minimal_required_endorsements - endorsing_power) in + match Period.mult + (Int32.of_int missing_endorsements) + delay_per_missing_endorsement with + | Ok delay -> + return (Time.add minimal_time (Period.to_seconds delay)) + | Error _ as err -> Lwt.return err diff --git a/src/proto_alpha/lib_protocol/baking.mli b/src/proto_alpha/lib_protocol/baking.mli index 52c78f74ba9168ea5878800fc24eaab2b62b5be5..39cc2e8e2be2725daa088a0266bf4452d7680d95 100644 --- a/src/proto_alpha/lib_protocol/baking.mli +++ b/src/proto_alpha/lib_protocol/baking.mli @@ -47,7 +47,7 @@ val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t *) val check_baking_rights: context -> Block_header.contents -> Time.t -> - public_key tzresult Lwt.t + (public_key * Period.t) tzresult Lwt.t (** For a given level computes who has the right to include an endorsement in the next block. @@ -63,8 +63,15 @@ val check_endorsement_rights: context -> Chain_id.t -> Kind.endorsement Operation.t -> (public_key_hash * int list * bool) tzresult Lwt.t -(** Returns the endorsement reward calculated w.r.t a given priority. *) -val endorsement_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t +(** Returns the baking reward calculated w.r.t a given priority [p] and a + number [e] of included endorsements as follows: + (block_reward / (p+1)) * (0.8 + 0.2 * e / endorsers_per_block) +*) +val baking_reward: context -> + block_priority:int -> included_endorsements:int -> Tez.t tzresult Lwt.t + +(** Returns the endorsing reward calculated w.r.t a given priority. *) +val endorsing_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t (** [baking_priorities ctxt level] is the lazy list of contract's public key hashes that are allowed to bake for [level]. *) @@ -106,3 +113,39 @@ val check_fitness_gap: val dawn_of_a_new_cycle: context -> Cycle.t option tzresult Lwt.t val earlier_predecessor_timestamp: context -> Level.t -> Timestamp.t tzresult Lwt.t + +(** Since Emmy+ + + A block is valid only if its timestamp has a minimal delay with + respect to the previous block's timestamp, and this minimal delay + depends not only on the block's priority but also on the number of + endorsement operations included in the block. + + In Emmy+, blocks' fitness increases by one unit with each level. + + In this way, Emmy+ simplifies the optimal baking strategy: The + bakers used to have to choose whether to wait for more endorsements + to include in their block, or to publish the block immediately, + without waiting. The incentive for including more endorsements was + to increase the fitness and win against unknown blocks. However, + when a block was produced too late in the priority period, there + was the risk that the block did not reach endorsers before the + block of next priority. In Emmy+, the baker does not need to take + such a decision, because the baker cannot publish a block too + early. *) + +(** Given a delay of a block's timestamp with respect to the minimum + time to bake at the block's priority (as returned by + `minimum_time`), it returns the minimum number of endorsements that + the block has to contain *) +val minimum_allowed_endorsements: context -> block_delay:Period.t -> int + +(** This is the somehow the dual of the previous function. Given a + block priority and a number of endorsement slots (given by the + `endorsing_power` argument), it returns the minimum time at which + the next block can be baked. *) +val minimal_valid_time: + context -> + priority:int -> + endorsing_power: int -> + Time.t tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/bootstrap_storage.ml b/src/proto_alpha/lib_protocol/bootstrap_storage.ml index 50d17dfffa6a15f11ae0f47da11f42696b8d090f..8e0b46abc0b6ba5da6ed3832515d5ffb5c1064b9 100644 --- a/src/proto_alpha/lib_protocol/bootstrap_storage.ml +++ b/src/proto_alpha/lib_protocol/bootstrap_storage.ml @@ -31,7 +31,7 @@ let init_account ctxt Contract_storage.credit ctxt contract amount >>=? fun ctxt -> match public_key with | Some public_key -> - Contract_storage.reveal_manager_key ctxt contract public_key >>=? fun ctxt -> + Contract_storage.reveal_manager_key ctxt public_key_hash public_key >>=? fun ctxt -> Delegate_storage.set ctxt contract (Some public_key_hash) >>=? fun ctxt -> return ctxt | None -> return ctxt @@ -43,11 +43,8 @@ let init_contract ~typecheck ctxt Contract_storage.originate ctxt contract ~balance:amount ~prepaid_bootstrap_storage:true - ~manager:Signature.Public_key_hash.zero ~script - ~delegate:(Some delegate) - ~spendable:false - ~delegatable:false >>=? fun ctxt -> + ~delegate:(Some delegate) >>=? fun ctxt -> return ctxt let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts = diff --git a/src/proto_alpha/lib_protocol/constants_repr.ml b/src/proto_alpha/lib_protocol/constants_repr.ml index 7ab55b46845b20d2be66e50661257e35b420ca52..6ad7b1526431ac1403eb7522b57b969a206fdd7d 100644 --- a/src/proto_alpha/lib_protocol/constants_repr.ml +++ b/src/proto_alpha/lib_protocol/constants_repr.ml @@ -23,7 +23,8 @@ (* *) (*****************************************************************************) -let version_number = "\000" +let version_number_004 = "\000" +let version_number = "\001" let proof_of_work_nonce_size = 8 let nonce_length = 32 let max_revelations_per_block = 32 @@ -95,37 +96,11 @@ type parametric = { cost_per_byte: Tez_repr.t ; hard_storage_limit_per_operation: Z.t ; test_chain_duration: int64 ; (* in seconds *) -} - -let default = { - preserved_cycles = 5 ; - blocks_per_cycle = 4096l ; - blocks_per_commitment = 32l ; - blocks_per_roll_snapshot = 256l ; - blocks_per_voting_period = 32768l ; - time_between_blocks = - List.map Period_repr.of_seconds_exn [ 60L ; 75L ] ; - endorsers_per_block = 32 ; - hard_gas_limit_per_operation = Z.of_int 800_000 ; - hard_gas_limit_per_block = Z.of_int 8_000_000 ; - proof_of_work_threshold = - Int64.(sub (shift_left 1L 46) 1L) ; - tokens_per_roll = - Tez_repr.(mul_exn one 8_000) ; - michelson_maximum_type_size = 1000 ; - seed_nonce_revelation_tip = begin - match Tez_repr.(one /? 8L) with - | Ok c -> c - | Error _ -> assert false - end ; - origination_size = 257 ; - block_security_deposit = Tez_repr.(mul_exn one 512) ; - endorsement_security_deposit = Tez_repr.(mul_exn one 64) ; - block_reward = Tez_repr.(mul_exn one 16) ; - endorsement_reward = Tez_repr.(mul_exn one 2) ; - hard_storage_limit_per_operation = Z.of_int 60_000 ; - cost_per_byte = Tez_repr.of_mutez_exn 1_000L ; - test_chain_duration = Int64.mul 32768L 60L; + quorum_min: int32 ; + quorum_max: int32 ; + min_proposal_quorum: int32 ; + initial_endorsers: int ; + delay_per_missing_endorsement: Period_repr.t ; } let parametric_encoding = @@ -152,7 +127,13 @@ let parametric_encoding = (c.endorsement_reward, c.cost_per_byte, c.hard_storage_limit_per_operation, - c.test_chain_duration))) ) + c.test_chain_duration, + c.quorum_min, + c.quorum_max, + c.min_proposal_quorum, + c.initial_endorsers, + c.delay_per_missing_endorsement + ))) ) (fun (( preserved_cycles, blocks_per_cycle, blocks_per_commitment, @@ -173,7 +154,12 @@ let parametric_encoding = (endorsement_reward, cost_per_byte, hard_storage_limit_per_operation, - test_chain_duration))) -> + test_chain_duration, + quorum_min, + quorum_max, + min_proposal_quorum, + initial_endorsers, + delay_per_missing_endorsement))) -> { preserved_cycles ; blocks_per_cycle ; blocks_per_commitment ; @@ -195,6 +181,11 @@ let parametric_encoding = cost_per_byte ; hard_storage_limit_per_operation ; test_chain_duration ; + quorum_min ; + quorum_max ; + min_proposal_quorum ; + initial_endorsers ; + delay_per_missing_endorsement ; } ) (merge_objs (obj9 @@ -217,11 +208,17 @@ let parametric_encoding = (req "block_security_deposit" Tez_repr.encoding) (req "endorsement_security_deposit" Tez_repr.encoding) (req "block_reward" Tez_repr.encoding)) - (obj4 + (obj9 (req "endorsement_reward" Tez_repr.encoding) (req "cost_per_byte" Tez_repr.encoding) (req "hard_storage_limit_per_operation" z) - (req "test_chain_duration" int64)))) + (req "test_chain_duration" int64) + (req "quorum_min" int32) + (req "quorum_max" int32) + (req "min_proposal_quorum" int32) + (req "initial_endorsers" uint16) + (req "delay_per_missing_endorsement" Period_repr.encoding) + ))) type t = { fixed : fixed ; diff --git a/src/proto_alpha/lib_protocol/constants_storage.ml b/src/proto_alpha/lib_protocol/constants_storage.ml index 3ede67cc243e867d0b119638e9c809e81c443231..c6b1dfd2a2128b55ea50ada8bc8adc27c8f01b4e 100644 --- a/src/proto_alpha/lib_protocol/constants_storage.ml +++ b/src/proto_alpha/lib_protocol/constants_storage.ml @@ -44,6 +44,12 @@ let time_between_blocks c = let endorsers_per_block c = let constants = Raw_context.constants c in constants.endorsers_per_block +let initial_endorsers c = + let constants = Raw_context.constants c in + constants.initial_endorsers +let delay_per_missing_endorsement c = + let constants = Raw_context.constants c in + constants.delay_per_missing_endorsement let hard_gas_limit_per_operation c = let constants = Raw_context.constants c in constants.hard_gas_limit_per_operation @@ -86,5 +92,14 @@ let endorsement_reward c = let test_chain_duration c = let constants = Raw_context.constants c in constants.test_chain_duration +let quorum_min c = + let constants = Raw_context.constants c in + constants.quorum_min +let quorum_max c = + let constants = Raw_context.constants c in + constants.quorum_max +let min_proposal_quorum c = + let constants = Raw_context.constants c in + constants.min_proposal_quorum let parametric c = Raw_context.constants c diff --git a/src/proto_alpha/lib_protocol/contract_repr.ml b/src/proto_alpha/lib_protocol/contract_repr.ml index 95e974ef40669323164060d775b2af0b7b668478..89632c77a7dd0ea9d391afa7f94ff5f1844f16f4 100644 --- a/src/proto_alpha/lib_protocol/contract_repr.ml +++ b/src/proto_alpha/lib_protocol/contract_repr.ml @@ -109,6 +109,8 @@ let () = let implicit_contract id = Implicit id +let originated_contract_004 id = Originated id + let is_implicit = function | Implicit m -> Some m | Originated _ -> None diff --git a/src/proto_alpha/lib_protocol/contract_repr.mli b/src/proto_alpha/lib_protocol/contract_repr.mli index 08ced771a8a70b2aa2e18132309097289ccf45f7..37f5503f69437362e677dd1eab6087e2cccd8801 100644 --- a/src/proto_alpha/lib_protocol/contract_repr.mli +++ b/src/proto_alpha/lib_protocol/contract_repr.mli @@ -30,13 +30,16 @@ type contract = t include Compare.S with type t := contract -(** {2 Implicit contracts} *****************************************************) +(** {2 Implicit contracts} *) val implicit_contract : Signature.Public_key_hash.t -> contract +(** Only for migration from proto_004 *) +val originated_contract_004 : Contract_hash.t -> contract + val is_implicit : contract -> Signature.Public_key_hash.t option -(** {2 Originated contracts} **************************************************) +(** {2 Originated contracts} *) (** Originated contracts handles are crafted from the hash of the operation that triggered their origination (and nothing else). @@ -56,7 +59,7 @@ val incr_origination_nonce : origination_nonce -> origination_nonce val is_originated : contract -> Contract_hash.t option -(** {2 Human readable notation} ***********************************************) +(** {2 Human readable notation} *) type error += Invalid_contract_notation of string (* `Permanent *) @@ -68,7 +71,7 @@ val pp: Format.formatter -> contract -> unit val pp_short: Format.formatter -> contract -> unit -(** {2 Serializers} ***********************************************************) +(** {2 Serializers} *) val encoding : contract Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 3951a34ae3741b1aba21defdcb667b72f65b5045..5d57e0174967c2fd982b6149115736d423155038 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -28,35 +28,28 @@ open Alpha_context let custom_root = (RPC_path.(open_root / "context" / "contracts") : RPC_context.t RPC_path.context) +let big_map_root = + (RPC_path.(open_root / "context" / "big_maps") : RPC_context.t RPC_path.context) + type info = { - manager: public_key_hash ; balance: Tez.t ; - spendable: bool ; - delegate: bool * public_key_hash option ; - counter: counter ; + delegate: public_key_hash option ; + counter: counter option ; script: Script.t option ; } let info_encoding = let open Data_encoding in conv - (fun {manager ; balance ; spendable ; delegate ; - script ; counter } -> - (manager, balance, spendable, delegate, - script, counter)) - (fun (manager, balance, spendable, delegate, - script, counter) -> - {manager ; balance ; spendable ; delegate ; - script ; counter}) @@ - obj6 - (req "manager" Signature.Public_key_hash.encoding) + (fun {balance ; delegate ; script ; counter } -> + (balance, delegate, script, counter)) + (fun (balance, delegate, script, counter) -> + {balance ; delegate ; script ; counter}) @@ + obj4 (req "balance" Tez.encoding) - (req "spendable" bool) - (req "delegate" @@ obj2 - (req "setable" bool) - (opt "value" Signature.Public_key_hash.encoding)) + (opt "delegate" Signature.Public_key_hash.encoding) (opt "script" Script.encoding) - (req "counter" n) + (opt "counter" n) module S = struct @@ -69,20 +62,11 @@ module S = struct ~output: Tez.encoding RPC_path.(custom_root /: Contract.rpc_arg / "balance") - let manager = - RPC_service.get_service - ~description: "Access the manager of a contract." - ~query: RPC_query.empty - ~output: Signature.Public_key_hash.encoding - RPC_path.(custom_root /: Contract.rpc_arg / "manager") - let manager_key = RPC_service.get_service ~description: "Access the manager of a contract." ~query: RPC_query.empty - ~output: (obj2 - (req "manager" Signature.Public_key_hash.encoding) - (opt "key" Signature.Public_key.encoding)) + ~output: (option Signature.Public_key.encoding) RPC_path.(custom_root /: Contract.rpc_arg / "manager_key") let delegate = @@ -99,20 +83,6 @@ module S = struct ~output: z RPC_path.(custom_root /: Contract.rpc_arg / "counter") - let spendable = - RPC_service.get_service - ~description: "Tells if the contract tokens can be spent by the manager." - ~query: RPC_query.empty - ~output: bool - RPC_path.(custom_root /: Contract.rpc_arg / "spendable") - - let delegatable = - RPC_service.get_service - ~description: "Tells if the contract delegate can be changed." - ~query: RPC_query.empty - ~output: bool - RPC_path.(custom_root /: Contract.rpc_arg / "delegatable") - let script = RPC_service.get_service ~description: "Access the code and data of the contract." @@ -127,15 +97,43 @@ module S = struct ~output: Script.expr_encoding RPC_path.(custom_root /: Contract.rpc_arg / "storage") + let entrypoint_type = + RPC_service.get_service + ~description: "Return the type of the given entrypoint of the contract" + ~query: RPC_query.empty + ~output: Script.expr_encoding + RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string) + + + let list_entrypoints = + RPC_service.get_service + ~description: "Return the list of entrypoints of the contract" + ~query: RPC_query.empty + ~output: (obj2 + (dft "unreachable" + (Data_encoding.list + (obj1 (req "path" (Data_encoding.list Michelson_v1_primitives.prim_encoding)))) + []) + (req "entrypoints" + (assoc Script.expr_encoding))) + RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints") + + let contract_big_map_get_opt = + RPC_service.post_service + ~description: "Access the value associated with a key in a big map of the contract (deprecated)." + ~query: RPC_query.empty + ~input: (obj2 + (req "key" Script.expr_encoding) + (req "type" Script.expr_encoding)) + ~output: (option Script.expr_encoding) + RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get") + let big_map_get = - RPC_service.post_service - ~description: "Access the value associated with a key in the big map storage of the contract." + RPC_service.get_service + ~description: "Access the value associated with a key in a big map." ~query: RPC_query.empty - ~input: (obj2 - (req "key" Script.expr_encoding) - (req "type" Script.expr_encoding)) - ~output: (option Script.expr_encoding) - RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get") + ~output: Script.expr_encoding + RPC_path.(big_map_root /: Big_map.rpc_arg /: Script_expr_hash.rpc_arg) let info = RPC_service.get_service @@ -170,20 +168,39 @@ let register () = f ctxt a1 >>=? function | None -> raise Not_found | Some v -> return v) in + let do_big_map_get ctxt id key = + let open Script_ir_translator in + let ctxt = Gas.set_unlimited ctxt in + Big_map.exists ctxt id >>=? fun (ctxt, types) -> + match types with + | None -> raise Not_found + | Some (_, value_type) -> + Lwt.return (parse_ty ctxt + ~legacy:true ~allow_big_map:false ~allow_operation:false ~allow_contract:true + (Micheline.root value_type)) + >>=? fun (Ex_ty value_type, ctxt) -> + Big_map.get_opt ctxt id key >>=? fun (_ctxt, value) -> + match value with + | None -> raise Not_found + | Some value -> + parse_data ctxt ~legacy:true value_type (Micheline.root value) >>=? fun (value, ctxt) -> + unparse_data ctxt Readable value_type value >>=? fun (value, _ctxt) -> + return (Micheline.strip_locations value) in register_field S.balance Contract.get_balance ; - register_field S.manager Contract.get_manager ; - register_field S.manager_key - (fun ctxt c -> - Contract.get_manager ctxt c >>=? fun mgr -> - Contract.is_manager_key_revealed ctxt c >>=? fun revealed -> - if revealed then - Contract.get_manager_key ctxt c >>=? fun key -> - return (mgr, Some key) - else return (mgr, None)) ; + register1 S.manager_key + (fun ctxt contract () () -> + match Contract.is_implicit contract with + | None -> raise Not_found + | Some mgr -> + Contract.is_manager_key_revealed ctxt mgr >>=? function + | false -> return_none + | true -> Contract.get_manager_key ctxt mgr >>=? return_some) ; register_opt_field S.delegate Delegate.get ; - register_field S.counter Contract.get_counter ; - register_field S.spendable Contract.is_spendable ; - register_field S.delegatable Contract.is_delegatable ; + register1 S.counter + (fun ctxt contract () () -> + match Contract.is_implicit contract with + | None -> raise Not_found + | Some mgr -> Contract.get_counter ctxt mgr) ; register_opt_field S.script (fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ; register_opt_field S.storage (fun ctxt contract -> @@ -193,39 +210,95 @@ let register () = | Some script -> let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in - parse_script ctxt script >>=? fun (Ex_script script, ctxt) -> + parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) -> unparse_script ctxt Readable script >>=? fun (script, ctxt) -> Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) -> return_some storage) ; - register1 S.big_map_get (fun ctxt contract () (key, key_type) -> - let open Script_ir_translator in - let ctxt = Gas.set_unlimited ctxt in - Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root key_type)) - >>=? fun (Ex_ty key_type, ctxt) -> - parse_data ctxt key_type (Micheline.root key) >>=? fun (key, ctxt) -> - hash_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - Contract.Big_map.get_opt ctxt contract key_hash >>=? fun (_ctxt, value) -> - return value) ; + register2 S.entrypoint_type + (fun ctxt v entrypoint () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) -> + match expr with + | None -> raise Not_found + | Some expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = true in + let open Script_ir_translator in + Script.force_decode ctxt expr >>=? fun (expr, _) -> + Lwt.return + begin + parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> + parse_ty ctxt ~legacy + ~allow_big_map:true ~allow_operation:false + ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.find_entrypoint ~root_name arg_type + entrypoint + end >>= function + Ok (_f , Ex_ty ty)-> + unparse_ty ctxt ty >>=? fun (ty_node, _) -> + return (Micheline.strip_locations ty_node) + | Error _ -> raise Not_found) ; + register1 S.list_entrypoints + (fun ctxt v () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) -> + match expr with + | None -> raise Not_found + | Some expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = true in + let open Script_ir_translator in + Script.force_decode ctxt expr >>=? fun (expr, _) -> + Lwt.return + begin + parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> + parse_ty ctxt ~legacy + ~allow_big_map:true ~allow_operation:false + ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.list_entrypoints ~root_name arg_type ctxt + end >>=? fun (unreachable_entrypoint,map) -> + return + (unreachable_entrypoint, + Entrypoints_map.fold + begin fun entry (_,ty) acc -> + (entry , Micheline.strip_locations ty) ::acc end + map []) + ) ; + register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) -> + Contract.get_script ctxt contract >>=? fun (ctxt, script) -> + Lwt.return (Script_ir_translator.parse_packable_ty ctxt ~legacy:true (Micheline.root key_type)) >>=? fun (Ex_ty key_type, ctxt) -> + Script_ir_translator.parse_data ctxt ~legacy:true key_type (Micheline.root key) >>=? fun (key, ctxt) -> + Script_ir_translator.hash_data ctxt key_type key >>=? fun (key, ctxt) -> + match script with + | None -> raise Not_found + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) -> + Script_ir_translator.collect_big_maps ctxt script.storage_type script.storage >>=? fun (ids, _ctxt) -> + let ids = Script_ir_translator.list_of_big_map_ids ids in + let rec find = function + | [] -> return_none + | (id : Z.t) :: ids -> try do_big_map_get ctxt id key >>=? return_some with Not_found -> find ids in + find ids) ; + register2 S.big_map_get (fun ctxt id key () () -> + do_big_map_get ctxt id key) ; register_field S.info (fun ctxt contract -> Contract.get_balance ctxt contract >>=? fun balance -> - Contract.get_manager ctxt contract >>=? fun manager -> Delegate.get ctxt contract >>=? fun delegate -> - Contract.get_counter ctxt contract >>=? fun counter -> - Contract.is_delegatable ctxt contract >>=? fun delegatable -> - Contract.is_spendable ctxt contract >>=? fun spendable -> + begin match Contract.is_implicit contract with + | Some manager -> + Contract.get_counter ctxt manager >>=? fun counter -> + return_some counter + | None -> return None + end >>=? fun counter -> Contract.get_script ctxt contract >>=? fun (ctxt, script) -> begin match script with | None -> return (None, ctxt) | Some script -> let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in - parse_script ctxt script >>=? fun (Ex_script script, ctxt) -> + parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) -> unparse_script ctxt Readable script >>=? fun (script, ctxt) -> return (Some script, ctxt) end >>=? fun (script, _ctxt) -> - return { manager ; balance ; - spendable ; delegate = (delegatable, delegate) ; - script ; counter }) + return { balance ; delegate ; script ; counter }) let list ctxt block = RPC_context.make_call0 S.list ctxt block () () @@ -236,11 +309,8 @@ let info ctxt block contract = let balance ctxt block contract = RPC_context.make_call1 S.balance ctxt block contract () () -let manager ctxt block contract = - RPC_context.make_call1 S.manager ctxt block contract () () - -let manager_key ctxt block contract = - RPC_context.make_call1 S.manager_key ctxt block contract () () +let manager_key ctxt block mgr = + RPC_context.make_call1 S.manager_key ctxt block (Contract.implicit_contract mgr) () () let delegate ctxt block contract = RPC_context.make_call1 S.delegate ctxt block contract () () @@ -248,14 +318,8 @@ let delegate ctxt block contract = let delegate_opt ctxt block contract = RPC_context.make_opt_call1 S.delegate ctxt block contract () () -let counter ctxt block contract = - RPC_context.make_call1 S.counter ctxt block contract () () - -let is_delegatable ctxt block contract = - RPC_context.make_call1 S.delegatable ctxt block contract () () - -let is_spendable ctxt block contract = - RPC_context.make_call1 S.spendable ctxt block contract () () +let counter ctxt block mgr = + RPC_context.make_call1 S.counter ctxt block (Contract.implicit_contract mgr) () () let script ctxt block contract = RPC_context.make_call1 S.script ctxt block contract () () @@ -266,8 +330,17 @@ let script_opt ctxt block contract = let storage ctxt block contract = RPC_context.make_call1 S.storage ctxt block contract () () +let entrypoint_type ctxt block contract entrypoint = + RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint () () + +let list_entrypoints ctxt block contract = + RPC_context.make_call1 S.list_entrypoints ctxt block contract () () + let storage_opt ctxt block contract = RPC_context.make_opt_call1 S.storage ctxt block contract () () -let big_map_get_opt ctxt block contract key = - RPC_context.make_call1 S.big_map_get ctxt block contract () key +let big_map_get ctxt block id key = + RPC_context.make_call2 S.big_map_get ctxt block id key () () + +let contract_big_map_get_opt ctxt block contract key = + RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key diff --git a/src/proto_alpha/lib_protocol/contract_services.mli b/src/proto_alpha/lib_protocol/contract_services.mli index 0682c387ba5234dc3e9c5eedb43adedaab346ee5..7b638ebd7904288cb4aa2d254fed4af2fe3784a6 100644 --- a/src/proto_alpha/lib_protocol/contract_services.mli +++ b/src/proto_alpha/lib_protocol/contract_services.mli @@ -29,11 +29,9 @@ val list: 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t type info = { - manager: public_key_hash ; balance: Tez.t ; - spendable: bool ; - delegate: bool * public_key_hash option ; - counter: counter ; + delegate: public_key_hash option ; + counter: counter option ; script: Script.t option ; } @@ -45,11 +43,8 @@ val info: val balance: 'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t -val manager: - 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t - val manager_key: - 'a #RPC_context.simple -> 'a -> Contract.t -> (public_key_hash * public_key option) shell_tzresult Lwt.t + 'a #RPC_context.simple -> 'a -> public_key_hash -> public_key option shell_tzresult Lwt.t val delegate: 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t @@ -57,14 +52,8 @@ val delegate: val delegate_opt: 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash option shell_tzresult Lwt.t -val is_delegatable: - 'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t - -val is_spendable: - 'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t - val counter: - 'a #RPC_context.simple -> 'a -> Contract.t -> counter shell_tzresult Lwt.t + 'a #RPC_context.simple -> 'a -> public_key_hash -> counter shell_tzresult Lwt.t val script: 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t @@ -75,12 +64,22 @@ val script_opt: val storage: 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t +val entrypoint_type: + 'a #RPC_context.simple -> 'a -> Contract.t -> string -> Script.expr shell_tzresult Lwt.t + +val list_entrypoints: + 'a #RPC_context.simple -> 'a -> Contract.t -> + (Michelson_v1_primitives.prim list list * + (string * Script.expr) list) shell_tzresult Lwt.t + val storage_opt: 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr option shell_tzresult Lwt.t -val big_map_get_opt: - 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr * Script.expr -> - Script.expr option shell_tzresult Lwt.t +val big_map_get: + 'a #RPC_context.simple -> 'a -> Z.t -> Script_expr_hash.t -> + Script.expr shell_tzresult Lwt.t +val contract_big_map_get_opt: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr * Script.expr -> Script.expr option shell_tzresult Lwt.t val register: unit -> unit diff --git a/src/proto_alpha/lib_protocol/contract_storage.ml b/src/proto_alpha/lib_protocol/contract_storage.ml index cc75a1c0dd1bd7273472d020fe1cdf6f2d42e4fe..21a74782b0f1ab29387ab441af3ab9f64a8d6cba 100644 --- a/src/proto_alpha/lib_protocol/contract_storage.ml +++ b/src/proto_alpha/lib_protocol/contract_storage.ml @@ -202,96 +202,185 @@ let () = let failwith msg = fail (Failure msg) -type big_map_diff_item = { - diff_key : Script_repr.expr; - diff_key_hash : Script_expr_hash.t; - diff_value : Script_repr.expr option; -} +type big_map_diff_item = + | Update of { + big_map : Z.t; + diff_key : Script_repr.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script_repr.expr option; + } + | Clear of Z.t + | Copy of Z.t * Z.t + | Alloc of { + big_map : Z.t; + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } + type big_map_diff = big_map_diff_item list let big_map_diff_item_encoding = let open Data_encoding in - conv - (fun { diff_key_hash ; diff_key ; diff_value } -> (diff_key_hash, diff_key, diff_value)) - (fun (diff_key_hash, diff_key, diff_value) -> { diff_key_hash ; diff_key ; diff_value }) - (obj3 - (req "key_hash" Script_expr_hash.encoding) - (req "key" Script_repr.expr_encoding) - (opt "value" Script_repr.expr_encoding)) + union + [ case (Tag 0) ~title:"update" + (obj5 + (req "action" (constant "update")) + (req "big_map" z) + (req "key_hash" Script_expr_hash.encoding) + (req "key" Script_repr.expr_encoding) + (opt "value" Script_repr.expr_encoding)) + (function + | Update { big_map ; diff_key_hash ; diff_key ; diff_value } -> + Some ((), big_map, diff_key_hash, diff_key, diff_value) + | _ -> None ) + (fun ((), big_map, diff_key_hash, diff_key, diff_value) -> + Update { big_map ; diff_key_hash ; diff_key ; diff_value }) ; + case (Tag 1) ~title:"remove" + (obj2 + (req "action" (constant "remove")) + (req "big_map" z)) + (function + | Clear big_map -> + Some ((), big_map) + | _ -> None ) + (fun ((), big_map) -> + Clear big_map) ; + case (Tag 2) ~title:"copy" + (obj3 + (req "action" (constant "copy")) + (req "source_big_map" z) + (req "destination_big_map" z)) + (function + | Copy (src, dst) -> + Some ((), src, dst) + | _ -> None ) + (fun ((), src, dst) -> + Copy (src, dst)) ; + case (Tag 3) ~title:"alloc" + (obj4 + (req "action" (constant "alloc")) + (req "big_map" z) + (req "key_type" Script_repr.expr_encoding) + (req "value_type" Script_repr.expr_encoding)) + (function + | Alloc { big_map ; key_type ; value_type } -> + Some ((), big_map, key_type, value_type) + | _ -> None ) + (fun ((), big_map, key_type, value_type) -> + Alloc { big_map ; key_type ; value_type }) ] let big_map_diff_encoding = let open Data_encoding in def "contract.big_map_diff" @@ list big_map_diff_item_encoding -let update_script_big_map c contract = function +let big_map_key_cost = 65 +let big_map_cost = 33 + +let update_script_big_map c = function | None -> return (c, Z.zero) | Some diff -> - fold_left_s (fun (c, total) diff_item -> - match diff_item.diff_value with - | None -> - Storage.Contract.Big_map.remove (c, contract) diff_item.diff_key_hash - >>=? fun (c, freed) -> - return (c, Z.sub total (Z.of_int freed)) - | Some v -> - Storage.Contract.Big_map.init_set (c, contract) diff_item.diff_key_hash v - >>=? fun (c, size_diff) -> - return (c, Z.add total (Z.of_int size_diff))) + fold_left_s (fun (c, total) -> function + | Clear id -> + Storage.Big_map.Total_bytes.get c id >>=? fun size -> + Storage.Big_map.remove_rec c id >>= fun c -> + if Compare.Z.(id < Z.zero) then + return (c, total) + else + return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost)) + | Copy (from, to_) -> + Storage.Big_map.copy c ~from ~to_ >>=? fun c -> + if Compare.Z.(to_ < Z.zero) then + return (c, total) + else + Storage.Big_map.Total_bytes.get c from >>=? fun size -> + return (c, Z.add (Z.add total size) (Z.of_int big_map_cost)) + | Alloc { big_map ; key_type ; value_type } -> + Storage.Big_map.Total_bytes.init c big_map Z.zero >>=? fun c -> + (* Annotations are erased to allow sharing on + [Copy]. The types from the contract code are used, + these ones are only used to make sure they are + compatible during transmissions between contracts, + and only need to be compatible, annotations + nonwhistanding. *) + let key_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root key_type)) in + let value_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root value_type)) in + Storage.Big_map.Key_type.init c big_map key_type >>=? fun c -> + Storage.Big_map.Value_type.init c big_map value_type >>=? fun c -> + if Compare.Z.(big_map < Z.zero) then + return (c, total) + else + return (c, Z.add total (Z.of_int big_map_cost)) + | Update { big_map ; diff_key_hash ; diff_value = None } -> + Storage.Big_map.Contents.remove (c, big_map) diff_key_hash + >>=? fun (c, freed, existed) -> + let freed = if existed then freed + big_map_key_cost else freed in + Storage.Big_map.Total_bytes.get c big_map >>=? fun size -> + Storage.Big_map.Total_bytes.set c big_map (Z.sub size (Z.of_int freed)) >>=? fun c -> + if Compare.Z.(big_map < Z.zero) then + return (c, total) + else + return (c, Z.sub total (Z.of_int freed)) + | Update { big_map ; diff_key_hash ; diff_value = Some v } -> + Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v + >>=? fun (c, size_diff, existed) -> + let size_diff = if existed then size_diff else size_diff + big_map_key_cost in + Storage.Big_map.Total_bytes.get c big_map >>=? fun size -> + Storage.Big_map.Total_bytes.set c big_map (Z.add size (Z.of_int size_diff)) >>=? fun c -> + if Compare.Z.(big_map < Z.zero) then + return (c, total) + else + return (c, Z.add total (Z.of_int size_diff))) (c, Z.zero) diff let create_base c ?(prepaid_bootstrap_storage=false) (* Free space for bootstrap contracts *) contract - ~balance ~manager ~delegate ?script ~spendable ~delegatable = - (match Contract_repr.is_implicit contract with - | None -> return Z.zero - | Some _ -> Storage.Contract.Global_counter.get c) >>=? fun counter -> + ~balance ~manager ~delegate ?script () = + begin match Contract_repr.is_implicit contract with + | None -> return c + | Some _ -> + Storage.Contract.Global_counter.get c >>=? fun counter -> + Storage.Contract.Counter.init c contract counter + end >>=? fun c -> Storage.Contract.Balance.init c contract balance >>=? fun c -> - Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) >>=? fun c -> + begin match manager with + | Some manager -> + Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) + | None -> return c + end >>=? fun c -> begin match delegate with | None -> return c | Some delegate -> Delegate_storage.init c contract delegate end >>=? fun c -> - Storage.Contract.Spendable.set c contract spendable >>= fun c -> - Storage.Contract.Delegatable.set c contract delegatable >>= fun c -> - Storage.Contract.Counter.init c contract counter >>=? fun c -> - (match script with - | Some ({ Script_repr.code ; storage }, big_map_diff) -> - Storage.Contract.Code.init c contract code >>=? fun (c, code_size) -> - Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) -> - update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size) -> - let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in - assert Compare.Z.(total_size >= Z.zero) ; - let prepaid_bootstrap_storage = - if prepaid_bootstrap_storage then - total_size - else - Z.zero - in - Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c -> - Storage.Contract.Used_storage_space.init c contract total_size - | None -> begin - match Contract_repr.is_implicit contract with - | None -> - Storage.Contract.Paid_storage_space.init c contract Z.zero >>=? fun c -> - Storage.Contract.Used_storage_space.init c contract Z.zero - | Some _ -> - return c - end >>=? fun c -> - return c) >>=? fun c -> - return c + match script with + | Some ({ Script_repr.code ; storage }, big_map_diff) -> + Storage.Contract.Code.init c contract code >>=? fun (c, code_size) -> + Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) -> + update_script_big_map c big_map_diff >>=? fun (c, big_map_size) -> + let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in + assert Compare.Z.(total_size >= Z.zero) ; + let prepaid_bootstrap_storage = + if prepaid_bootstrap_storage then + total_size + else + Z.zero + in + Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c -> + Storage.Contract.Used_storage_space.init c contract total_size + | None -> + return c let originate c ?prepaid_bootstrap_storage contract - ~balance ~manager ?script ~delegate ~spendable ~delegatable = - create_base c ?prepaid_bootstrap_storage contract ~balance ~manager - ~delegate ?script ~spendable ~delegatable + ~balance ~script ~delegate = + create_base c ?prepaid_bootstrap_storage contract ~balance + ~manager:None ~delegate ~script () let create_implicit c manager ~balance = create_base c (Contract_repr.implicit_contract manager) - ~balance ~manager ?script:None ~delegate:None - ~spendable:true ~delegatable:false + ~balance ~manager:(Some manager) ?script:None ~delegate:None () let delete c contract = match Contract_repr.is_implicit contract with @@ -302,17 +391,15 @@ let delete c contract = Delegate_storage.remove c contract >>=? fun c -> Storage.Contract.Balance.delete c contract >>=? fun c -> Storage.Contract.Manager.delete c contract >>=? fun c -> - Storage.Contract.Spendable.del c contract >>= fun c -> - Storage.Contract.Delegatable.del c contract >>= fun c -> Storage.Contract.Counter.delete c contract >>=? fun c -> - Storage.Contract.Code.remove c contract >>=? fun (c, _) -> - Storage.Contract.Storage.remove c contract >>=? fun (c, _) -> + Storage.Contract.Code.remove c contract >>=? fun (c, _, _) -> + Storage.Contract.Storage.remove c contract >>=? fun (c, _, _) -> Storage.Contract.Paid_storage_space.remove c contract >>= fun c -> Storage.Contract.Used_storage_space.remove c contract >>= fun c -> return c let allocated c contract = - Storage.Contract.Counter.get_option c contract >>=? function + Storage.Contract.Balance.get_option c contract >>=? function | None -> return_false | Some _ -> return_true @@ -349,7 +436,8 @@ let originated_from_current_nonce ~since: ctxt_since ~until: ctxt_until = | false -> return_none) (Contract_repr.originated_contracts ~since ~until) -let check_counter_increment c contract counter = +let check_counter_increment c manager counter = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Counter.get c contract >>=? fun contract_counter -> let expected = Z.succ contract_counter in if Compare.Z.(expected = counter) @@ -359,12 +447,16 @@ let check_counter_increment c contract counter = else fail (Counter_in_the_future (contract, expected, counter)) -let increment_counter c contract = +let increment_counter c manager = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Global_counter.get c >>=? fun global_counter -> Storage.Contract.Global_counter.set c (Z.succ global_counter) >>=? fun c -> Storage.Contract.Counter.get c contract >>=? fun contract_counter -> Storage.Contract.Counter.set c contract (Z.succ contract_counter) +let get_script_code c contract = + Storage.Contract.Code.get_option c contract + let get_script c contract = Storage.Contract.Code.get_option c contract >>=? fun (c, code) -> Storage.Contract.Storage.get_option c contract >>=? fun (c, storage) -> @@ -381,7 +473,8 @@ let get_storage ctxt contract = Lwt.return (Raw_context.consume_gas ctxt cost) >>=? fun ctxt -> return (ctxt, Some storage) -let get_counter c contract = +let get_counter c manager = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Counter.get_option c contract >>=? function | None -> begin match Contract_repr.is_implicit contract with @@ -390,7 +483,7 @@ let get_counter c contract = end | Some v -> return v -let get_manager c contract = +let get_manager_004 c contract = Storage.Contract.Manager.get_option c contract >>=? function | None -> begin match Contract_repr.is_implicit contract with @@ -400,19 +493,22 @@ let get_manager c contract = | Some (Manager_repr.Hash v) -> return v | Some (Manager_repr.Public_key v) -> return (Signature.Public_key.hash v) -let get_manager_key c contract = +let get_manager_key c manager = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Manager.get_option c contract >>=? function | None -> failwith "get_manager_key" | Some (Manager_repr.Hash _) -> fail (Unrevealed_manager_key contract) | Some (Manager_repr.Public_key v) -> return v -let is_manager_key_revealed c contract = +let is_manager_key_revealed c manager = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Manager.get_option c contract >>=? function | None -> return_false | Some (Manager_repr.Hash _) -> return_false | Some (Manager_repr.Public_key _) -> return_true -let reveal_manager_key c contract public_key = +let reveal_manager_key c manager public_key = + let contract = Contract_repr.implicit_contract manager in Storage.Contract.Manager.get c contract >>=? function | Public_key _ -> fail (Previously_revealed_key contract) | Hash v -> @@ -432,22 +528,15 @@ let get_balance c contract = end | Some v -> return v -let is_delegatable = Delegate_storage.is_delegatable -let is_spendable c contract = - match Contract_repr.is_implicit contract with - | Some _ -> return_true - | None -> - Storage.Contract.Spendable.mem c contract >>= return - let update_script_storage c contract storage big_map_diff = let storage = Script_repr.lazy_expr storage in - update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size_diff) -> + update_script_big_map c big_map_diff >>=? fun (c, big_map_size_diff) -> Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) -> Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size -> let new_size = Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff)) in Storage.Contract.Used_storage_space.set c contract new_size -let spend_from_script c contract amount = +let spend c contract amount = Storage.Contract.Balance.get c contract >>=? fun balance -> match Tez_repr.(balance -? amount) with | Error _ -> @@ -490,12 +579,6 @@ let credit c contract amount = Storage.Contract.Balance.set c contract balance >>=? fun c -> Roll_storage.Contract.add_amount c contract amount -let spend c contract amount = - is_spendable c contract >>=? fun spendable -> - if not spendable - then fail (Unspendable_contract contract) - else spend_from_script c contract amount - let init c = Storage.Contract.Global_counter.init c Z.zero @@ -517,10 +600,3 @@ let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space = let to_pay = Z.sub new_storage_space already_paid_space in Storage.Contract.Paid_storage_space.set c contract new_storage_space >>=? fun c -> return (to_pay, c) - -module Big_map = struct - let mem ctxt contract key = - Storage.Contract.Big_map.mem (ctxt, contract) key - let get_opt ctxt contract key = - Storage.Contract.Big_map.get_option (ctxt, contract) key -end diff --git a/src/proto_alpha/lib_protocol/contract_storage.mli b/src/proto_alpha/lib_protocol/contract_storage.mli index 00ab164624e3755f06845dd2e2e2a4e563e40a80..a8c1747e1c0e0a74ed82e77963319e68ccb01ea8 100644 --- a/src/proto_alpha/lib_protocol/contract_storage.mli +++ b/src/proto_alpha/lib_protocol/contract_storage.mli @@ -47,42 +47,49 @@ val must_be_allocated: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t val list: Raw_context.t -> Contract_repr.t list Lwt.t val check_counter_increment: - Raw_context.t -> Contract_repr.t -> Z.t -> unit tzresult Lwt.t + Raw_context.t -> Signature.Public_key_hash.t -> Z.t -> unit tzresult Lwt.t val increment_counter: - Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t + Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t -val is_delegatable: - Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t - -val is_spendable: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t - -val get_manager: +val get_manager_004: Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t tzresult Lwt.t val get_manager_key: - Raw_context.t -> Contract_repr.t -> Signature.Public_key.t tzresult Lwt.t + Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t tzresult Lwt.t val is_manager_key_revealed: - Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t + Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t val reveal_manager_key: - Raw_context.t -> Contract_repr.t -> Signature.Public_key.t -> + Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t -> Raw_context.t tzresult Lwt.t val get_balance: Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t -val get_counter: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t +val get_counter: Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t +val get_script_code: + Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t val get_script: Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.t option) tzresult Lwt.t val get_storage: Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t -type big_map_diff_item = { - diff_key : Script_repr.expr; - diff_key_hash : Script_expr_hash.t; - diff_value : Script_repr.expr option; -} +type big_map_diff_item = + | Update of { + big_map : Z.t ; + diff_key : Script_repr.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script_repr.expr option; + } + | Clear of Z.t + | Copy of Z.t * Z.t + | Alloc of { + big_map : Z.t; + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } + type big_map_diff = big_map_diff_item list val big_map_diff_encoding : big_map_diff Data_encoding.t @@ -96,26 +103,17 @@ val credit: Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t -(** checks that the contract is spendable and decrease_balance *) val spend: Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t -(** decrease_balance even if the contract is not spendable *) -val spend_from_script: - Raw_context.t -> Contract_repr.t -> Tez_repr.t -> - Raw_context.t tzresult Lwt.t - val originate: Raw_context.t -> ?prepaid_bootstrap_storage:bool -> Contract_repr.t -> balance:Tez_repr.t -> - manager:Signature.Public_key_hash.t -> - ?script:(Script_repr.t * big_map_diff option) -> + script:(Script_repr.t * big_map_diff option) -> delegate:Signature.Public_key_hash.t option -> - spendable:bool -> - delegatable:bool -> Raw_context.t tzresult Lwt.t val fresh_contract_from_current_nonce : @@ -131,10 +129,3 @@ val init: val used_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t val paid_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t val set_paid_storage_space_and_return_fees_to_pay: Raw_context.t -> Contract_repr.t -> Z.t -> (Z.t * Raw_context.t) tzresult Lwt.t - -module Big_map : sig - val mem : - Raw_context.t -> Contract_repr.t -> Script_expr_hash.t -> (Raw_context.t * bool) tzresult Lwt.t - val get_opt : - Raw_context.t -> Contract_repr.t -> Script_expr_hash.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t -end diff --git a/src/proto_alpha/lib_protocol/delegate_services.ml b/src/proto_alpha/lib_protocol/delegate_services.ml index 1f01c3cef73e0f671831337b7128d39b6085f61b..0e54e0afc1a492b4d3d2586dcfd6f93420d7dd3e 100644 --- a/src/proto_alpha/lib_protocol/delegate_services.ml +++ b/src/proto_alpha/lib_protocol/delegate_services.ml @@ -30,7 +30,7 @@ type info = { frozen_balance: Tez.t ; frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; staking_balance: Tez.t ; - delegated_contracts: Contract_hash.t list ; + delegated_contracts: Contract_repr.t list ; delegated_balance: Tez.t ; deactivated: bool ; grace_period: Cycle.t ; @@ -56,7 +56,7 @@ let info_encoding = (req "frozen_balance" Tez.encoding) (req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding) (req "staking_balance" Tez.encoding) - (req "delegated_contracts" (list Contract_hash.encoding)) + (req "delegated_contracts" (list Contract_repr.encoding)) (req "delegated_balance" Tez.encoding) (req "deactivated" bool) (req "grace_period" Cycle.encoding)) @@ -140,7 +140,7 @@ module S = struct ~description: "Returns the list of contracts that delegate to a given delegate." ~query: RPC_query.empty - ~output: (list Contract_hash.encoding) + ~output: (list Contract_repr.encoding) RPC_path.(path / "delegated_contracts") let delegated_balance = @@ -281,7 +281,7 @@ let requested_levels ~default ctxt cycles levels = Level.compare (List.concat (List.map (Level.from_raw ctxt) levels :: List.map (Level.levels_in_cycle ctxt) cycles)) in - map_p + map_s (fun level -> let current_level = Level.current ctxt in if Level.(level <= current_level) then @@ -410,7 +410,7 @@ module Baking_rights = struct match q.max_priority with | None -> 64 | Some max -> max in - map_p (baking_priorities ctxt max_priority) levels >>=? fun rights -> + map_s (baking_priorities ctxt max_priority) levels >>=? fun rights -> let rights = if q.all then rights @@ -516,7 +516,7 @@ module Endorsing_rights = struct requested_levels ~default: (Level.current ctxt, Some (Timestamp.current ctxt)) ctxt q.cycles q.levels >>=? fun levels -> - map_p (endorsement_slots ctxt) levels >>=? fun rights -> + map_s (endorsement_slots ctxt) levels >>=? fun rights -> let rights = List.concat rights in match q.delegates with | [] -> return rights @@ -534,10 +534,128 @@ module Endorsing_rights = struct end +module Endorsing_power = struct + + let endorsing_power ctxt (operation, chain_id) = + let Operation_data data = operation.protocol_data in + match data.contents with + | Single Endorsement _ -> + Baking.check_endorsement_rights ctxt chain_id { + shell = operation.shell ; + protocol_data = data ; + } >>=? fun (_, slots, _) -> + return (List.length slots) + | _ -> + failwith "Operation is not an endorsement" + + module S = struct + let endorsing_power = + let open Data_encoding in + RPC_service.post_service + ~description:"Get the endorsing power of an endorsement, that is, \ + the number of slots that the endorser has" + ~query: RPC_query.empty + ~input: (obj2 + (req "endorsement_operation" Operation.encoding) + (req "chain_id" Chain_id.encoding)) + ~output: int31 + RPC_path.(open_root / "endorsing_power") + end + + let register () = + let open Services_registration in + register0 S.endorsing_power begin fun ctxt () (op, chain_id) -> + endorsing_power ctxt (op, chain_id) + end + + let get ctxt block op chain_id = + RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id) + +end + +module Required_endorsements = struct + + let required_endorsements ctxt block_delay = + return (Baking.minimum_allowed_endorsements ctxt ~block_delay) + + module S = struct + + type t = { block_delay : Period.t } + + let required_endorsements_query = + let open RPC_query in + query (fun block_delay -> { block_delay }) + |+ field "block_delay" Period.rpc_arg Period.zero (fun t -> t.block_delay) + |> seal + + let required_endorsements = + let open Data_encoding in + RPC_service.get_service + ~description:"Minimum number of endorsements for a block to be \ + valid, given a delay of the block's timestamp with \ + respect to the minimum time to bake at the \ + block's priority" + ~query: required_endorsements_query + ~output: int31 + RPC_path.(open_root / "required_endorsements") + end + + let register () = + let open Services_registration in + register0 S.required_endorsements begin fun ctxt ({ block_delay }) () -> + required_endorsements ctxt block_delay + end + + let get ctxt block block_delay = + RPC_context.make_call0 S.required_endorsements ctxt block { block_delay } () + +end + +module Minimal_valid_time = struct + + let minimal_valid_time ctxt ~priority ~endorsing_power = + Baking.minimal_valid_time ctxt + ~priority ~endorsing_power + + module S = struct + + type t = { priority : int ; + endorsing_power : int } + + let minimal_valid_time_query = + let open RPC_query in + query (fun priority endorsing_power -> + { priority ; endorsing_power }) + |+ field "priority" RPC_arg.int 0 (fun t -> t.priority) + |+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power) + |> seal + + let minimal_valid_time = + RPC_service.get_service + ~description: "Minimal valid time for a block given a priority \ + and an endorsing power." + ~query: minimal_valid_time_query + ~output: Time.encoding + RPC_path.(open_root / "minimal_valid_time") + end + + let register () = + let open Services_registration in + register0 S.minimal_valid_time begin fun ctxt { priority ; endorsing_power } () -> + minimal_valid_time ctxt ~priority ~endorsing_power + end + + let get ctxt block priority endorsing_power = + RPC_context.make_call0 S.minimal_valid_time ctxt block { priority ; endorsing_power } () +end + let register () = register () ; Baking_rights.register () ; - Endorsing_rights.register () + Endorsing_rights.register () ; + Endorsing_power.register () ; + Required_endorsements.register () ; + Minimal_valid_time.register () let endorsement_rights ctxt level = Endorsing_rights.endorsement_slots ctxt (level, None) >>=? fun l -> @@ -551,3 +669,12 @@ let baking_rights ctxt max_priority = List.map (fun { Baking_rights.delegate ; timestamp ; _ } -> (delegate, timestamp)) l) + +let endorsing_power ctxt operation = + Endorsing_power.endorsing_power ctxt operation + +let required_endorsements ctxt delay = + Required_endorsements.required_endorsements ctxt delay + +let minimal_valid_time ctxt priority endorsing_power = + Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power diff --git a/src/proto_alpha/lib_protocol/delegate_services.mli b/src/proto_alpha/lib_protocol/delegate_services.mli index 4061a665c22f244495e5530f68540a7a83f275d0..74b282b98b3298045cea42fecd5df19f2a5a1c4d 100644 --- a/src/proto_alpha/lib_protocol/delegate_services.mli +++ b/src/proto_alpha/lib_protocol/delegate_services.mli @@ -36,7 +36,7 @@ type info = { frozen_balance: Tez.t ; frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; staking_balance: Tez.t ; - delegated_contracts: Contract_hash.t list ; + delegated_contracts: Contract_repr.t list ; delegated_balance: Tez.t ; deactivated: bool ; grace_period: Cycle.t ; @@ -72,7 +72,7 @@ val staking_balance: val delegated_contracts: 'a #RPC_context.simple -> 'a -> Signature.Public_key_hash.t -> - Contract_hash.t list shell_tzresult Lwt.t + Contract_repr.t list shell_tzresult Lwt.t val delegated_balance: 'a #RPC_context.simple -> 'a -> @@ -162,6 +162,32 @@ module Endorsing_rights : sig end +module Endorsing_power : sig + + val get: + 'a #RPC_context.simple -> 'a -> + Alpha_context.packed_operation -> + Chain_id.t -> + int shell_tzresult Lwt.t + +end + +module Required_endorsements : sig + + val get: + 'a #RPC_context.simple -> 'a -> + Period.t -> int shell_tzresult Lwt.t + +end + +module Minimal_valid_time : sig + + val get: + 'a #RPC_context.simple -> 'a -> + int -> int -> Time.t shell_tzresult Lwt.t + +end + (* temporary export for deprecated unit test *) val endorsement_rights: Alpha_context.t -> @@ -173,4 +199,20 @@ val baking_rights: int option -> (Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t +val endorsing_power: + Alpha_context.t -> + (Alpha_context.packed_operation * Chain_id.t) -> + int tzresult Lwt.t + +val required_endorsements: + Alpha_context.t -> + Alpha_context.Period.t -> + int tzresult Lwt.t + +val minimal_valid_time: + Alpha_context.t -> + int -> + int -> + Time.t tzresult Lwt.t + val register: unit -> unit diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml index da097d9d6f3bac77bf3a01c8ea6390bf3fa126f0..c8d5e878bd1a4b7521ffdd304bbb63b75992952a 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_storage.ml @@ -123,7 +123,6 @@ let frozen_balance_encoding = (req "rewards" Tez_repr.encoding)) type error += - | Non_delegatable_contract of Contract_repr.contract (* `Permanent *) | No_deletion of Signature.Public_key_hash.t (* `Permanent *) | Active_delegate (* `Temporary *) | Current_delegate (* `Temporary *) @@ -134,18 +133,6 @@ type error += balance : Tez_repr.t } (* `Temporary *) let () = - register_error_kind - `Permanent - ~id:"contract.undelegatable_contract" - ~title:"Non delegatable contract" - ~description:"Tried to delegate an implicit contract \ - or a non delegatable originated contract" - ~pp:(fun ppf contract -> - Format.fprintf ppf "Contract %a is not delegatable" - Contract_repr.pp contract) - Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) - (function Non_delegatable_contract c -> Some c | _ -> None) - (fun c -> Non_delegatable_contract c) ; register_error_kind `Permanent ~id:"delegate.no_deletion" @@ -212,33 +199,21 @@ let () = Some (delegate, balance, deposit) | _ -> None) (fun (delegate, balance, deposit) -> Balance_too_low_for_deposit { delegate ; balance ; deposit } ) -let is_delegatable c contract = - match Contract_repr.is_implicit contract with - | Some _ -> - return_false - | None -> - Storage.Contract.Delegatable.mem c contract >>= return - -let link c contract delegate balance = +let link c contract delegate = + Storage.Contract.Balance.get c contract >>=? fun balance -> Roll_storage.Delegate.add_amount c delegate balance >>=? fun c -> - match Contract_repr.is_originated contract with - | None -> return c - | Some h -> - Storage.Contract.Delegated.add - (c, Contract_repr.implicit_contract delegate) h >>= fun c -> - return c + Storage.Contract.Delegated.add (c, Contract_repr.implicit_contract delegate) contract >>= fun c -> + return c -let unlink c contract balance = +let unlink c contract = + Storage.Contract.Balance.get c contract >>=? fun balance -> Storage.Contract.Delegate.get_option c contract >>=? function | None -> return c | Some delegate -> + (* Removes the balance of the contract from the delegate *) Roll_storage.Delegate.remove_amount c delegate balance >>=? fun c -> - match Contract_repr.is_originated contract with - | None -> return c - | Some h -> - Storage.Contract.Delegated.del - (c, Contract_repr.implicit_contract delegate) h >>= fun c -> - return c + Storage.Contract.Delegated.del (c, Contract_repr.implicit_contract delegate) contract >>= fun c -> + return c let known c delegate = Storage.Contract.Manager.get_option @@ -246,55 +221,55 @@ let known c delegate = | None | Some (Manager_repr.Hash _) -> return_false | Some (Manager_repr.Public_key _) -> return_true -(* A delegate is registered if its "implicit account" - delegates to itself. *) +(* A delegate is registered if its "implicit account" delegates to itself. *) let registered c delegate = - Storage.Contract.Delegate.mem - c (Contract_repr.implicit_contract delegate) + Storage.Contract.Delegate.get_option + c (Contract_repr.implicit_contract delegate) >>=? function + | Some current_delegate -> + return @@ Signature.Public_key_hash.equal delegate current_delegate + | None -> + return_false let init ctxt contract delegate = known ctxt delegate >>=? fun known_delegate -> fail_unless known_delegate (Roll_storage.Unregistered_delegate delegate) >>=? fun () -> - registered ctxt delegate >>= fun is_registered -> + registered ctxt delegate >>=? fun is_registered -> fail_unless is_registered (Roll_storage.Unregistered_delegate delegate) >>=? fun () -> Storage.Contract.Delegate.init ctxt contract delegate >>=? fun ctxt -> - Storage.Contract.Balance.get ctxt contract >>=? fun balance -> - link ctxt contract delegate balance + link ctxt contract delegate let get = Roll_storage.get_contract_delegate -let set_base c is_delegatable contract delegate = +let set c contract delegate = match delegate with | None -> begin + let delete () = + unlink c contract >>=? fun c -> + Storage.Contract.Delegate.remove c contract >>= fun c -> + return c in match Contract_repr.is_implicit contract with | Some pkh -> - fail (No_deletion pkh) - | None -> - is_delegatable c contract >>=? fun delegatable -> - if delegatable then - Storage.Contract.Balance.get c contract >>=? fun balance -> - unlink c contract balance >>=? fun c -> - Storage.Contract.Delegate.remove c contract >>= fun c -> - return c + (* check if contract is a registered delegate *) + registered c pkh >>=? fun is_registered -> + if is_registered then + fail (No_deletion pkh) else - fail (Non_delegatable_contract contract) + delete () + | None -> delete () end | Some delegate -> known c delegate >>=? fun known_delegate -> - registered c delegate >>= fun registered_delegate -> - is_delegatable c contract >>=? fun delegatable -> + registered c delegate >>=? fun registered_delegate -> let self_delegation = match Contract_repr.is_implicit contract with | Some pkh -> Signature.Public_key_hash.equal pkh delegate | None -> false in if not known_delegate || not (registered_delegate || self_delegation) then fail (Roll_storage.Unregistered_delegate delegate) - else if not (delegatable || self_delegation) then - fail (Non_delegatable_contract contract) else begin Storage.Contract.Delegate.get_option c contract >>=? function @@ -308,14 +283,26 @@ let set_base c is_delegatable contract delegate = fail Current_delegate | None | Some _ -> return_unit end >>=? fun () -> + (* check if contract is a registered delegate *) + begin + match Contract_repr.is_implicit contract with + | Some pkh -> + registered c pkh >>=? fun is_registered -> + (* allow self-delegation to re-activate *) + if not self_delegation && is_registered then + fail (No_deletion pkh) + else + return_unit + | None -> + return_unit + end >>=? fun () -> Storage.Contract.Balance.mem c contract >>= fun exists -> fail_when (self_delegation && not exists) (Empty_delegate_account delegate) >>=? fun () -> - Storage.Contract.Balance.get c contract >>=? fun balance -> - unlink c contract balance >>=? fun c -> + unlink c contract >>=? fun c -> Storage.Contract.Delegate.init_set c contract delegate >>= fun c -> - link c contract delegate balance >>=? fun c -> + link c contract delegate >>=? fun c -> begin if self_delegation then Storage.Delegates.add c delegate >>= fun c -> @@ -326,15 +313,8 @@ let set_base c is_delegatable contract delegate = end >>=? fun c -> return c -let set c contract delegate = - set_base c is_delegatable contract delegate - -let set_from_script c contract delegate = - set_base c (fun _ _ -> return_true) contract delegate - let remove ctxt contract = - Storage.Contract.Balance.get ctxt contract >>=? fun balance -> - unlink ctxt contract balance + unlink ctxt contract let delegated_contracts ctxt delegate = let contract = Contract_repr.implicit_contract delegate in diff --git a/src/proto_alpha/lib_protocol/delegate_storage.mli b/src/proto_alpha/lib_protocol/delegate_storage.mli index 6f458403b769934fc4d739cc05f6cdd73b77b9b8..730cde3053faa5388662e4fa4463d9d327aa8592 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.mli +++ b/src/proto_alpha/lib_protocol/delegate_storage.mli @@ -49,10 +49,6 @@ type frozen_balance = { rewards : Tez_repr.t ; } -(** Is the contract eligible to delegation ? *) -val is_delegatable: - Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t - (** Allow to register a delegate when creating an account. *) val init: Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t -> @@ -67,26 +63,19 @@ val get: Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option tzresult Lwt.t -val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t +val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t (** Updating the delegate of a contract. - When calling this function on an "implicit contract" this function - fails, unless when the registered delegate is the contract manager. - In the that case, the manager is now registered as a delegate. One - cannot unregister a delegate for now. The associate contract is - now 'undeletable'. *) + When calling this function on an "implicit contract" and setting + the delegate to the contract manager registers it as a delegate. One + cannot unregister a delegate for now. The associate contract is now + 'undeletable'. *) val set: Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option -> Raw_context.t tzresult Lwt.t -(** Same as {!set} ignoring the [delegatable] flag. *) -val set_from_script: - Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option -> - Raw_context.t tzresult Lwt.t - type error += - | Non_delegatable_contract of Contract_repr.contract (* `Permanent *) | No_deletion of Signature.Public_key_hash.t (* `Permanent *) | Active_delegate (* `Temporary *) | Current_delegate (* `Temporary *) @@ -169,10 +158,10 @@ val staking_balance: Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t -(** Returns the list of contract that delegated towards a given delegate *) +(** Returns the list of contracts (implicit or originated) that delegated towards a given delegate *) val delegated_contracts: Raw_context.t -> Signature.Public_key_hash.t -> - Contract_hash.t list Lwt.t + Contract_repr.t list Lwt.t val delegated_balance: Raw_context.t -> Signature.Public_key_hash.t -> diff --git a/src/proto_alpha/lib_protocol/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index f7bbe11361d9a5f530badc06045de702615add94..7d293d0218484054219afd25fd186ce6458814ed 100644 --- a/src/proto_alpha/lib_protocol/dune.inc +++ b/src/proto_alpha/lib_protocol/dune.inc @@ -18,7 +18,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end (rule (targets registerer.ml) - (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml + (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml (:src_dir TEZOS_PROTOCOL)) (action (with-stdout-to %{targets} @@ -26,7 +26,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end (rule (targets functor.ml) - (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml + (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml (:src_dir TEZOS_PROTOCOL)) (action (with-stdout-to %{targets} (chdir %{workspace_root} @@ -34,7 +34,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end (rule (targets protocol.ml) - (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml) + (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml) (action (write-file %{targets} "module Environment = Tezos_protocol_environment_alpha.Environment @@ -62,7 +62,7 @@ include Tezos_raw_protocol_alpha.Main -open Tezos_protocol_environment_alpha__Environment -open Pervasives -open Error_monad)) - (modules Misc Storage_description State_hash Nonce_hash Script_expr_hash Contract_hash Blinded_public_key_hash Qty_repr Tez_repr Period_repr Time_repr Constants_repr Fitness_repr Raw_level_repr Voting_period_repr Cycle_repr Level_repr Seed_repr Gas_limit_repr Script_int_repr Script_timestamp_repr Michelson_v1_primitives Script_repr Contract_repr Roll_repr Vote_repr Block_header_repr Operation_repr Manager_repr Commitment_repr Parameters_repr Raw_context Storage_sigs Storage_functors Storage Constants_storage Level_storage Nonce_storage Seed_storage Roll_storage Delegate_storage Contract_storage Bootstrap_storage Fitness_storage Vote_storage Commitment_storage Init_storage Fees_storage Alpha_context Script_typed_ir Script_tc_errors Michelson_v1_gas Script_ir_annot Script_ir_translator Script_tc_errors_registration Script_interpreter Baking Amendment Apply_results Apply Services_registration Constants_services Contract_services Delegate_services Helpers_services Voting_services Alpha_services Main)) + (modules Misc Storage_description State_hash Nonce_hash Script_expr_hash Contract_hash Blinded_public_key_hash Qty_repr Tez_repr Period_repr Time_repr Constants_repr Fitness_repr Raw_level_repr Voting_period_repr Cycle_repr Level_repr Seed_repr Gas_limit_repr Script_int_repr Script_timestamp_repr Michelson_v1_primitives Script_repr Legacy_script_support_repr Contract_repr Roll_repr Vote_repr Block_header_repr Operation_repr Manager_repr Commitment_repr Parameters_repr Raw_context Storage_sigs Storage_functors Storage Constants_storage Level_storage Nonce_storage Seed_storage Roll_storage Delegate_storage Contract_storage Bootstrap_storage Fitness_storage Vote_storage Commitment_storage Init_storage Fees_storage Alpha_context Script_typed_ir Script_tc_errors Michelson_v1_gas Script_ir_annot Script_ir_translator Script_tc_errors_registration Script_interpreter Baking Amendment Apply_results Apply Services_registration Constants_services Contract_services Delegate_services Helpers_services Voting_services Alpha_services Main)) (install (section lib) diff --git a/src/proto_alpha/lib_protocol/fees_storage.ml b/src/proto_alpha/lib_protocol/fees_storage.ml index e713d96f143992b2150e6190e07bff1e070ffdfc..67640e8558b971bf12af15252097e326ff4b2540 100644 --- a/src/proto_alpha/lib_protocol/fees_storage.ml +++ b/src/proto_alpha/lib_protocol/fees_storage.ml @@ -97,7 +97,7 @@ let burn_storage_fees c ~storage_limit ~payer = else trace Cannot_pay_storage_fee (Contract_storage.must_exist c payer >>=? fun () -> - Contract_storage.spend_from_script c payer to_burn) >>=? fun c -> + Contract_storage.spend c payer to_burn) >>=? fun c -> return c let check_storage_limit c ~storage_limit = diff --git a/src/proto_alpha/lib_protocol/fitness_repr.ml b/src/proto_alpha/lib_protocol/fitness_repr.ml index 9e4e4e688457cacfc3812cb8ba8098577da097bf..9bbc19e74a5aed77229e650c0604110b021ecce6 100644 --- a/src/proto_alpha/lib_protocol/fitness_repr.ml +++ b/src/proto_alpha/lib_protocol/fitness_repr.ml @@ -57,5 +57,10 @@ let to_int64 = function when Compare.String. (MBytes.to_string version = Constants_repr.version_number) -> int64_of_bytes fitness + | [ version ; + _fitness (* ignored since higher version takes priority *) ] + when Compare.String. + (MBytes.to_string version = Constants_repr.version_number_004) -> + ok 0L | [] -> ok 0L | _ -> error Invalid_fitness diff --git a/src/proto_alpha/lib_protocol/gas_limit_repr.ml b/src/proto_alpha/lib_protocol/gas_limit_repr.ml index 27025d7d6ab023c7089d1a81b54b92720a338792..2d935809ecf90cb3cacf3970c8d9b467dc3bcbd7 100644 --- a/src/proto_alpha/lib_protocol/gas_limit_repr.ml +++ b/src/proto_alpha/lib_protocol/gas_limit_repr.ml @@ -27,6 +27,8 @@ type t = | Unaccounted | Limited of { remaining : Z.t } +type internal_gas = Z.t + type cost = { allocations : Z.t ; steps : Z.t ; @@ -90,37 +92,60 @@ let write_base_weight = Z.of_int 160 let byte_read_weight = Z.of_int 10 let byte_written_weight = Z.of_int 15 -let consume block_gas operation_gas cost = match operation_gas with - | Unaccounted -> ok (block_gas, Unaccounted) +let rescaling_bits = 7 +let rescaling_mask = + Z.sub (Z.shift_left Z.one rescaling_bits) Z.one + +let scale (z : Z.t) = Z.shift_left z rescaling_bits +let rescale (z : Z.t) = Z.shift_right z rescaling_bits + +let cost_to_internal_gas (cost : cost) : internal_gas = + Z.add + (Z.add + (Z.mul cost.allocations allocation_weight) + (Z.mul cost.steps step_weight)) + (Z.add + (Z.add + (Z.mul cost.reads read_base_weight) + (Z.mul cost.writes write_base_weight)) + (Z.add + (Z.mul cost.bytes_read byte_read_weight) + (Z.mul cost.bytes_written byte_written_weight))) + +let internal_gas_to_gas internal_gas : Z.t * internal_gas = + let gas = rescale internal_gas in + let rest = Z.logand internal_gas rescaling_mask in + (gas, rest) + +let consume block_gas operation_gas internal_gas cost = + match operation_gas with + | Unaccounted -> ok (block_gas, Unaccounted, internal_gas) | Limited { remaining } -> - let weighted_cost = - Z.add - (Z.add - (Z.mul allocation_weight cost.allocations) - (Z.mul step_weight cost.steps)) - (Z.add - (Z.add - (Z.mul read_base_weight cost.reads) - (Z.mul write_base_weight cost.writes)) - (Z.add - (Z.mul byte_read_weight cost.bytes_read) - (Z.mul byte_written_weight cost.bytes_written))) in - let remaining = - Z.sub remaining weighted_cost in - let block_remaining = - Z.sub block_gas weighted_cost in - if Compare.Z.(remaining < Z.zero) - then error Operation_quota_exceeded - else if Compare.Z.(block_remaining < Z.zero) - then error Block_quota_exceeded - else ok (block_remaining, Limited { remaining }) - -let check_enough block_gas operation_gas cost = - consume block_gas operation_gas cost - >|? fun (_block_remainig, _remaining) -> () + let cost_internal_gas = cost_to_internal_gas cost in + let total_internal_gas = + Z.add cost_internal_gas internal_gas in + let gas, rest = internal_gas_to_gas total_internal_gas in + if Compare.Z.(gas > Z.zero) then + let remaining = + Z.sub remaining gas in + let block_remaining = + Z.sub block_gas gas in + if Compare.Z.(remaining < Z.zero) + then error Operation_quota_exceeded + else if Compare.Z.(block_remaining < Z.zero) + then error Block_quota_exceeded + else ok (block_remaining, Limited { remaining }, rest) + else + ok (block_gas, operation_gas, total_internal_gas) + +let check_enough block_gas operation_gas internal_gas cost = + consume block_gas operation_gas internal_gas cost + >|? fun (_block_remainig, _remaining, _internal_gas) -> () + +let internal_gas_zero : internal_gas = Z.zero let alloc_cost n = - { allocations = Z.of_int (n + 1) ; + { allocations = scale (Z.of_int (n + 1)) ; steps = Z.zero ; reads = Z.zero ; writes = Z.zero ; @@ -133,9 +158,17 @@ let alloc_bytes_cost n = let alloc_bits_cost n = alloc_cost ((n + 63) / 64) +let atomic_step_cost n = + { allocations = Z.zero ; + steps = Z.of_int (2 * n) ; + reads = Z.zero ; + writes = Z.zero ; + bytes_read = Z.zero ; + bytes_written = Z.zero } + let step_cost n = { allocations = Z.zero ; - steps = Z.of_int n ; + steps = scale (Z.of_int n) ; reads = Z.zero ; writes = Z.zero ; bytes_read = Z.zero ; @@ -152,9 +185,9 @@ let free = let read_bytes_cost n = { allocations = Z.zero ; steps = Z.zero ; - reads = Z.one ; + reads = scale Z.one ; writes = Z.zero ; - bytes_read = n ; + bytes_read = scale n ; bytes_written = Z.zero } let write_bytes_cost n = @@ -163,7 +196,7 @@ let write_bytes_cost n = reads = Z.zero ; writes = Z.one ; bytes_read = Z.zero ; - bytes_written = n } + bytes_written = scale n } let ( +@ ) x y = { allocations = Z.add x.allocations y.allocations ; diff --git a/src/proto_alpha/lib_protocol/gas_limit_repr.mli b/src/proto_alpha/lib_protocol/gas_limit_repr.mli index 00db523537187acc2aeb2d381b504443401e6c41..d5b58c203fe5c2a7e35dc54f11c7c98f630dee24 100644 --- a/src/proto_alpha/lib_protocol/gas_limit_repr.mli +++ b/src/proto_alpha/lib_protocol/gas_limit_repr.mli @@ -27,6 +27,8 @@ type t = | Unaccounted | Limited of { remaining : Z.t } +type internal_gas + val encoding : t Data_encoding.encoding val pp : Format.formatter -> t -> unit @@ -38,10 +40,13 @@ val pp_cost : Format.formatter -> cost -> unit type error += Block_quota_exceeded (* `Temporary *) type error += Operation_quota_exceeded (* `Temporary *) -val consume : Z.t -> t -> cost -> (Z.t * t) tzresult -val check_enough : Z.t -> t -> cost -> unit tzresult +val consume : Z.t -> t -> internal_gas -> cost -> (Z.t * t * internal_gas) tzresult +val check_enough : Z.t -> t -> internal_gas -> cost -> unit tzresult + +val internal_gas_zero : internal_gas val free : cost +val atomic_step_cost : int -> cost val step_cost : int -> cost val alloc_cost : int -> cost val alloc_bytes_cost : int -> cost diff --git a/src/proto_alpha/lib_protocol/helpers_services.ml b/src/proto_alpha/lib_protocol/helpers_services.ml index 72702850782fa2caac7d1b044be0f31b156e3706..a44c6c7f3ed3f621f544b56bc01d9a75cbb7f35e 100644 --- a/src/proto_alpha/lib_protocol/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/helpers_services.ml @@ -59,14 +59,16 @@ module Scripts = struct let path = RPC_path.(path / "scripts") let run_code_input_encoding = - (obj7 + (obj9 (req "script" Script.expr_encoding) (req "storage" Script.expr_encoding) (req "input" Script.expr_encoding) (req "amount" Tez.encoding) + (req "chain_id" Chain_id.encoding) (opt "source" Contract.encoding) (opt "payer" Contract.encoding) - (opt "gas" z)) + (opt "gas" z) + (dft "entrypoint" string "default")) let trace_encoding = def "scripted.trace" @@ @@ -147,10 +149,39 @@ module Scripts = struct ~description: "Run an operation without signature checks" ~query: RPC_query.empty - ~input: Operation.encoding + ~input: (obj2 + (req "operation" Operation.encoding) + (req "chain_id" Chain_id.encoding)) ~output: Apply_results.operation_data_and_metadata_encoding RPC_path.(path / "run_operation") + let entrypoint_type = + RPC_service.post_service + ~description: "Return the type of the given entrypoint" + ~query: RPC_query.empty + ~input: (obj2 + (req "script" Script.expr_encoding) + (dft "entrypoint" string "default")) + ~output: (obj1 + (req "entrypoint_type" Script.expr_encoding)) + RPC_path.(path / "entrypoint") + + + let list_entrypoints = + RPC_service.post_service + ~description: "Return the list of entrypoints of the given script" + ~query: RPC_query.empty + ~input: (obj1 + (req "script" Script.expr_encoding)) + ~output: (obj2 + (dft "unreachable" + (Data_encoding.list + (obj1 (req "path" (Data_encoding.list Michelson_v1_primitives.prim_encoding)))) + []) + (req "entrypoints" + (assoc Script.expr_encoding))) + RPC_path.(path / "entrypoints") + end let register () = @@ -163,14 +194,11 @@ module Scripts = struct | None -> assert false in Contract.originate ctxt dummy_contract ~balance - ~manager: Signature.Public_key_hash.zero ~delegate: None - ~spendable: false - ~delegatable: false ~script: (script, None) >>=? fun ctxt -> return (ctxt, dummy_contract) in register0 S.run_code begin fun ctxt () - (code, storage, parameter, amount, source, payer, gas) -> + (code, storage, parameter, amount, chain_id, source, payer, gas, entrypoint) -> let storage = Script.lazy_expr storage in let code = Script.lazy_expr code in originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) -> @@ -183,17 +211,24 @@ module Scripts = struct | Some gas -> gas | None -> Constants.hard_gas_limit_per_operation ctxt in let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + { source ; + payer ; + self = dummy_contract ; + amount ; + chain_id } in Script_interpreter.execute ctxt Readable - ~source - ~payer - ~self:(dummy_contract, { storage ; code }) - ~amount ~parameter + step_constants + ~script:{ storage ; code } + ~entrypoint + ~parameter >>=? fun { Script_interpreter.storage ; operations ; big_map_diff ; _ } -> return (storage, operations, big_map_diff) end ; register0 S.trace_code begin fun ctxt () - (code, storage, parameter, amount, source, payer, gas) -> + (code, storage, parameter, amount, chain_id, source, payer, gas, entrypoint) -> let storage = Script.lazy_expr storage in let code = Script.lazy_expr code in originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) -> @@ -206,12 +241,19 @@ module Scripts = struct | Some gas -> gas | None -> Constants.hard_gas_limit_per_operation ctxt in let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + { source ; + payer ; + self = dummy_contract ; + amount ; + chain_id } in Script_interpreter.trace ctxt Readable - ~source - ~payer - ~self:(dummy_contract, { storage ; code }) - ~amount ~parameter + step_constants + ~script:{ storage ; code } + ~entrypoint + ~parameter >>=? fun ({ Script_interpreter.storage ; operations ; big_map_diff ; _ }, trace) -> return (storage, operations, trace, big_map_diff) end ; @@ -234,13 +276,13 @@ module Scripts = struct let ctxt = match maybe_gas with | None -> Gas.set_unlimited ctxt | Some gas -> Gas.set_limit ctxt gas in - Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ, ctxt) -> - parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) -> + Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ)) >>=? fun (Ex_ty typ, ctxt) -> + parse_data ctxt ~legacy:true typ (Micheline.root expr) >>=? fun (data, ctxt) -> Script_ir_translator.pack_data ctxt typ data >>=? fun (bytes, ctxt) -> return (bytes, Gas.level ctxt) end ; register0 S.run_operation begin fun ctxt () - { shell ; protocol_data = Operation_data protocol_data } -> + ({ shell ; protocol_data = Operation_data protocol_data }, chain_id) -> (* this code is a duplicate of Apply without signature check *) let partial_precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) @@ -249,15 +291,15 @@ module Scripts = struct Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () -> let ctxt = Gas.set_limit ctxt gas_limit in Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () -> - Contract.must_be_allocated ctxt source >>=? fun () -> + Contract.must_be_allocated ctxt (Contract.implicit_contract source) >>=? fun () -> Contract.check_counter_increment ctxt source counter >>=? fun () -> begin match operation with | Reveal pk -> Contract.reveal_manager_key ctxt source pk - | Transaction { parameters = Some arg ; _ } -> + | Transaction { parameters ; _ } -> (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) - let arg_bytes = Data_encoding.Binary.to_bytes_exn Script.lazy_expr_encoding arg in + let arg_bytes = Data_encoding.Binary.to_bytes_exn Script.lazy_expr_encoding parameters in let arg = match Data_encoding.Binary.of_bytes Script.lazy_expr_encoding arg_bytes with | Some arg -> arg | None -> assert false in @@ -267,7 +309,7 @@ module Scripts = struct (* Fail if not enough gas for complete deserialization cost *) trace Apply.Gas_quota_exceeded_init_deserialize @@ Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt - | Origination { script = Some script ; _ } -> + | Origination { script = script ; _ } -> (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) let script_bytes = Data_encoding.Binary.to_bytes_exn Script.encoding script in let script = match Data_encoding.Binary.of_bytes Script.encoding script_bytes with @@ -287,7 +329,7 @@ module Scripts = struct Contract.get_manager_key ctxt source >>=? fun _public_key -> (* signature check unplugged from here *) Contract.increment_counter ctxt source >>=? fun ctxt -> - Contract.spend ctxt source fee >>=? fun ctxt -> + Contract.spend ctxt (Contract.implicit_contract source) fee >>=? fun ctxt -> return ctxt in let rec partial_precheck_manager_contents_list : type kind. @@ -310,27 +352,61 @@ module Scripts = struct match protocol_data.contents with | Single (Manager_operation _) as op -> partial_precheck_manager_contents_list ctxt op >>=? fun ctxt -> - Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) -> + Apply.apply_manager_contents_list ctxt Optimized baker chain_id op >>= fun (_ctxt, result) -> return result | Cons (Manager_operation _, _) as op -> partial_precheck_manager_contents_list ctxt op >>=? fun ctxt -> - Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) -> + Apply.apply_manager_contents_list ctxt Optimized baker chain_id op >>= fun (_ctxt, result) -> return result | _ -> Apply.apply_contents_list - ctxt ~partial:true Chain_id.zero Optimized shell.branch baker operation + ctxt chain_id Optimized shell.branch baker operation operation.protocol_data.contents >>=? fun (_ctxt, result) -> return result - + end; + register0 S.entrypoint_type begin fun ctxt () (expr, entrypoint) -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = false in + let open Script_ir_translator in + Lwt.return + begin + parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> + parse_ty ctxt ~legacy + ~allow_big_map:true ~allow_operation:false + ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.find_entrypoint ~root_name arg_type + entrypoint + end >>=? fun (_f , Ex_ty ty)-> + unparse_ty ctxt ty >>=? fun (ty_node, _) -> + return (Micheline.strip_locations ty_node) + end ; + register0 S.list_entrypoints begin fun ctxt () expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = false in + let open Script_ir_translator in + Lwt.return + begin + parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> + parse_ty ctxt ~legacy + ~allow_big_map:true ~allow_operation:false + ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.list_entrypoints ~root_name arg_type ctxt + end >>=? fun (unreachable_entrypoint,map) -> + return + (unreachable_entrypoint, + Entrypoints_map.fold + begin fun entry (_,ty) acc -> + (entry , Micheline.strip_locations ty) ::acc end + map []) end - let run_code ctxt block code (storage, input, amount, source, payer, gas) = + let run_code ctxt block code (storage, input, amount, chain_id, source, payer, gas, entrypoint) = RPC_context.make_call0 S.run_code ctxt - block () (code, storage, input, amount, source, payer, gas) + block () (code, storage, input, amount, chain_id, source, payer, gas, entrypoint) - let trace_code ctxt block code (storage, input, amount, source, payer, gas) = + let trace_code ctxt block code (storage, input, amount, chain_id, source, payer, gas, entrypoint) = RPC_context.make_call0 S.trace_code ctxt - block () (code, storage, input, amount, source, payer, gas) + block () (code, storage, input, amount, chain_id, source, payer, gas, entrypoint) let typecheck_code ctxt block = RPC_context.make_call0 S.typecheck_code ctxt block () @@ -344,6 +420,13 @@ module Scripts = struct let run_operation ctxt block = RPC_context.make_call0 S.run_operation ctxt block () + let entrypoint_type ctxt block = + RPC_context.make_call0 S.entrypoint_type ctxt block () + + let list_entrypoints ctxt block = + RPC_context.make_call0 S.list_entrypoints ctxt block () + + end module Forge = struct @@ -403,7 +486,7 @@ module Forge = struct ~gas_limit ~storage_limit operations = Contract_services.manager_key ctxt block source >>= function | Error _ as e -> Lwt.return e - | Ok (_, revealed) -> + | Ok revealed -> let ops = List.map (fun (Manager operation) -> @@ -431,28 +514,23 @@ module Forge = struct let transaction ctxt block ~branch ~source ?sourcePubKey ~counter - ~amount ~destination ?parameters + ~amount ~destination ?(entrypoint = "default") ?parameters ~gas_limit ~storage_limit ~fee ()= - let parameters = Option.map ~f:Script.lazy_expr parameters in + let parameters = Option.unopt_map ~f:Script.lazy_expr ~default:Script.unit_parameter parameters in operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee ~gas_limit ~storage_limit - [Manager (Transaction { amount ; parameters ; destination })] + [Manager (Transaction { amount ; parameters ; destination ; entrypoint })] let origination ctxt block ~branch ~source ?sourcePubKey ~counter - ~managerPubKey ~balance - ?(spendable = true) - ?(delegatable = true) - ?delegatePubKey ?script + ~balance + ?delegatePubKey ~script ~gas_limit ~storage_limit ~fee () = operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee ~gas_limit ~storage_limit - [Manager (Origination { manager = managerPubKey ; - delegate = delegatePubKey ; + [Manager (Origination { delegate = delegatePubKey ; script ; - spendable ; - delegatable ; credit = balance ; preorigination = None })] diff --git a/src/proto_alpha/lib_protocol/helpers_services.mli b/src/proto_alpha/lib_protocol/helpers_services.mli index 0603230637ddc16a1d6800803aa177017c7176f7..fc205d97b94599f9a9b1da3720d9fa560e6106d5 100644 --- a/src/proto_alpha/lib_protocol/helpers_services.mli +++ b/src/proto_alpha/lib_protocol/helpers_services.mli @@ -40,7 +40,7 @@ module Scripts : sig val run_code: 'a #RPC_context.simple -> 'a -> Script.expr -> - (Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option * Z.t option) -> + (Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) -> (Script.expr * packed_internal_operation list * Contract.big_map_diff option) shell_tzresult Lwt.t @@ -48,7 +48,7 @@ module Scripts : sig val trace_code: 'a #RPC_context.simple -> 'a -> Script.expr -> - (Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option* Z.t option) -> + (Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) -> (Script.expr * packed_internal_operation list * Script_interpreter.execution_trace * @@ -69,9 +69,19 @@ module Scripts : sig val run_operation: 'a #RPC_context.simple -> - 'a -> packed_operation -> + 'a -> packed_operation * Chain_id.t -> (packed_protocol_data * Apply_results.packed_operation_metadata) shell_tzresult Lwt.t + val entrypoint_type: + 'a #RPC_context.simple -> + 'a -> Script.expr * string -> Script.expr shell_tzresult Lwt.t + + val list_entrypoints: + 'a #RPC_context.simple -> + 'a -> Script.expr -> + (Michelson_v1_primitives.prim list list * + (string * Script.expr) list) shell_tzresult Lwt.t + end module Forge : sig @@ -81,7 +91,7 @@ module Forge : sig val operations: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> ?sourcePubKey:public_key -> counter:counter -> fee:Tez.t -> @@ -92,7 +102,7 @@ module Forge : sig val reveal: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> sourcePubKey:public_key -> counter:counter -> fee:Tez.t -> @@ -101,11 +111,12 @@ module Forge : sig val transaction: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> ?sourcePubKey:public_key -> counter:counter -> amount:Tez.t -> destination:Contract.t -> + ?entrypoint:string -> ?parameters:Script.expr -> gas_limit:Z.t -> storage_limit:Z.t -> @@ -115,15 +126,12 @@ module Forge : sig val origination: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> ?sourcePubKey:public_key -> counter:counter -> - managerPubKey:public_key_hash -> balance:Tez.t -> - ?spendable:bool -> - ?delegatable:bool -> ?delegatePubKey: public_key_hash -> - ?script:Script.t -> + script:Script.t -> gas_limit:Z.t -> storage_limit:Z.t -> fee:Tez.t-> @@ -132,7 +140,7 @@ module Forge : sig val delegation: 'a #RPC_context.simple -> 'a -> branch:Block_hash.t -> - source:Contract.t -> + source:public_key_hash -> ?sourcePubKey:public_key -> counter:counter -> fee:Tez.t -> diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index 9d313def809a6defdaa0abb8be082611a2052186..e7ed875a5d8d926757b593c72dff6cd886c02932 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -23,10 +24,324 @@ (* *) (*****************************************************************************) -(* This is the genesis protocol: initialise the state *) +(* Delegated storage changed type of value from Contract_hash to + Contract_repr. Move all 'delegated' data into a storage with + the original type, then copy over into the new storage. *) +let migrate_delegated ctxt contract = + let path = "contracts" :: (* module Contract *) + "index" :: (* module Indexed_context *) + Contract_repr.Index.to_path contract [ + "delegated" ; (* module Delegated *) + ] in + let path_tmp = "contracts" :: (* module Contract *) + "index" :: (* module Indexed_context *) + Contract_repr.Index.to_path contract [ + "delegated_004" ; (* module Delegated *) + ] in + Raw_context.dir_mem ctxt path >>= fun exists -> + if exists then + Raw_context.copy ctxt path path_tmp >>=? fun ctxt -> + Raw_context.remove_rec ctxt path >>= fun ctxt -> + Storage.Contract.Delegated_004.fold (ctxt, contract) ~init:(Ok ctxt) ~f:(fun delegated ctxt -> + Lwt.return ctxt >>=? fun ctxt -> + let originated = Contract_repr.originated_contract_004 delegated in + Storage.Contract.Delegated.add (ctxt, contract) originated >>= fun ctxt -> + return ctxt + ) >>=? fun ctxt -> + Raw_context.remove_rec ctxt path_tmp >>= fun ctxt -> + return ctxt + else + return ctxt + +let transform_script: + (manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t) -> + manager_pkh: Signature.Public_key_hash.t -> + Raw_context.t -> + Contract_repr.t -> + Script_repr.lazy_expr -> + Raw_context.t tzresult Lwt.t = + fun transformation ~manager_pkh ctxt contract code -> + Storage.Contract.Storage.get ctxt contract >>=? fun (_ctxt, storage) -> + transformation manager_pkh code storage >>=? fun (migrated_code, migrated_storage) -> + (* Set the migrated script code for free *) + Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, code_size_diff) -> + (* Set the migrated script storage for free *) + Storage.Contract.Storage.set_free ctxt contract migrated_storage >>=? fun (ctxt, storage_size_diff) -> + Storage.Contract.Used_storage_space.get ctxt contract >>=? fun used_space -> + let total_size = Z.(add (of_int code_size_diff) (add (of_int storage_size_diff) used_space)) in + (* Free storage space for migrated contracts *) + Storage.Contract.Used_storage_space.set ctxt contract total_size >>=? fun ctxt -> + Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_space -> + if Compare.Z.(paid_space < total_size) then + Storage.Contract.Paid_storage_space.set ctxt contract total_size >>=? fun ctxt -> + return ctxt + else + return ctxt + +let manager_script_storage: Signature.Public_key_hash.t -> Script_repr.lazy_expr = + fun manager_pkh -> + let open Micheline in + Script_repr.lazy_expr @@ strip_locations @@ + (* store in optimized binary representation - as unparsed with [Optimized]. *) + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh in + Bytes (0, bytes) + +(* If the given contract is not allocated, we'll allocate it with 1 mutez, + so that the migrated contracts' managers don't have to pay origination burn *) +let allocate_contract ctxt contract = + Contract_storage.allocated ctxt contract >>=? function + | true -> + return ctxt + | false -> + Contract_storage.credit ctxt contract Tez_repr.one_mutez + +(* Process an individual contract *) +let process_contract_add_manager contract ctxt = + let open Legacy_script_support_repr in + match Contract_repr.is_originated contract with + | None -> return ctxt (* Only process originated contracts *) + | Some _ -> begin + Storage.Contract.Counter.remove ctxt contract >>= fun ctxt -> + Storage.Contract.Spendable_004.mem ctxt contract >>= fun is_spendable -> + Storage.Contract.Delegatable_004.mem ctxt contract >>= fun is_delegatable -> + Storage.Contract.Spendable_004.del ctxt contract >>= fun ctxt -> + Storage.Contract.Delegatable_004.del ctxt contract >>= fun ctxt -> + (* Try to get script code (ignore ctxt update to discard the initialization) *) + Storage.Contract.Code.get_option ctxt contract >>=? fun (_ctxt, code) -> + (* Get the manager of the originated contract *) + Contract_storage.get_manager_004 ctxt contract >>=? fun manager_pkh -> + let manager = Contract_repr.implicit_contract manager_pkh in + Storage.Contract.Manager.remove ctxt contract >>= fun ctxt -> + match code with + | Some code -> + (* + | spendable | delegatable | template | + |-----------+-------------+------------------| + | true | true | add_do | + | true | false | add_do | + | false | true | add_set_delegate | + | false | false | nothing | + *) + if is_spendable then + transform_script add_do ~manager_pkh ctxt contract code >>=? fun ctxt -> + allocate_contract ctxt manager + else if is_delegatable then + transform_script add_set_delegate ~manager_pkh ctxt contract code >>=? fun ctxt -> + allocate_contract ctxt manager + else if has_default_entrypoint code then + transform_script + (fun ~manager_pkh:_ ~script_code ~script_storage -> + add_root_entrypoint script_code >>=? fun script_code -> + return (script_code, script_storage)) + ~manager_pkh ctxt contract code + else + return ctxt + | None -> begin + (* Initialize the script code for free *) + Storage.Contract.Code.init_free ctxt contract manager_script_code >>=? fun (ctxt, code_size) -> + let storage = manager_script_storage manager_pkh in + (* Initialize the script storage for free *) + Storage.Contract.Storage.init_free ctxt contract storage >>=? fun (ctxt, storage_size) -> + let total_size = Z.(add (of_int code_size) (of_int storage_size)) in + (* Free storage space for migrated contracts *) + Storage.Contract.Paid_storage_space.init_set ctxt contract total_size >>= fun ctxt -> + Storage.Contract.Used_storage_space.init_set ctxt contract total_size >>= fun ctxt -> + allocate_contract ctxt manager + end + end + +(* The [[update_contract_script]] function returns a copy of its + argument (the Micheline AST of a contract script) with "ADDRESS" + replaced by "ADDRESS; CHAIN_ID; PAIR". + + [[Micheline.strip_locations]] should be called on the resulting + Micheline AST to get meaningful locations. *) + +let rec update_contract_script : ('l, 'p) Micheline.node -> ('l, 'p) Micheline.node + = function + | Micheline.Seq (_, + Micheline.Prim (_, Michelson_v1_primitives.I_ADDRESS, [], []) :: + l) -> + Micheline.Seq (0, + Micheline.Prim (0, Michelson_v1_primitives.I_ADDRESS, [], []) :: + Micheline.Prim (0, Michelson_v1_primitives.I_CHAIN_ID, [], []) :: + Micheline.Prim (0, Michelson_v1_primitives.I_PAIR, [], []) :: l) + | Micheline.Seq (_, a :: l) -> + let a' = update_contract_script a in + let b = Micheline.Seq (0, l) in + let b' = update_contract_script b in + begin match b' with + | Micheline.Seq (_, l') -> + Micheline.Seq (0, a' :: l') + | _ -> assert false + end + | Micheline.Prim (_, p, l, annot) -> + Micheline.Prim (0, p, List.map update_contract_script l, annot) + | script -> script + +let migrate_multisig_script (ctxt : Raw_context.t) (contract : Contract_repr.t) + (code : Script_repr.expr) : Raw_context.t tzresult Lwt.t = + let migrated_code = + Script_repr.lazy_expr @@ Micheline.strip_locations @@ + update_contract_script @@ Micheline.root code + in + Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, _code_size_diff) -> + (* Set the spendable and delegatable flags to false so that no entrypoint gets added by + the [[process_contract_add_manager]] function. *) + Storage.Contract.Spendable_004.set ctxt contract false >>= fun ctxt -> + Storage.Contract.Delegatable_004.set ctxt contract false >>= fun ctxt -> + return ctxt + +(* The hash of the multisig contract; only contracts with this exact + hash are going to be updated by the [[update_contract_script]] + function. *) +let multisig_hash : Script_expr_hash.t = + Script_expr_hash.of_bytes_exn @@ + MBytes.of_hex @@ + `Hex "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31" + +let process_contract_multisig (contract : Contract_repr.t) (ctxt : Raw_context.t) = + Contract_storage.get_script ctxt contract >>=? fun (ctxt, script_opt) -> + match script_opt with + | None -> + (* Do nothing on scriptless contracts *) + return ctxt + | Some { Script_repr.code = code ; Script_repr.storage = _storage } -> + (* The contract has some script, only try to modify it if it has + the hash of the multisig contract *) + Lwt.return (Script_repr.force_decode code) >>=? fun (code, _gas_cost) -> + let bytes = + Data_encoding.Binary.to_bytes_exn Script_repr.expr_encoding code + in + let hash = Script_expr_hash.hash_bytes [ bytes ] in + if Script_expr_hash.(hash = multisig_hash) then + migrate_multisig_script ctxt contract code + else + return ctxt + +(* Process an individual contract *) +let process_contract contract ctxt = + process_contract_multisig contract ctxt >>=? fun ctxt -> + process_contract_add_manager contract ctxt >>=? fun ctxt -> + return ctxt + +let invoice_contract ctxt kt1_addr amount = + let amount = Tez_repr.of_mutez_exn (Int64.(mul 1_000_000L (of_int amount))) in + match Contract_repr.of_b58check kt1_addr with + | Ok recipient -> begin + Contract_storage.credit ctxt recipient amount >>= function + | Ok ctxt -> return ctxt + | Error _ -> return ctxt end + | Error _ -> return ctxt + +(* Extract Big_maps from their parent contract directory, + recompute their used space, and assign them an ID. *) +let migrate_contract_big_map ctxt contract = + Storage.Contract.Code.get_option ctxt contract >>=? function + | ctxt, None -> return ctxt + | ctxt, Some code -> + Storage.Contract.Storage.get ctxt contract >>=? fun (ctxt, storage) -> + let extract_big_map_types expr = + let open Michelson_v1_primitives in + let open Micheline in + match Micheline.root expr with + | Seq (_, [ Prim (_, K_storage, [ expr ], _) ; _ ; _ ]) + | Seq (_, [ _ ; Prim (_, K_storage, [ expr ], _) ; _ ]) + | Seq (_, [ _ ; _ ; Prim (_, K_storage, [ expr ], _) ]) -> + begin match expr with + | Prim (_, T_pair, [ Prim (_, T_big_map, [ kt ; vt ], _ ) ; _ ], _) -> Some (kt, vt) + | _ -> None + end + | _ -> None in + let rewrite_big_map expr id = + let open Michelson_v1_primitives in + let open Micheline in + match Micheline.root expr with + | Prim (_, D_Pair, [ Seq (_, _ (* ignore_unused_origination_literal *)) ; pannot ], sannot) -> + Micheline.strip_locations (Prim (0, D_Pair, [ Int (0, id) ; pannot ], sannot)) + | _ -> assert false in + Lwt.return (Script_repr.force_decode code) >>=? fun (code, _) -> + match extract_big_map_types code with + | None -> return ctxt + | Some (kt, vt) -> + Lwt.return (Script_repr.force_decode storage) >>=? fun (storage, _) -> + Storage.Big_map.Next.incr ctxt >>=? fun (ctxt, id) -> + let contract_path suffix = + "contracts" :: (* module Contract *) + "index" :: (* module Indexed_context *) + Contract_repr.Index.to_path contract suffix in + let old_path = contract_path [ "big_map" ] in + let storage = rewrite_big_map storage id in + Storage.Contract.Storage.set ctxt contract (Script_repr.lazy_expr storage) >>=? fun (ctxt, _) -> + let kt = Micheline.strip_locations (Script_repr.strip_annotations kt) in + let vt = Micheline.strip_locations (Script_repr.strip_annotations vt) in + Storage.Big_map.Key_type.init ctxt id kt >>=? fun ctxt -> + Storage.Big_map.Value_type.init ctxt id vt >>=? fun ctxt -> + Raw_context.dir_mem ctxt old_path >>= fun exists -> + if exists then + let read_size ctxt key = + Raw_context.get ctxt key >>=? fun len -> + match Data_encoding.(Binary.of_bytes int31) len with + | None -> assert false + | Some len -> return len in + let iter_sizes f (ctxt, acc) = + let rec dig i path (ctxt, acc) = + if Compare.Int.(i <= 0) then + Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc -> + Lwt.return acc >>=? fun (ctxt, acc) -> + match k with + | `Dir _ -> return (ctxt, acc) + | `Key file -> + match List.rev file with + | last :: _ when Compare.String.(last = "data") -> + return (ctxt, acc) + | last :: _ when Compare.String.(last = "len") -> + read_size ctxt file >>=? fun len -> + return (ctxt, f len acc) + | _ -> assert false + end + else + Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc -> + Lwt.return acc >>=? fun (ctxt, acc) -> + match k with + | `Dir k -> dig (i-1) k (ctxt, acc) + | `Key _ -> return (ctxt, acc) + end in + dig Script_expr_hash.path_length old_path (ctxt, acc) in + iter_sizes + (fun s acc -> (acc |> Z.add (Z.of_int s) |> Z.add (Z.of_int 65))) + (ctxt, (Z.of_int 0)) >>=? fun (ctxt, total_bytes) -> + Storage.Big_map.Total_bytes.init ctxt id total_bytes >>=? fun ctxt -> + let new_path = "big_maps" :: (* module Big_map *) + "index" :: (* module Indexed_context *) + Storage.Big_map.Index.to_path id [ + "contents" ; (* module Delegated *) + ] in + Raw_context.copy ctxt old_path new_path >>=? fun ctxt -> + Raw_context.remove_rec ctxt old_path >>= fun ctxt -> + read_size ctxt (contract_path [ "len" ; "code" ]) >>=? fun code_size -> + read_size ctxt (contract_path [ "len" ; "storage" ]) >>=? fun storage_size -> + let total_bytes = + total_bytes |> + Z.add (Z.of_int 33) |> + Z.add (Z.of_int code_size) |> + Z.add (Z.of_int storage_size) in + Storage.Contract.Used_storage_space.get ctxt contract >>=? fun previous_size -> + Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_bytes -> + let change = Z.sub paid_bytes previous_size in + Storage.Contract.Used_storage_space.set ctxt contract total_bytes >>=? fun ctxt -> + Storage.Contract.Paid_storage_space.set ctxt contract (Z.add total_bytes change) + else + Storage.Big_map.Total_bytes.init ctxt id Z.zero >>=? fun ctxt -> + return ctxt + let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = Raw_context.prepare_first_block ~level ~timestamp ~fitness ctxt >>=? fun (previous_protocol, ctxt) -> + Storage.Big_map.Next.init ctxt >>=? fun ctxt -> match previous_protocol with | Genesis param -> Commitment_storage.init ctxt param.commitments >>=? fun ctxt -> @@ -41,11 +356,24 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = param.bootstrap_contracts >>=? fun ctxt -> Roll_storage.init_first_cycles ctxt >>=? fun ctxt -> Vote_storage.init ctxt >>=? fun ctxt -> - Storage.Last_block_priority.init ctxt 0 >>=? fun ctxt -> + Storage.Block_priority.init ctxt 0 >>=? fun ctxt -> Vote_storage.freeze_listings ctxt >>=? fun ctxt -> return ctxt | Alpha_previous -> + Storage.Vote.Current_quorum_004.get ctxt >>=? fun quorum -> + Storage.Vote.Participation_ema.init ctxt quorum >>=? fun ctxt -> + Storage.Vote.Current_quorum_004.delete ctxt >>=? fun ctxt -> + Storage.Block_priority.init ctxt 0 >>=? fun ctxt -> + Storage.Last_block_priority.delete ctxt >>=? fun ctxt -> + Storage.Contract.fold ctxt ~init:(Ok ctxt) + ~f:(fun contract ctxt -> + Lwt.return ctxt >>=? fun ctxt -> + migrate_delegated ctxt contract >>=? fun ctxt -> + migrate_contract_big_map ctxt contract >>=? fun ctxt -> + process_contract contract ctxt) + >>=? fun ctxt -> + invoice_contract ctxt "KT1DUfaMfTRZZkvZAYQT5b3byXnvqoAykc43" 500 >>=? fun ctxt -> return ctxt -let prepare ctxt ~level ~timestamp ~fitness = - Raw_context.prepare ~level ~timestamp ~fitness ctxt +let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness = + Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt diff --git a/src/proto_alpha/lib_protocol/legacy_script_support_repr.ml b/src/proto_alpha/lib_protocol/legacy_script_support_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..e9c74fae8ddd48c509dbe37d17ad5d8db94c88ec --- /dev/null +++ b/src/proto_alpha/lib_protocol/legacy_script_support_repr.ml @@ -0,0 +1,532 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019 Nomadic Labs *) +(* Copyright (c) 2019 Cryptium Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let manager_script_code: Script_repr.lazy_expr = + let open Micheline in + let open Michelson_v1_primitives in + Script_repr.lazy_expr @@ strip_locations @@ + Seq (0, [ + Prim (0, K_parameter, [ + Prim (0, T_or, [ + Prim (0, T_lambda, [ + Prim (0, T_unit, [], []); + Prim (0, T_list, [ + Prim (0, T_operation, [], []) + ], []) + ], ["%do"]); + Prim (0, T_unit, [], ["%default"]) + ], []) + ], []); + Prim (0, K_storage, [ + Prim (0, T_key_hash, [], []) + ], []); + Prim (0, K_code, [ + Seq (0, [ + Seq (0, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []) + ]) + ], []) + ]) + ]); + Prim (0, I_IF_LEFT, [ + Seq (0, [ + Prim (0, I_PUSH, [ + Prim (0, T_mutez, [], []); + Int (0, Z.zero) + ], []); + Prim (0, I_AMOUNT, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) + ]); + Prim (0, I_IF, [ + Seq (0, []); + Seq (0, [ + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_FAILWITH, [], []) + ]) + ]) + ], []) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_DUP, [], []) + ]) + ], []); + Prim (0, I_SWAP, [], []) + ]); + Prim (0, I_IMPLICIT_ACCOUNT, [], []); + Prim (0, I_ADDRESS, [], []); + Prim (0, I_SENDER, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) + ]); + Prim (0, I_IF, [ + Seq (0, []); + Seq (0, [ + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_FAILWITH, [], []) + ]) + ]) + ], []) + ]); + Prim (0, I_UNIT, [], []); + Prim (0, I_EXEC, [], []); + Prim (0, I_PAIR, [], []) + ]); + Seq (0, [ + Prim (0, I_DROP, [], []); + Prim (0, I_NIL, [ + Prim (0, T_operation, [], []) + ], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ], []) + ]) + +(* Find the toplevel expression with a given prim type from list, + because they can be in arbitrary order. *) +let find_toplevel toplevel exprs = + let open Micheline in + let rec iter toplevel = function + | (Prim (_, prim, _, _) as found) :: _ + when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim) -> + Some found + | _ :: rest -> + iter toplevel rest + | [] -> + None in + iter (Michelson_v1_primitives.string_of_prim toplevel) exprs + +let add_do: + manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t = + fun ~manager_pkh ~script_code ~script_storage -> + let open Micheline in + let open Michelson_v1_primitives in + Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) -> + Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) -> + let storage_expr = root script_storage_expr in + match root script_code_expr with + | Seq (_, toplevel) + -> begin + match find_toplevel K_parameter toplevel, + find_toplevel K_storage toplevel, + find_toplevel K_code toplevel with + Some (Prim (_, K_parameter, [ + Prim (_, parameter_type, parameter_expr, parameter_annot) + ], prim_param_annot)), + Some (Prim (_, K_storage, [ + Prim (_, code_storage_type, code_storage_expr, code_storage_annot) + ], k_storage_annot)), + Some (Prim (_, K_code, [code_expr], code_annot)) -> + (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *) + + let migrated_code = + Seq (0, [ + Prim (0, K_parameter, [ + Prim (0, T_or, [ + Prim (0, T_lambda, [ + Prim (0, T_unit, [], []); + Prim (0, T_list, [ + Prim (0, T_operation, [], []) + ], []) + ], ["%do"]); + Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot) + ], []) + ], prim_param_annot); + Prim (0, K_storage, [ + Prim (0, T_pair, [ + Prim (0, T_key_hash, [], []); + Prim (0, code_storage_type, code_storage_expr, code_storage_annot) + ], []) + ], k_storage_annot); + Prim (0, K_code, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IF_LEFT, [ + Seq (0, [ + Prim (0, I_PUSH, [ + Prim (0, T_mutez, [], []); + Int (0, Z.zero) + ], []); + Prim (0, I_AMOUNT, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) + ]); + Prim (0, I_IF, [ + Seq (0, []); + Seq (0, [ + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_FAILWITH, [], []) + ]) + ]) + ], []) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_DUP, [], []) + ]) + ], []); + Prim (0, I_SWAP, [], []) + ]); + Prim (0, I_CDR, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IMPLICIT_ACCOUNT, [], []); + Prim (0, I_ADDRESS, [], []); + Prim (0, I_SENDER, [], []); + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_NEQ, [], []); + Prim (0, I_IF, [ + Seq (0, [ + Prim (0, I_SENDER, [], []); + Prim (0, I_PUSH, [ + Prim (0, T_string, [], []); + String (0, "Only the owner can operate.") + ], []); + Prim (0, I_PAIR, [], []); + Prim (0, I_FAILWITH, [], []) + ]); + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_EXEC, [], []); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []); + Prim (0, I_DUP, [], []); + Prim (0, I_CDR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []); + + code_expr; + + Prim (0, I_SWAP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_SWAP, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []) + ]) + ], []) + ]) + ]); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_SWAP, [], []); + Prim (0, I_PAIR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ], code_annot) + ]) + in + let migrated_storage = Prim (0, D_Pair, [ + (* Instead of + `String (0, Signature.Public_key_hash.to_b58check manager_pkh)` + the storage is written as unparsed with [Optimized] *) + Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ; + storage_expr + ], []) in + Script_repr.lazy_expr @@ strip_locations migrated_code, + Script_repr.lazy_expr @@ strip_locations migrated_storage + | _ -> + script_code, script_storage + end + | _ -> + script_code, script_storage + + + +let add_set_delegate: + manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t = + fun ~manager_pkh ~script_code ~script_storage -> + let open Micheline in + let open Michelson_v1_primitives in + Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) -> + Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) -> + let storage_expr = root script_storage_expr in + match root script_code_expr with + | Seq (_, toplevel) + -> begin + match find_toplevel K_parameter toplevel, + find_toplevel K_storage toplevel, + find_toplevel K_code toplevel with + Some (Prim (_, K_parameter, [ + Prim (_, parameter_type, parameter_expr, parameter_annot) + ], prim_param_annot)), + Some (Prim (_, K_storage, [ + Prim (_, code_storage_type, code_storage_expr, code_storage_annot) + ], k_storage_annot)), + Some (Prim (_, K_code, [code_expr], code_annot)) -> + (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *) + + let migrated_code = + Seq (0, [ + Prim (0, K_parameter, [ + Prim (0, T_or, [ + Prim (0, T_or, [ + Prim (0, T_key_hash, [], ["%set_delegate"]); + Prim (0, T_unit, [], ["%remove_delegate"]) + ], []); + Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot) + ], []) + ], prim_param_annot); + Prim (0, K_storage, [ + Prim (0, T_pair, [ + Prim (0, T_key_hash, [], []); + Prim (0, code_storage_type, code_storage_expr, code_storage_annot) + ], []) + ], k_storage_annot); + Prim (0, K_code, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IF_LEFT, [ + Seq (0, [ + Prim (0, I_PUSH, [ + Prim (0, T_mutez, [], []); + Int (0, Z.zero) + ], []); + Prim (0, I_AMOUNT, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) + ]); + Prim (0, I_IF, [ + Seq (0, []); + Seq (0, [ + Seq (0, [ + Prim (0, I_UNIT, [], []); + Prim (0, I_FAILWITH, [], []) + ]) + ]) + ], []) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_DUP, [], []) + ]) + ], []); + Prim (0, I_SWAP, [], []) + ]); + Prim (0, I_CDR, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IMPLICIT_ACCOUNT, [], []); + Prim (0, I_ADDRESS, [], []); + Prim (0, I_SENDER, [], []); + Seq (0, [ + Prim (0, I_COMPARE, [], []); + Prim (0, I_NEQ, [], []); + Prim (0, I_IF, [ + Seq (0, [ + Prim (0, I_SENDER, [], []); + Prim (0, I_PUSH, [ + Prim (0, T_string, [], []); + String (0, "Only the owner can operate.") + ], []); + Prim (0, I_PAIR, [], []); + Prim (0, I_FAILWITH, [], []) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []); + Prim (0, I_NIL, [ + Prim (0, T_operation, [], []) + ], []) + ]) + ], []); + Prim (0, I_IF_LEFT, [ + Seq (0, [ + Prim (0, I_SOME, [], []); + Prim (0, I_SET_DELEGATE, [], []); + Prim (0, I_CONS, [], []); + Prim (0, I_PAIR, [], []) + ]); + Seq (0, [ + Prim (0, I_DROP, [], []); + Prim (0, I_NONE, [ + Prim (0, T_key_hash, [], []) + ], []); + Prim (0, I_SET_DELEGATE, [], []); + Prim (0, I_CONS, [], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ], []) + ]) + ]); + Seq (0, [ + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []); + Prim (0, I_DUP, [], []); + Prim (0, I_CDR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []); + + code_expr; + + Prim (0, I_SWAP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_SWAP, [], []); + Seq (0, [ + Seq (0, [ + Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_CDR, [], []) + ]) + ], []) + ]) + ]); + Prim (0, I_DIP, [ + Seq (0, [ + Prim (0, I_SWAP, [], []); + Prim (0, I_PAIR, [], []) + ]) + ], []); + Prim (0, I_PAIR, [], []) + ]) + ], []) + ]) + ], code_annot) + ]) + in + let migrated_storage = Prim (0, D_Pair, [ + (* Instead of + `String (0, Signature.Public_key_hash.to_b58check manager_pkh)` + the storage is written as unparsed with [Optimized] *) + Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ; + storage_expr + ], []) in + Script_repr.lazy_expr @@ strip_locations migrated_code, + Script_repr.lazy_expr @@ strip_locations migrated_storage + | _ -> + script_code, script_storage + end + | _ -> + script_code, script_storage + +let has_default_entrypoint expr = + let open Micheline in + let open Michelson_v1_primitives in + match Script_repr.force_decode expr with + | Error _ -> false + | Ok (expr, _) -> + match root expr with + | Seq (_, toplevel) -> begin + match find_toplevel K_parameter toplevel with + | Some (Prim (_, K_parameter, [ _ ], [ "%default" ])) -> false + | Some (Prim (_, K_parameter, [ parameter_expr ], _)) -> + let rec has_default = function + | Prim (_, T_or, [ l ; r ], annots) -> + List.exists (String.equal "%default") annots || has_default l || has_default r + | Prim (_, _, _, annots) -> + List.exists (String.equal "%default") annots + | _ -> false + in + has_default parameter_expr + | Some _ | None -> false + end + | _ -> false + +let add_root_entrypoint + : script_code: Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t + = fun ~script_code -> + let open Micheline in + let open Michelson_v1_primitives in + Lwt.return (Script_repr.force_decode script_code) >>|? fun (script_code_expr, _gas_cost) -> + match root script_code_expr with + | Seq (_, toplevel) -> + let migrated_code = + Seq (0, List.map (function + | Prim (_, K_parameter, [ parameter_expr ], _) -> + Prim (0, K_parameter, [ parameter_expr ], [ "%root" ]) + | Prim (_, K_code, exprs, annots) -> + let rec rewrite_self = function + | Int _ | String _ | Bytes _ | Prim (_, I_CREATE_CONTRACT, _, _) as leaf -> leaf + | Prim (_, I_SELF, [], annots) -> + Prim (0, I_SELF, [], "%root" :: annots) + | Prim (_, name, args, annots) -> + Prim (0, name, List.map rewrite_self args, annots) + | Seq (_, args) -> + Seq (0, List.map rewrite_self args) in + Prim (0, K_code, List.map rewrite_self exprs, annots) + | other -> other) + toplevel) in + Script_repr.lazy_expr @@ strip_locations migrated_code + | _ -> + script_code diff --git a/src/proto_alpha/lib_protocol/legacy_script_support_repr.mli b/src/proto_alpha/lib_protocol/legacy_script_support_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..0b69d33938c37b5d196946c4af5f3eff0bac385b --- /dev/null +++ b/src/proto_alpha/lib_protocol/legacy_script_support_repr.mli @@ -0,0 +1,69 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019 Nomadic Labs *) +(* Copyright (c) 2019 Cryptium Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** This code mimics the now defunct scriptless KT1s. + + The manager contract is from: + https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/manager.tz + The formal proof is at: + https://gitlab.com/nomadic-labs/mi-cho-coq/blob/a7603e12021166e15890f6d504feebec2f945502/src/contracts_coq/manager.v *) +val manager_script_code: Script_repr.lazy_expr + +(** This code mimics the now defunct "spendable" flags of KT1s by + adding a [do] entrypoint, preserving the original script's at + 'default' entrypoint. + + The pseudo-code for the applied transformations is from: + https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_do.tz *) +val add_do: + manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t + +(** This code mimics the now defunct "spendable" flags of KT1s by + adding a [do] entrypoint, preserving the original script's at + 'default' entrypoint. + + The pseudo-code for the applied transformations is from: + https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_set_delegate.tz *) +val add_set_delegate: + manager_pkh: Signature.Public_key_hash.t -> + script_code: Script_repr.lazy_expr -> + script_storage: Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t + +(** Checks if a contract was declaring a default entrypoint somewhere + else than at the root, in which case its type changes when + entrypoints are activated. *) +val has_default_entrypoint: + Script_repr.lazy_expr -> bool + +(** Adds a [%root] annotation on the toplevel parameter construct. *) +val add_root_entrypoint: + script_code: Script_repr.lazy_expr -> + Script_repr.lazy_expr tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index ec05389ca1678a286b69697d006d0552edc58d2a..6fe0c821d8dbf596f1ca6c4e3f2cd5d4d61a3ce5 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -54,7 +54,6 @@ type operation = Alpha_context.packed_operation = { protocol_data: operation_data ; } - let acceptable_passes = Alpha_context.Operation.acceptable_passes let max_block_length = @@ -81,10 +80,12 @@ type validation_mode = | Application of { block_header : Alpha_context.Block_header.t ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } | Partial_application of { block_header : Alpha_context.Block_header.t ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } | Partial_construction of { predecessor : Block_hash.t ; @@ -93,6 +94,7 @@ type validation_mode = predecessor : Block_hash.t ; protocol_data : Alpha_context.Block_header.contents ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } type validation_state = @@ -114,12 +116,12 @@ let begin_partial_application let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - Alpha_context.prepare ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> Apply.begin_application - ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker) -> + ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) -> let mode = Partial_application - { block_header ; baker = Signature.Public_key.hash baker } in + { block_header ; baker = Signature.Public_key.hash baker ; block_delay } in return { mode ; chain_id ; ctxt ; op_count = 0 } let begin_application @@ -131,16 +133,17 @@ let begin_application let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - Alpha_context.prepare ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> Apply.begin_application - ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker) -> - let mode = Application { block_header ; baker = Signature.Public_key.hash baker } in + ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) -> + let mode = + Application { block_header ; baker = Signature.Public_key.hash baker ; block_delay } in return { mode ; chain_id ; ctxt ; op_count = 0 } let begin_construction ~chain_id ~predecessor_context:ctxt - ~predecessor_timestamp:pred_timestamp + ~predecessor_timestamp ~predecessor_level:pred_level ~predecessor_fitness:pred_fitness ~predecessor @@ -149,7 +152,7 @@ let begin_construction () = let level = Int32.succ pred_level in let fitness = pred_fitness in - Alpha_context.prepare ~timestamp ~level ~fitness ctxt >>=? fun ctxt -> + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> begin match protocol_data with | None -> @@ -158,11 +161,11 @@ let begin_construction return (mode, ctxt) | Some proto_header -> Apply.begin_full_construction - ctxt pred_timestamp - proto_header.contents >>=? fun (ctxt, protocol_data, baker) -> + ctxt predecessor_timestamp + proto_header.contents >>=? fun (ctxt, protocol_data, baker, block_delay) -> let mode = let baker = Signature.Public_key.hash baker in - Full_construction { predecessor ; baker ; protocol_data } in + Full_construction { predecessor ; baker ; protocol_data ; block_delay } in return (mode, ctxt) end >>=? fun (mode, ctxt) -> return { mode ; chain_id ; ctxt ; op_count = 0 } @@ -192,13 +195,7 @@ let apply_operation | Partial_construction { predecessor } -> predecessor, Signature.Public_key_hash.zero in - let partial = - match mode with - | Partial_construction _ -> true - | Application _ - | Full_construction _ - | Partial_application _ -> false in - Apply.apply_operation ~partial ctxt chain_id Optimized predecessor baker + Apply.apply_operation ctxt chain_id Optimized predecessor baker (Alpha_context.Operation.hash operation) operation >>=? fun (ctxt, result) -> let op_count = op_count + 1 in @@ -224,8 +221,12 @@ let finalize_block { mode ; ctxt ; op_count } = consumed_gas = Z.zero ; deactivated = []; balance_updates = []}) - | Partial_application { baker ; _ } -> - let level = Alpha_context. Level.current ctxt in + | Partial_application { block_header ; baker ; block_delay } -> + let level = Alpha_context.Level.current ctxt in + let included_endorsements = Alpha_context.included_endorsements ctxt in + Apply.check_minimum_endorsements ctxt + block_header.protocol_data.contents + block_delay included_endorsements >>=? fun () -> Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind -> let ctxt = Alpha_context.finalize ctxt in return (ctxt, Apply_results.{ baker ; @@ -236,16 +237,16 @@ let finalize_block { mode ; ctxt ; op_count } = deactivated = []; balance_updates = []}) | Application - { baker ; block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } } - | Full_construction { protocol_data ; baker ; _ } -> - Apply.finalize_application ctxt protocol_data baker >>=? fun (ctxt, receipt) -> + { baker ; block_delay ; block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } } + | Full_construction { protocol_data ; baker ; block_delay ; _ } -> + Apply.finalize_application ctxt protocol_data baker ~block_delay >>=? fun (ctxt, receipt) -> let level = Alpha_context.Level.current ctxt in let priority = protocol_data.priority in let raw_level = Alpha_context.Raw_level.to_int32 level.level in let fitness = Alpha_context.Fitness.current ctxt in let commit_message = Format.asprintf - "lvl %ld, fit %Ld, prio %d, %d ops" + "lvl %ld, fit 1:%Ld, prio %d, %d ops" raw_level fitness priority op_count in let ctxt = Alpha_context.finalize ~commit_message ctxt in return (ctxt, receipt) @@ -298,9 +299,14 @@ let init ctxt block_header = let fitness = block_header.fitness in let timestamp = block_header.timestamp in let typecheck (ctxt:Alpha_context.context) (script:Alpha_context.Script.t) = - Script_ir_translator.parse_script ctxt script >>=? fun (ex_script, ctxt) -> - Script_ir_translator.big_map_initialization ctxt Optimized ex_script >>=? fun (big_map_diff, ctxt) -> - return ((script, big_map_diff), ctxt) + Script_ir_translator.parse_script ctxt ~legacy:false script >>=? fun (Ex_script parsed_script, ctxt) -> + Script_ir_translator.extract_big_map_diff ctxt Optimized parsed_script.storage_type parsed_script.storage + ~to_duplicate: Script_ir_translator.no_big_map_id + ~to_update: Script_ir_translator.no_big_map_id + ~temporary:false >>=? fun (storage, big_map_diff, ctxt) -> + Script_ir_translator.unparse_data ctxt Optimized parsed_script.storage_type storage >>=? fun (storage, ctxt) -> + let storage = Alpha_context.Script.lazy_expr (Micheline.strip_locations storage) in + return (({ script with storage }, big_map_diff), ctxt) in Alpha_context.prepare_first_block ~typecheck diff --git a/src/proto_alpha/lib_protocol/main.mli b/src/proto_alpha/lib_protocol/main.mli index bde08a85e32b3e1713788267f39d93e416bf3fbf..c0d9f66c35c2469ed2bc631d6f40bd4d91a83730 100644 --- a/src/proto_alpha/lib_protocol/main.mli +++ b/src/proto_alpha/lib_protocol/main.mli @@ -29,10 +29,12 @@ type validation_mode = | Application of { block_header : Alpha_context.Block_header.t ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } | Partial_application of { block_header : Alpha_context.Block_header.t ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } | Partial_construction of { predecessor : Block_hash.t ; @@ -41,6 +43,7 @@ type validation_mode = predecessor : Block_hash.t ; protocol_data : Alpha_context.Block_header.contents ; baker : Alpha_context.public_key_hash ; + block_delay : Alpha_context.Period.t ; } type validation_state = diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index 0e7e4561799cb881fa7ea6c49721082a2ebb36e9..f61e519feafc9afc52b9377f1633bec773750984 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -27,48 +27,6 @@ open Alpha_context open Gas module Cost_of = struct - let cycle = step_cost 1 - let nop = free - - let stack_op = step_cost 1 - - let bool_binop _ _ = step_cost 1 - let bool_unop _ = step_cost 1 - - let pair = alloc_cost 2 - let pair_access = step_cost 1 - - let cons = alloc_cost 2 - - let variant_no_data = alloc_cost 1 - - let branch = step_cost 2 - - let string length = - alloc_bytes_cost length - - let bytes length = - alloc_mbytes_cost length - - let zint z = - alloc_bits_cost (Z.numbits z) - - let concat cost length ss = - let rec cum acc = function - | [] -> acc - | s :: ss -> cum (cost (length s) +@ acc) ss in - cum free ss - - let concat_string ss = concat string String.length ss - let concat_bytes ss = concat bytes MBytes.length ss - - let slice_string length = string length - let slice_bytes = alloc_cost 0 - - (* Cost per cycle of a loop, fold, etc *) - let loop_cycle = step_cost 2 - - let list_size = step_cost 1 let log2 = let rec help acc = function @@ -76,166 +34,257 @@ module Cost_of = struct | n -> help (acc + 1) (n / 2) in help 1 - let module_cost = alloc_cost 10 - - let map_access : type key value. (key, value) Script_typed_ir.map -> int - = fun (module Box) -> - log2 (snd Box.boxed) - - let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost - = fun (module Box) -> - let size = snd Box.boxed in - 3 *@ alloc_cost size - - let map_mem _key map = step_cost (map_access map) - - let map_get = map_mem - - let map_update _ _ map = - map_access map *@ alloc_cost 3 - - let map_size = step_cost 2 - - let big_map_mem _key _map = step_cost 50 - let big_map_get _key _map = step_cost 50 - let big_map_update _key _value _map = step_cost 10 + let z_bytes (z : Z.t) = + let bits = Z.numbits z in + (7 + bits) / 8 + + let int_bytes (z : 'a Script_int.num) = + z_bytes (Script_int.to_zint z) + + let timestamp_bytes (t : Script_timestamp.t) = + let z = Script_timestamp.to_zint t in + z_bytes z + + (* For now, returns size in bytes, but this could get more complicated... *) + let rec size_of_comparable : type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int = + fun wit v -> + match wit with + | Int_key _ -> int_bytes v + | Nat_key _ -> int_bytes v + | String_key _ -> String.length v + | Bytes_key _ -> MBytes.length v + | Bool_key _ -> 8 + | Key_hash_key _ -> Signature.Public_key_hash.size + | Timestamp_key _ -> timestamp_bytes v + | Address_key _ -> Signature.Public_key_hash.size + | Mutez_key _ -> 8 + | Pair_key ((l, _), (r, _), _) -> + let (lval, rval) = v in + size_of_comparable l lval + size_of_comparable r rval - let set_access : type elt. elt -> elt Script_typed_ir.set -> int - = fun _key (module Box) -> - log2 @@ Box.size - - let set_mem key set = step_cost (set_access key set) - - let set_update key _presence set = - set_access key set *@ alloc_cost 3 - - (* for LEFT, RIGHT, SOME *) - let wrap = alloc_cost 1 - - let mul n1 n2 = - let steps = - (Z.numbits (Script_int.to_zint n1)) - * (Z.numbits (Script_int.to_zint n2)) in - let bits = - (Z.numbits (Script_int.to_zint n1)) - + (Z.numbits (Script_int.to_zint n2)) in - step_cost steps +@ alloc_bits_cost bits - - let div n1 n2 = - mul n1 n2 +@ alloc_cost 2 - - let add_sub_z n1 n2 = - let bits = - Compare.Int.max (Z.numbits n1) (Z.numbits n2) in - step_cost bits +@ alloc_cost bits - - let add n1 n2 = - add_sub_z (Script_int.to_zint n1) (Script_int.to_zint n2) - - let sub = add - - let abs n = - alloc_bits_cost (Z.numbits @@ Script_int.to_zint n) - - let neg = abs - let int _ = step_cost 1 - - let add_timestamp t n = - add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n) - - let sub_timestamp t n = - add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n) - - let diff_timestamps t1 t2 = - add_sub_z (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2) - - let empty_set = module_cost - - let set_size = step_cost 2 - - let set_to_list : type item. item Script_typed_ir.set -> cost - = fun (module Box) -> - alloc_cost @@ Pervasives.(Box.size * 2) - - let empty_map = module_cost + let string length = + alloc_bytes_cost length - let int64_op = step_cost 1 +@ alloc_cost 1 + let bytes length = + alloc_mbytes_cost length - let z_to_int64 = step_cost 2 +@ alloc_cost 1 + let manager_operation = step_cost 10_000 - let int64_to_z = step_cost 2 +@ alloc_cost 1 + module Legacy = struct + let zint z = + alloc_bits_cost (Z.numbits z) - let bitwise_binop n1 n2 = - let bits = Compare.Int.max (Z.numbits (Script_int.to_zint n1)) (Z.numbits (Script_int.to_zint n2)) in - step_cost bits +@ alloc_bits_cost bits + let set_to_list : type item. item Script_typed_ir.set -> cost + = fun (module Box) -> + alloc_cost @@ Pervasives.(Box.size * 2) - let logor = bitwise_binop - let logand = bitwise_binop - let logxor = bitwise_binop - let lognot n = - let bits = Z.numbits @@ Script_int.to_zint n in - step_cost bits +@ alloc_cost bits + let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost + = fun (module Box) -> + let size = snd Box.boxed in + 3 *@ alloc_cost size - let unopt ~default = function - | None -> default - | Some x -> x + let z_to_int64 = step_cost 2 +@ alloc_cost 1 - let max_int = 1073741823 + let hash data len = 10 *@ step_cost (MBytes.length data) +@ bytes len - let shift_left x y = - alloc_bits_cost - (Z.numbits (Script_int.to_zint x) + - (unopt (Script_int.to_int y) ~default:max_int)) + let set_access : type elt. elt -> elt Script_typed_ir.set -> int + = fun _key (module Box) -> + log2 @@ Box.size - let shift_right x y = - alloc_bits_cost - (Compare.Int.max 1 - (Z.numbits (Script_int.to_zint x) - - unopt (Script_int.to_int y) ~default:max_int)) + let set_update key _presence set = + set_access key set *@ alloc_cost 3 + end - let exec = step_cost 1 - - let push = step_cost 1 - - let compare_res = step_cost 1 - - let unpack_failed bytes = - (* We cannot instrument failed deserialization, - so we take worst case fees: a set of size 1 bytes values. *) - let len = MBytes.length bytes in - (len *@ alloc_mbytes_cost 1) +@ - (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1))) - - let address = step_cost 1 - let contract = Gas.read_bytes_cost Z.zero +@ step_cost 10000 - let transfer = step_cost 10 - let create_account = step_cost 10 - let create_contract = step_cost 10 - let implicit_account = step_cost 10 - let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32) - let balance = step_cost 1 +@ read_bytes_cost (Z.of_int 8) - let now = step_cost 5 - let check_signature = step_cost 1000 - let hash_key = step_cost 3 +@ bytes 20 - let hash data len = 10 *@ step_cost (MBytes.length data) +@ bytes len - let steps_to_quota = step_cost 1 - let source = step_cost 1 - let self = step_cost 1 - let amount = step_cost 1 - let compare_bool _ _ = step_cost 1 - let compare_string s1 s2 = - step_cost ((7 + Compare.Int.max (String.length s1) (String.length s2)) / 8) +@ step_cost 1 - let compare_bytes s1 s2 = - step_cost ((7 + Compare.Int.max (MBytes.length s1) (MBytes.length s2)) / 8) +@ step_cost 1 - let compare_tez _ _ = step_cost 1 - let compare_zint n1 n2 = step_cost ((7 + Compare.Int.max (Z.numbits n1) (Z.numbits n2)) / 8) +@ step_cost 1 - let compare_int n1 n2 = compare_zint (Script_int.to_zint n1) (Script_int.to_zint n2) - let compare_nat = compare_int - let compare_key_hash _ _ = alloc_bytes_cost 36 - let compare_timestamp t1 t2 = compare_zint (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2) - let compare_address _ _ = step_cost 20 + module Interpreter = struct + let cycle = atomic_step_cost 10 + let nop = free + let stack_op = atomic_step_cost 10 + let push = atomic_step_cost 10 + let wrap = atomic_step_cost 10 + let variant_no_data = atomic_step_cost 10 + let branch = atomic_step_cost 10 + let pair = atomic_step_cost 10 + let pair_access = atomic_step_cost 10 + let cons = atomic_step_cost 10 + let loop_size = atomic_step_cost 5 + let loop_cycle = atomic_step_cost 10 + let loop_iter = atomic_step_cost 20 + let loop_map = atomic_step_cost 30 + let empty_set = atomic_step_cost 10 + let set_to_list : type elt. elt Script_typed_ir.set -> cost = + fun (module Box) -> + atomic_step_cost (Box.size * 20) + + let set_mem : type elt. elt -> elt Script_typed_ir.set -> cost = + fun elt (module Box) -> + let elt_bytes = size_of_comparable Box.elt_ty elt in + atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size) + + let set_update : type elt. elt -> bool -> elt Script_typed_ir.set -> cost = + fun elt _ (module Box) -> + let elt_bytes = size_of_comparable Box.elt_ty elt in + atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size) + + let set_size = atomic_step_cost 10 + let empty_map = atomic_step_cost 10 + let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost = + fun (module Box) -> + let size = snd Box.boxed in + atomic_step_cost (size * 20) + + let map_access : type key value. key -> (key, value) Script_typed_ir.map -> cost + = fun key (module Box) -> + let map_card = snd Box.boxed in + let key_bytes = size_of_comparable Box.key_ty key in + atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card) + + let map_mem = map_access + let map_get = map_access + + let map_update : type key value. key -> value option -> (key, value) Script_typed_ir.map -> cost + = fun key _value (module Box) -> + let map_card = snd Box.boxed in + let key_bytes = size_of_comparable Box.key_ty key in + atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card) + + let map_size = atomic_step_cost 10 + + let add_timestamp (t1 : Script_timestamp.t) (t2 : 'a Script_int.num) = + let bytes1 = timestamp_bytes t1 in + let bytes2 = int_bytes t2 in + atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62)) + let sub_timestamp = add_timestamp + let diff_timestamps (t1 : Script_timestamp.t) (t2 : Script_timestamp.t) = + let bytes1 = timestamp_bytes t1 in + let bytes2 = timestamp_bytes t2 in + atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62)) + + let rec concat_loop l acc = + match l with + | [] -> 30 + | _ :: tl -> concat_loop tl (acc + 30) + + let concat_string string_list = + atomic_step_cost (concat_loop string_list 0) + + let slice_string string_length = + atomic_step_cost (40 + (string_length / 70)) + + let concat_bytes bytes_list = + atomic_step_cost (concat_loop bytes_list 0) + + let int64_op = atomic_step_cost 61 + let z_to_int64 = atomic_step_cost 20 + let int64_to_z = atomic_step_cost 20 + let bool_binop _ _ = atomic_step_cost 10 + let bool_unop _ = atomic_step_cost 10 + + let abs int = atomic_step_cost (61 + ((int_bytes int) / 70)) + let int _int = free + let neg = abs + let add i1 i2 = atomic_step_cost (51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62)) + let sub = add + + let mul i1 i2 = + let bytes = Compare.Int.max (int_bytes i1) (int_bytes i2) in + atomic_step_cost (51 + (bytes / 6 * log2 bytes)) + + let indic_lt x y = if Compare.Int.(x < y) then 1 else 0 + + let div i1 i2 = + let bytes1 = int_bytes i1 in + let bytes2 = int_bytes i2 in + let cost = indic_lt bytes2 bytes1 * (bytes1 - bytes2) * bytes2 in + atomic_step_cost (51 + (cost / 3151)) + + let shift_left _i _shift_bits = atomic_step_cost 30 + let shift_right _i _shift_bits = atomic_step_cost 30 + let logor i1 i2 = + let bytes1 = int_bytes i1 in + let bytes2 = int_bytes i2 in + atomic_step_cost (51 + ((Compare.Int.max bytes1 bytes2) / 70)) + let logand i1 i2 = + let bytes1 = int_bytes i1 in + let bytes2 = int_bytes i2 in + atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 70)) + let logxor = logor + let lognot i = atomic_step_cost (51 + ((int_bytes i) / 20)) + let exec = atomic_step_cost 10 + let compare_bool _ _ = atomic_step_cost 30 + + let compare_string s1 s2 = + let bytes1 = String.length s1 in + let bytes2 = String.length s2 in + atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123)) + let compare_bytes b1 b2 = + let bytes1 = MBytes.length b1 in + let bytes2 = MBytes.length b2 in + atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123)) + let compare_tez _ _ = atomic_step_cost 30 + let compare_zint i1 i2 = + atomic_step_cost (51 + ((Compare.Int.min (int_bytes i1) (int_bytes i2)) / 82)) + let compare_key_hash _ _ = atomic_step_cost 92 + + let compare_timestamp t1 t2 = + let bytes1 = timestamp_bytes t1 in + let bytes2 = timestamp_bytes t2 in + atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 82)) + + let compare_address _ _ = atomic_step_cost 92 + let compare_res = atomic_step_cost 30 + let unpack_failed bytes = + (* We cannot instrument failed deserialization, + so we take worst case fees: a set of size 1 bytes values. *) + let len = MBytes.length bytes in + (len *@ alloc_mbytes_cost 1) +@ + (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1))) + let address = atomic_step_cost 10 + let contract = step_cost 10000 + let transfer = step_cost 10 + let create_account = step_cost 10 + let create_contract = step_cost 10 + let implicit_account = step_cost 10 + let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32) + let balance = atomic_step_cost 10 + let now = atomic_step_cost 10 + let check_signature_secp256k1 bytes = atomic_step_cost (10342 + (bytes / 5)) + let check_signature_ed25519 bytes = atomic_step_cost (36864 + (bytes / 5)) + let check_signature_p256 bytes = atomic_step_cost (36864 + (bytes / 5)) + let check_signature (pkey : Signature.public_key) bytes = + match pkey with + | Ed25519 _ -> check_signature_ed25519 (MBytes.length bytes) + | Secp256k1 _ -> check_signature_secp256k1 (MBytes.length bytes) + | P256 _ -> check_signature_p256 (MBytes.length bytes) + let hash_key = atomic_step_cost 30 + let hash_blake2b b = atomic_step_cost (102 + ((MBytes.length b) / 5)) + let hash_sha256 b = atomic_step_cost (409 + (MBytes.length b)) + let hash_sha512 b = + let bytes = MBytes.length b in atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4))) + let steps_to_quota = atomic_step_cost 10 + let source = atomic_step_cost 10 + let self = atomic_step_cost 10 + let amount = atomic_step_cost 10 + let chain_id = step_cost 1 + let stack_n_op n = atomic_step_cost (20 + (((n lsr 1) + (n lsr 2)) + (n lsr 4))) + let apply = alloc_cost 8 +@ step_cost 1 + + let rec compare : type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost = fun ty x y -> + match ty with + | Bool_key _ -> compare_bool x y + | String_key _ -> compare_string x y + | Bytes_key _ -> compare_bytes x y + | Mutez_key _ -> compare_tez x y + | Int_key _ -> compare_zint x y + | Nat_key _ -> compare_zint x y + | Key_hash_key _ -> compare_key_hash x y + | Timestamp_key _ -> compare_timestamp x y + | Address_key _ -> compare_address x y + | Pair_key ((tl, _), (tr, _), _) -> + (* Reasonable over-approximation of the cost of lexicographic comparison. *) + let (xl, xr) = x and (yl, yr) = y in + compare tl xl yl +@ compare tr xr yr - let manager_operation = step_cost 10_000 + end module Typechecking = struct let cycle = step_cost 1 @@ -243,7 +292,7 @@ module Cost_of = struct let unit = free let string = string let bytes = bytes - let z = zint + let z = Legacy.zint let int_of_string str = alloc_cost @@ (Pervasives.(/) (String.length str) 5) let tez = step_cost 1 +@ alloc_cost 1 @@ -251,6 +300,7 @@ module Cost_of = struct let key = step_cost 3 +@ alloc_cost 3 let key_hash = step_cost 1 +@ alloc_cost 1 let signature = step_cost 1 +@ alloc_cost 1 + let chain_id = step_cost 1 +@ alloc_cost 1 let contract = step_cost 5 let get_script = step_cost 20 +@ alloc_cost 5 let contract_exists = step_cost 15 +@ alloc_cost 5 @@ -308,6 +358,7 @@ module Cost_of = struct | Map_get -> alloc_cost 1 | Map_update -> alloc_cost 1 | Map_size -> alloc_cost 1 + | Empty_big_map _ -> alloc_cost 2 | Big_map_mem -> alloc_cost 1 | Big_map_get -> alloc_cost 1 | Big_map_update -> alloc_cost 1 @@ -365,6 +416,7 @@ module Cost_of = struct | Loop_left _ -> alloc_cost 5 | Dip _ -> alloc_cost 4 | Exec -> alloc_cost 1 + | Apply _ -> alloc_cost 1 | Lambda _ -> alloc_cost 2 | Failwith _ -> alloc_cost 1 | Nop -> alloc_cost 0 @@ -381,6 +433,12 @@ module Cost_of = struct | Create_account -> alloc_cost 2 | Implicit_account -> alloc_cost 1 | Create_contract _ -> alloc_cost 8 + (* Deducted the cost of removed arguments manager, spendable and delegatable: + - manager: key_hash = 1 + - spendable: bool = 0 + - delegatable: bool = 0 + *) + | Create_contract_2 _ -> alloc_cost 7 | Set_delegate -> alloc_cost 1 | Now -> alloc_cost 1 | Balance -> alloc_cost 1 @@ -396,6 +454,11 @@ module Cost_of = struct | Sender -> alloc_cost 1 | Self _ -> alloc_cost 2 | Amount -> alloc_cost 1 + | Dig (n,_) -> n *@ alloc_cost 1 (* _ is a unary development of n *) + | Dug (n,_) -> n *@ alloc_cost 1 + | Dipn (n,_,_) -> n *@ alloc_cost 1 + | Dropn (n,_) -> n *@ alloc_cost 1 + | ChainId -> alloc_cost 1 end module Unparse = struct @@ -415,6 +478,7 @@ module Cost_of = struct let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *) let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int let operation bytes = Script.bytes_node_cost bytes + let chain_id bytes = Script.bytes_node_cost bytes let key = string_cost 54 let key_hash = string_cost 36 let signature = string_cost 128 @@ -429,8 +493,8 @@ module Cost_of = struct let one_arg_type = prim_cost 1 let two_arg_type = prim_cost 2 - let set_to_list = set_to_list - let map_to_list = map_to_list + let set_to_list = Legacy.set_to_list + let map_to_list = Legacy.map_to_list end end diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli index cfb121cf91fc00e5ee0d616a5c0947e5c2bf8b52..c950a7496e3df9e92b5bd0bbf5cec7596d8f29cc 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli @@ -26,93 +26,94 @@ open Alpha_context module Cost_of : sig - val cycle : Gas.cost - val loop_cycle : Gas.cost - val list_size : Gas.cost - val nop : Gas.cost - val stack_op : Gas.cost - val bool_binop : 'a -> 'b -> Gas.cost - val bool_unop : 'a -> Gas.cost - val pair : Gas.cost - val pair_access : Gas.cost - val cons : Gas.cost - val variant_no_data : Gas.cost - val branch : Gas.cost - val concat_string : string list -> Gas.cost - val concat_bytes : MBytes.t list -> Gas.cost - val slice_string : int -> Gas.cost - val slice_bytes : Gas.cost - val map_mem : - 'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost - val map_to_list : - ('b, 'c) Script_typed_ir.map -> Gas.cost - val map_get : - 'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost - val map_update : - 'a -> 'b -> ('c, 'd) Script_typed_ir.map -> Gas.cost - val map_size : Gas.cost - val big_map_mem : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost - val big_map_get : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost - val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost - val set_to_list : 'a Script_typed_ir.set -> Gas.cost - val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost - val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost - val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val abs : 'a Script_int.num -> Gas.cost - val neg : 'a Script_int.num -> Gas.cost - val int : 'a -> Gas.cost - val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost - val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost - val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost - val empty_set : Gas.cost - val set_size : Gas.cost - val empty_map : Gas.cost - val int64_op : Gas.cost - val z_to_int64 : Gas.cost - val int64_to_z : Gas.cost - val bitwise_binop : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val lognot : 'a Script_int.num -> Gas.cost - val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val exec : Gas.cost - val push : Gas.cost - val compare_res : Gas.cost - val unpack_failed : MBytes.t -> Gas.cost - val address : Gas.cost - val contract : Gas.cost - val transfer : Gas.cost - val create_account : Gas.cost - val create_contract : Gas.cost - val implicit_account : Gas.cost - val set_delegate : Gas.cost - val balance : Gas.cost - val now : Gas.cost - val check_signature : Gas.cost - val hash_key : Gas.cost - val hash : MBytes.t -> int -> Gas.cost - val steps_to_quota : Gas.cost - val source : Gas.cost - val self : Gas.cost - val amount : Gas.cost - val wrap : Gas.cost - val compare_bool : 'a -> 'b -> Gas.cost - val compare_string : string -> string -> Gas.cost - val compare_bytes : MBytes.t -> MBytes.t -> Gas.cost - val compare_tez : 'a -> 'b -> Gas.cost - val compare_int : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val compare_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost - val compare_key_hash : 'a -> 'b -> Gas.cost - val compare_timestamp : Script_timestamp.t -> Script_timestamp.t -> Gas.cost - val compare_address : Contract.t -> Contract.t -> Gas.cost val manager_operation : Gas.cost + module Legacy : sig + val z_to_int64 : Gas.cost + val hash : MBytes.t -> int -> Gas.cost + val map_to_list : + ('b, 'c) Script_typed_ir.map -> Gas.cost + val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost + end + + module Interpreter : sig + val cycle : Gas.cost + val loop_cycle : Gas.cost + val loop_size : Gas.cost + val loop_iter : Gas.cost + val loop_map : Gas.cost + val nop : Gas.cost + val stack_op : Gas.cost + val stack_n_op : int -> Gas.cost + val bool_binop : 'a -> 'b -> Gas.cost + val bool_unop : 'a -> Gas.cost + val pair : Gas.cost + val pair_access : Gas.cost + val cons : Gas.cost + val variant_no_data : Gas.cost + val branch : Gas.cost + val concat_string : string list -> Gas.cost + val concat_bytes : MBytes.t list -> Gas.cost + val slice_string : int -> Gas.cost + val map_mem : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_get : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_update : 'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_size : Gas.cost + val set_to_list : 'a Script_typed_ir.set -> Gas.cost + val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost + val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost + val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val abs : 'a Script_int.num -> Gas.cost + val neg : 'a Script_int.num -> Gas.cost + val int : 'a -> Gas.cost + val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost + val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost + val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost + val empty_set : Gas.cost + val set_size : Gas.cost + val empty_map : Gas.cost + val int64_op : Gas.cost + val z_to_int64 : Gas.cost + val int64_to_z : Gas.cost + val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val lognot : 'a Script_int.num -> Gas.cost + val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val exec : Gas.cost + val push : Gas.cost + val compare_res : Gas.cost + val unpack_failed : MBytes.t -> Gas.cost + val address : Gas.cost + val contract : Gas.cost + val transfer : Gas.cost + val create_account : Gas.cost + val create_contract : Gas.cost + val implicit_account : Gas.cost + val set_delegate : Gas.cost + val balance : Gas.cost + val now : Gas.cost + val check_signature : public_key -> MBytes.t -> Gas.cost + val hash_key : Gas.cost + val hash_blake2b : MBytes.t -> Gas.cost + val hash_sha256 : MBytes.t -> Gas.cost + val hash_sha512 : MBytes.t -> Gas.cost + val steps_to_quota : Gas.cost + val source : Gas.cost + val self : Gas.cost + val amount : Gas.cost + val chain_id : Gas.cost + val wrap : Gas.cost + val compare : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> Gas.cost + val apply : Gas.cost + end + module Typechecking : sig val cycle : Gas.cost val unit : Gas.cost @@ -126,6 +127,7 @@ module Cost_of : sig val key : Gas.cost val key_hash : Gas.cost val signature : Gas.cost + val chain_id : Gas.cost val contract : Gas.cost @@ -177,6 +179,7 @@ module Cost_of : sig val key_hash : Gas.cost val signature : Gas.cost val operation : MBytes.t -> Gas.cost + val chain_id : MBytes.t -> Gas.cost val contract : Gas.cost diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index d80f5f7eb0d6dafcadb92296e50819421efd609e..6c6a1025b0b6558b173750286923ae56d4192ce8 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -54,6 +54,7 @@ type prim = | I_BALANCE | I_CAR | I_CDR + | I_CHAIN_ID | I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT @@ -65,10 +66,12 @@ type prim = | I_DROP | I_DUP | I_EDIV + | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC + | I_APPLY | I_FAILWITH | I_GE | I_GET @@ -120,6 +123,8 @@ type prim = | I_ISNAT | I_CAST | I_RENAME + | I_DIG + | I_DUG | T_bool | T_contract | T_int @@ -142,6 +147,7 @@ type prim = | T_unit | T_operation | T_address + | T_chain_id let valid_case name = let is_lower = function '_' | 'a'..'z' -> true | _ -> false in @@ -187,6 +193,7 @@ let string_of_prim = function | I_BALANCE -> "BALANCE" | I_CAR -> "CAR" | I_CDR -> "CDR" + | I_CHAIN_ID -> "CHAIN_ID" | I_CHECK_SIGNATURE -> "CHECK_SIGNATURE" | I_COMPARE -> "COMPARE" | I_CONCAT -> "CONCAT" @@ -198,10 +205,12 @@ let string_of_prim = function | I_DROP -> "DROP" | I_DUP -> "DUP" | I_EDIV -> "EDIV" + | I_EMPTY_BIG_MAP -> "EMPTY_BIG_MAP" | I_EMPTY_MAP -> "EMPTY_MAP" | I_EMPTY_SET -> "EMPTY_SET" | I_EQ -> "EQ" | I_EXEC -> "EXEC" + | I_APPLY -> "APPLY" | I_FAILWITH -> "FAILWITH" | I_GE -> "GE" | I_GET -> "GET" @@ -253,6 +262,8 @@ let string_of_prim = function | I_ISNAT -> "ISNAT" | I_CAST -> "CAST" | I_RENAME -> "RENAME" + | I_DIG -> "DIG" + | I_DUG -> "DUG" | T_bool -> "bool" | T_contract -> "contract" | T_int -> "int" @@ -275,6 +286,7 @@ let string_of_prim = function | T_unit -> "unit" | T_operation -> "operation" | T_address -> "address" + | T_chain_id -> "chain_id" let prim_of_string = function | "parameter" -> ok K_parameter @@ -301,6 +313,7 @@ let prim_of_string = function | "BALANCE" -> ok I_BALANCE | "CAR" -> ok I_CAR | "CDR" -> ok I_CDR + | "CHAIN_ID" -> ok I_CHAIN_ID | "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE | "COMPARE" -> ok I_COMPARE | "CONCAT" -> ok I_CONCAT @@ -312,10 +325,12 @@ let prim_of_string = function | "DROP" -> ok I_DROP | "DUP" -> ok I_DUP | "EDIV" -> ok I_EDIV + | "EMPTY_BIG_MAP" -> ok I_EMPTY_BIG_MAP | "EMPTY_MAP" -> ok I_EMPTY_MAP | "EMPTY_SET" -> ok I_EMPTY_SET | "EQ" -> ok I_EQ | "EXEC" -> ok I_EXEC + | "APPLY" -> ok I_APPLY | "FAILWITH" -> ok I_FAILWITH | "GE" -> ok I_GE | "GET" -> ok I_GET @@ -367,6 +382,8 @@ let prim_of_string = function | "ISNAT" -> ok I_ISNAT | "CAST" -> ok I_CAST | "RENAME" -> ok I_RENAME + | "DIG" -> ok I_DIG + | "DUG" -> ok I_DUG | "bool" -> ok T_bool | "contract" -> ok T_contract | "int" -> ok T_int @@ -389,6 +406,7 @@ let prim_of_string = function | "unit" -> ok T_unit | "operation" -> ok T_operation | "address" -> ok T_address + | "chain_id" -> ok T_chain_id | n -> if valid_case n then error (Unknown_primitive_name n) @@ -436,6 +454,7 @@ let prim_encoding = let open Data_encoding in def "michelson.v1.primitives" @@ string_enum [ + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("parameter", K_parameter) ; ("storage", K_storage) ; ("code", K_code) ; @@ -446,6 +465,7 @@ let prim_encoding = ("Pair", D_Pair) ; ("Right", D_Right) ; ("Some", D_Some) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("True", D_True) ; ("Unit", D_Unit) ; ("PACK", I_PACK) ; @@ -456,6 +476,7 @@ let prim_encoding = ("ABS", I_ABS) ; ("ADD", I_ADD) ; ("AMOUNT", I_AMOUNT) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("AND", I_AND) ; ("BALANCE", I_BALANCE) ; ("CAR", I_CAR) ; @@ -466,6 +487,7 @@ let prim_encoding = ("CONS", I_CONS) ; ("CREATE_ACCOUNT", I_CREATE_ACCOUNT) ; ("CREATE_CONTRACT", I_CREATE_CONTRACT) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) ; ("DIP", I_DIP) ; ("DROP", I_DROP) ; @@ -476,6 +498,7 @@ let prim_encoding = ("EQ", I_EQ) ; ("EXEC", I_EXEC) ; ("FAILWITH", I_FAILWITH) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("GE", I_GE) ; ("GET", I_GET) ; ("GT", I_GT) ; @@ -486,6 +509,7 @@ let prim_encoding = ("IF_NONE", I_IF_NONE) ; ("INT", I_INT) ; ("LAMBDA", I_LAMBDA) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("LE", I_LE) ; ("LEFT", I_LEFT) ; ("LOOP", I_LOOP) ; @@ -496,6 +520,7 @@ let prim_encoding = ("MEM", I_MEM) ; ("MUL", I_MUL) ; ("NEG", I_NEG) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("NEQ", I_NEQ) ; ("NIL", I_NIL) ; ("NONE", I_NONE) ; @@ -506,6 +531,7 @@ let prim_encoding = ("PUSH", I_PUSH) ; ("RIGHT", I_RIGHT) ; ("SIZE", I_SIZE) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("SOME", I_SOME) ; ("SOURCE", I_SOURCE) ; ("SENDER", I_SENDER) ; @@ -516,6 +542,7 @@ let prim_encoding = ("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ; ("SET_DELEGATE", I_SET_DELEGATE) ; ("UNIT", I_UNIT) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("UPDATE", I_UPDATE) ; ("XOR", I_XOR) ; ("ITER", I_ITER) ; @@ -526,6 +553,7 @@ let prim_encoding = ("CAST", I_CAST) ; ("RENAME", I_RENAME) ; ("bool", T_bool) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("contract", T_contract) ; ("int", T_int) ; ("key", T_key) ; @@ -536,6 +564,7 @@ let prim_encoding = ("big_map", T_big_map) ; ("nat", T_nat) ; ("option", T_option) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("or", T_or) ; ("pair", T_pair) ; ("set", T_set) ; @@ -546,9 +575,18 @@ let prim_encoding = ("timestamp", T_timestamp) ; ("unit", T_unit) ; ("operation", T_operation) ; + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) ("address", T_address) ; (* Alpha_002 addition *) ("SLICE", I_SLICE) ; + (* Alpha_005 addition *) + ("DIG", I_DIG) ; + ("DUG", I_DUG) ; + ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP) ; + ("APPLY", I_APPLY) ; + ("chain_id", T_chain_id) ; + ("CHAIN_ID", I_CHAIN_ID) + (* New instructions must be added here, for backward compatibility of the encoding. *) ] let () = diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli index c51e8b443114cec52706eb70467b4b6ae975fb8d..6a0852bf4615d564801335b132eba917545791d7 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli @@ -52,6 +52,7 @@ type prim = | I_BALANCE | I_CAR | I_CDR + | I_CHAIN_ID | I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT @@ -63,10 +64,12 @@ type prim = | I_DROP | I_DUP | I_EDIV + | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC + | I_APPLY | I_FAILWITH | I_GE | I_GET @@ -118,6 +121,8 @@ type prim = | I_ISNAT | I_CAST | I_RENAME + | I_DIG + | I_DUG | T_bool | T_contract | T_int @@ -140,6 +145,7 @@ type prim = | T_unit | T_operation | T_address + | T_chain_id val prim_encoding : prim Data_encoding.encoding diff --git a/src/proto_alpha/lib_protocol/misc.mli b/src/proto_alpha/lib_protocol/misc.mli index 6e359e0b4b17f890bc6e0341531ddf39243cb250..407d7480b429e657003b038558dd02f6c79cc001 100644 --- a/src/proto_alpha/lib_protocol/misc.mli +++ b/src/proto_alpha/lib_protocol/misc.mli @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(** {2 Stuff} ****************************************************************) +(** {2 Helper functions} *) type 'a lazyt = unit -> 'a type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt) diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 17a62d71c1c6e4cba33ed68af7bfa78f4b0c5c9e..f07ef5c55530a025b67859e555815189100a6573 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -98,7 +98,7 @@ and _ contents = ballot: Vote_repr.ballot ; } -> Kind.ballot contents | Manager_operation : { - source: Contract_repr.contract ; + source: Signature.public_key_hash ; fee: Tez_repr.tez ; counter: counter ; operation: 'kind manager_operation ; @@ -110,15 +110,13 @@ and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : { amount: Tez_repr.tez ; - parameters: Script_repr.lazy_expr option ; + parameters: Script_repr.lazy_expr ; + entrypoint: string ; destination: Contract_repr.contract ; } -> Kind.transaction manager_operation | Origination : { - manager: Signature.Public_key_hash.t ; delegate: Signature.Public_key_hash.t option ; - script: Script_repr.t option ; - spendable: bool ; - delegatable: bool ; + script: Script_repr.t ; credit: Tez_repr.tez ; preorigination: Contract_repr.t option ; } -> Kind.origination manager_operation @@ -225,6 +223,22 @@ module Encoding = struct (fun pkh -> Reveal pkh) } + let entrypoint_encoding = + def + ~title:"entrypoint" + ~description:"Named entrypoint to a Michelson smart contract" + "entrypoint" @@ + let builtin_case tag name = + Data_encoding.case (Tag tag) ~title:name + (constant name) + (fun n -> if Compare.String.(n = name) then Some () else None) (fun () -> name) in + union [ builtin_case 0 "default" ; + builtin_case 1 "root" ; + builtin_case 2 "do" ; + builtin_case 3 "set_delegate" ; + builtin_case 4 "remove_delegate" ; + Data_encoding.case (Tag 255) ~title:"named" (Bounded.string 31) (fun s -> Some s) (fun s -> s) ] + let transaction_case = MCase { tag = 1 ; @@ -233,18 +247,29 @@ module Encoding = struct (obj3 (req "amount" Tez_repr.encoding) (req "destination" Contract_repr.encoding) - (opt "parameters" Script_repr.lazy_expr_encoding)) ; + (opt "parameters" + (obj2 + (req "entrypoint" entrypoint_encoding) + (req "value" Script_repr.lazy_expr_encoding)))) ; select = (function | Manager (Transaction _ as op) -> Some op | _ -> None) ; proj = (function - | Transaction { amount ; destination ; parameters } -> + | Transaction { amount ; destination ; parameters ; entrypoint } -> + let parameters = + if Script_repr.is_unit_parameter parameters && Compare.String.(entrypoint = "default") then + None + else + Some (entrypoint, parameters) in (amount, destination, parameters)) ; inj = (fun (amount, destination, parameters) -> - Transaction { amount ; destination ; parameters }) + let entrypoint, parameters = match parameters with + | None -> "default", Script_repr.unit_parameter + | Some (entrypoint, value) -> entrypoint, value in + Transaction { amount ; destination ; parameters ; entrypoint }) } let origination_case = @@ -252,32 +277,26 @@ module Encoding = struct tag = 2 ; name = "origination" ; encoding = - (obj6 - (req "manager_pubkey" Signature.Public_key_hash.encoding) + (obj3 (req "balance" Tez_repr.encoding) - (dft "spendable" bool true) - (dft "delegatable" bool true) (opt "delegate" Signature.Public_key_hash.encoding) - (opt "script" Script_repr.encoding)) ; + (req "script" Script_repr.encoding)) ; select = (function | Manager (Origination _ as op) -> Some op | _ -> None) ; proj = (function - | Origination { manager ; credit ; spendable ; - delegatable ; delegate ; script ; + | Origination { credit ; delegate ; script ; preorigination = _ (* the hash is only used internally when originating from smart contracts, don't serialize it *) } -> - (manager, credit, spendable, - delegatable, delegate, script)) ; + (credit, delegate, script)) ; inj = - (fun (manager, credit, spendable, delegatable, delegate, script) -> + (fun (credit, delegate, script) -> Origination - {manager ; credit ; spendable ; delegatable ; - delegate ; script ; preorigination = None }) + {credit ; delegate ; script ; preorigination = None }) } let delegation_case = @@ -482,7 +501,7 @@ module Encoding = struct let manager_encoding = (obj5 - (req "source" Contract_repr.encoding) + (req "source" Signature.Public_key_hash.encoding) (req "fee" Tez_repr.encoding) (req "counter" (check_size 10 n)) (req "gas_limit" (check_size 10 n)) @@ -526,10 +545,10 @@ module Encoding = struct (rebuild op (mcase.inj contents))) } - let reveal_case = make_manager_case 7 Manager_operations.reveal_case - let transaction_case = make_manager_case 8 Manager_operations.transaction_case - let origination_case = make_manager_case 9 Manager_operations.origination_case - let delegation_case = make_manager_case 10 Manager_operations.delegation_case + let reveal_case = make_manager_case 107 Manager_operations.reveal_case + let transaction_case = make_manager_case 108 Manager_operations.transaction_case + let origination_case = make_manager_case 109 Manager_operations.origination_case + let delegation_case = make_manager_case 110 Manager_operations.delegation_case let contents_encoding = let make (Case { tag ; name ; encoding ; select ; proj ; inj }) = @@ -668,12 +687,12 @@ let check_signature_sync (type kind) key chain_id ({ shell ; protocol_data } : k if Signature.check ~watermark key signature unsigned_operation then Ok () else - Error [Invalid_signature] in + error Invalid_signature in match protocol_data.contents, protocol_data.signature with | Single _, None -> - Error [Missing_signature] + error Missing_signature | Cons _, None -> - Error [Missing_signature] + error Missing_signature | Single (Endorsement _) as contents, Some signature -> check ~watermark:(Endorsement chain_id) (Contents_list contents) signature | Single _ as contents, Some signature -> diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index fe1dcb7547ba00d1188c17f65832ae0f1908fdd4..dd46b15c909e60b1a556e833a030e1fd7e1c5983 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -99,7 +99,7 @@ and _ contents = ballot: Vote_repr.ballot ; } -> Kind.ballot contents | Manager_operation : { - source: Contract_repr.contract ; + source: Signature.Public_key_hash.t ; fee: Tez_repr.tez ; counter: counter ; operation: 'kind manager_operation ; @@ -111,15 +111,13 @@ and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : { amount: Tez_repr.tez ; - parameters: Script_repr.lazy_expr option ; + parameters: Script_repr.lazy_expr ; + entrypoint: string ; destination: Contract_repr.contract ; } -> Kind.transaction manager_operation | Origination : { - manager: Signature.Public_key_hash.t ; delegate: Signature.Public_key_hash.t option ; - script: Script_repr.t option ; - spendable: bool ; - delegatable: bool ; + script: Script_repr.t ; credit: Tez_repr.tez ; preorigination: Contract_repr.t option ; } -> Kind.origination manager_operation diff --git a/src/proto_alpha/lib_protocol/parameters_repr.ml b/src/proto_alpha/lib_protocol/parameters_repr.ml index b8c7b150d21d35bf62ba84403e705d1b342d975b..bbf9c18fb35963e240516c4684ce8e03b55e9d22 100644 --- a/src/proto_alpha/lib_protocol/parameters_repr.ml +++ b/src/proto_alpha/lib_protocol/parameters_repr.ml @@ -85,103 +85,163 @@ let bootstrap_contract_encoding = (req "amount" Tez_repr.encoding) (req "script" Script_repr.encoding)) -(* This encoding is used to read configuration files (e.g. sandbox.json) - where some fields can be missing, in that case they are replaced by - the default. *) -let constants_encoding = +let encoding = let open Data_encoding in conv - (fun (c : Constants_repr.parametric) -> - let module Compare_time_between_blocks = Compare.List (Period_repr) in - let module Compare_keys = Compare.List (Ed25519.Public_key) in - let opt (=) def v = if def = v then None else Some v in - let default = Constants_repr.default in - let preserved_cycles = - opt Compare.Int.(=) - default.preserved_cycles c.preserved_cycles - and blocks_per_cycle = - opt Compare.Int32.(=) - default.blocks_per_cycle c.blocks_per_cycle - and blocks_per_commitment = - opt Compare.Int32.(=) - default.blocks_per_commitment c.blocks_per_commitment - and blocks_per_roll_snapshot = - opt Compare.Int32.(=) - default.blocks_per_roll_snapshot c.blocks_per_roll_snapshot - and blocks_per_voting_period = - opt Compare.Int32.(=) - default.blocks_per_voting_period c.blocks_per_voting_period - and time_between_blocks = - opt Compare_time_between_blocks.(=) - default.time_between_blocks c.time_between_blocks - and endorsers_per_block = - opt Compare.Int.(=) - default.endorsers_per_block c.endorsers_per_block - and hard_gas_limit_per_operation = - opt Compare.Z.(=) - default.hard_gas_limit_per_operation c.hard_gas_limit_per_operation - and hard_gas_limit_per_block = - opt Compare.Z.(=) - default.hard_gas_limit_per_block c.hard_gas_limit_per_block - and proof_of_work_threshold = - opt Compare.Int64.(=) - default.proof_of_work_threshold c.proof_of_work_threshold - and tokens_per_roll = - opt Tez_repr.(=) - default.tokens_per_roll c.tokens_per_roll - and michelson_maximum_type_size = - opt Compare.Int.(=) - default.michelson_maximum_type_size c.michelson_maximum_type_size - and seed_nonce_revelation_tip = - opt Tez_repr.(=) - default.seed_nonce_revelation_tip c.seed_nonce_revelation_tip - and origination_size = - opt Compare.Int.(=) - default.origination_size c.origination_size - and block_security_deposit = - opt Tez_repr.(=) - default.block_security_deposit c.block_security_deposit - and endorsement_security_deposit = - opt Tez_repr.(=) - default.endorsement_security_deposit c.endorsement_security_deposit - and block_reward = - opt Tez_repr.(=) - default.block_reward c.block_reward - and endorsement_reward = - opt Tez_repr.(=) - default.endorsement_reward c.endorsement_reward - and cost_per_byte = - opt Tez_repr.(=) - default.cost_per_byte c.cost_per_byte - and hard_storage_limit_per_operation = - opt Compare.Z.(=) - default.hard_storage_limit_per_operation c.hard_storage_limit_per_operation - and test_chain_duration = - opt Compare.Int64.(=) - default.test_chain_duration c.test_chain_duration - in - (( preserved_cycles, - blocks_per_cycle, - blocks_per_commitment, - blocks_per_roll_snapshot, - blocks_per_voting_period, - time_between_blocks, - endorsers_per_block, - hard_gas_limit_per_operation, - hard_gas_limit_per_block), - ((proof_of_work_threshold, - tokens_per_roll, - michelson_maximum_type_size, - seed_nonce_revelation_tip, - origination_size, - block_security_deposit, - endorsement_security_deposit, - block_reward), - (endorsement_reward, - cost_per_byte, - hard_storage_limit_per_operation, - test_chain_duration)))) - (fun (( preserved_cycles, + (fun { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ; + security_deposit_ramp_up_cycles ; no_reward_cycles } -> + ((bootstrap_accounts, bootstrap_contracts, commitments, + security_deposit_ramp_up_cycles, no_reward_cycles), + constants)) + (fun ( (bootstrap_accounts, bootstrap_contracts, commitments, + security_deposit_ramp_up_cycles, no_reward_cycles), + constants) -> + { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ; + security_deposit_ramp_up_cycles ; no_reward_cycles }) + (merge_objs + (obj5 + (req "bootstrap_accounts" (list bootstrap_account_encoding)) + (dft "bootstrap_contracts" (list bootstrap_contract_encoding) []) + (dft "commitments" (list Commitment_repr.encoding) []) + (opt "security_deposit_ramp_up_cycles" int31) + (opt "no_reward_cycles" int31)) + Constants_repr.parametric_encoding) + + +(* Only for migration from 004 to 005 *) + +module Proto_004 = struct + + type parametric = { + preserved_cycles: int ; + blocks_per_cycle: int32 ; + blocks_per_commitment: int32 ; + blocks_per_roll_snapshot: int32 ; + blocks_per_voting_period: int32 ; + time_between_blocks: Period_repr.t list ; + endorsers_per_block: int ; + hard_gas_limit_per_operation: Z.t ; + hard_gas_limit_per_block: Z.t ; + proof_of_work_threshold: int64 ; + tokens_per_roll: Tez_repr.t ; + michelson_maximum_type_size: int; + seed_nonce_revelation_tip: Tez_repr.t ; + origination_size: int ; + block_security_deposit: Tez_repr.t ; + endorsement_security_deposit: Tez_repr.t ; + block_reward: Tez_repr.t ; + endorsement_reward: Tez_repr.t ; + cost_per_byte: Tez_repr.t ; + hard_storage_limit_per_operation: Z.t ; + test_chain_duration: int64 ; (* in seconds *) + } + + let default = { + preserved_cycles = 5 ; + blocks_per_cycle = 4096l ; + blocks_per_commitment = 32l ; + blocks_per_roll_snapshot = 256l ; + blocks_per_voting_period = 32768l ; + time_between_blocks = + List.map Period_repr.of_seconds_exn [ 60L ; 75L ] ; + endorsers_per_block = 32 ; + hard_gas_limit_per_operation = Z.of_int 800_000 ; + hard_gas_limit_per_block = Z.of_int 8_000_000 ; + proof_of_work_threshold = + Int64.(sub (shift_left 1L 46) 1L) ; + tokens_per_roll = + Tez_repr.(mul_exn one 8_000) ; + michelson_maximum_type_size = 1000 ; + seed_nonce_revelation_tip = begin + match Tez_repr.(one /? 8L) with + | Ok c -> c + | Error _ -> assert false + end ; + origination_size = 257 ; + block_security_deposit = Tez_repr.(mul_exn one 512) ; + endorsement_security_deposit = Tez_repr.(mul_exn one 64) ; + block_reward = Tez_repr.(mul_exn one 16) ; + endorsement_reward = Tez_repr.(mul_exn one 2) ; + hard_storage_limit_per_operation = Z.of_int 60_000 ; + cost_per_byte = Tez_repr.of_mutez_exn 1_000L ; + test_chain_duration = Int64.mul 32768L 60L; + } + + (* This encoding is used to read configuration files (e.g. sandbox.json) + where some fields can be missing, in that case they are replaced by + the default. *) + let constants_encoding = + let open Data_encoding in + conv + (fun (c : parametric) -> + let module Compare_time_between_blocks = Compare.List (Period_repr) in + let module Compare_keys = Compare.List (Ed25519.Public_key) in + let opt (=) def v = if def = v then None else Some v in + let preserved_cycles = + opt Compare.Int.(=) + default.preserved_cycles c.preserved_cycles + and blocks_per_cycle = + opt Compare.Int32.(=) + default.blocks_per_cycle c.blocks_per_cycle + and blocks_per_commitment = + opt Compare.Int32.(=) + default.blocks_per_commitment c.blocks_per_commitment + and blocks_per_roll_snapshot = + opt Compare.Int32.(=) + default.blocks_per_roll_snapshot c.blocks_per_roll_snapshot + and blocks_per_voting_period = + opt Compare.Int32.(=) + default.blocks_per_voting_period c.blocks_per_voting_period + and time_between_blocks = + opt Compare_time_between_blocks.(=) + default.time_between_blocks c.time_between_blocks + and endorsers_per_block = + opt Compare.Int.(=) + default.endorsers_per_block c.endorsers_per_block + and hard_gas_limit_per_operation = + opt Compare.Z.(=) + default.hard_gas_limit_per_operation c.hard_gas_limit_per_operation + and hard_gas_limit_per_block = + opt Compare.Z.(=) + default.hard_gas_limit_per_block c.hard_gas_limit_per_block + and proof_of_work_threshold = + opt Compare.Int64.(=) + default.proof_of_work_threshold c.proof_of_work_threshold + and tokens_per_roll = + opt Tez_repr.(=) + default.tokens_per_roll c.tokens_per_roll + and michelson_maximum_type_size = + opt Compare.Int.(=) + default.michelson_maximum_type_size c.michelson_maximum_type_size + and seed_nonce_revelation_tip = + opt Tez_repr.(=) + default.seed_nonce_revelation_tip c.seed_nonce_revelation_tip + and origination_size = + opt Compare.Int.(=) + default.origination_size c.origination_size + and block_security_deposit = + opt Tez_repr.(=) + default.block_security_deposit c.block_security_deposit + and endorsement_security_deposit = + opt Tez_repr.(=) + default.endorsement_security_deposit c.endorsement_security_deposit + and block_reward = + opt Tez_repr.(=) + default.block_reward c.block_reward + and endorsement_reward = + opt Tez_repr.(=) + default.endorsement_reward c.endorsement_reward + and cost_per_byte = + opt Tez_repr.(=) + default.cost_per_byte c.cost_per_byte + and hard_storage_limit_per_operation = + opt Compare.Z.(=) + default.hard_storage_limit_per_operation c.hard_storage_limit_per_operation + and test_chain_duration = + opt Compare.Int64.(=) + default.test_chain_duration c.test_chain_duration + in + (( preserved_cycles, blocks_per_cycle, blocks_per_commitment, blocks_per_roll_snapshot, @@ -201,98 +261,98 @@ let constants_encoding = (endorsement_reward, cost_per_byte, hard_storage_limit_per_operation, - test_chain_duration))) -> - let unopt def = function None -> def | Some v -> v in - let default = Constants_repr.default in - { Constants_repr.preserved_cycles = - unopt default.preserved_cycles preserved_cycles ; - blocks_per_cycle = - unopt default.blocks_per_cycle blocks_per_cycle ; - blocks_per_commitment = - unopt default.blocks_per_commitment blocks_per_commitment ; - blocks_per_roll_snapshot = - unopt default.blocks_per_roll_snapshot blocks_per_roll_snapshot ; - blocks_per_voting_period = - unopt default.blocks_per_voting_period blocks_per_voting_period ; - time_between_blocks = - unopt default.time_between_blocks @@ - time_between_blocks ; - endorsers_per_block = - unopt default.endorsers_per_block endorsers_per_block ; - hard_gas_limit_per_operation = - unopt default.hard_gas_limit_per_operation hard_gas_limit_per_operation ; - hard_gas_limit_per_block = - unopt default.hard_gas_limit_per_block hard_gas_limit_per_block ; - proof_of_work_threshold = - unopt default.proof_of_work_threshold proof_of_work_threshold ; - tokens_per_roll = - unopt default.tokens_per_roll tokens_per_roll ; - michelson_maximum_type_size = - unopt default.michelson_maximum_type_size michelson_maximum_type_size ; - seed_nonce_revelation_tip = - unopt default.seed_nonce_revelation_tip seed_nonce_revelation_tip ; - origination_size = - unopt default.origination_size origination_size ; - block_security_deposit = - unopt default.block_security_deposit block_security_deposit ; - endorsement_security_deposit = - unopt default.endorsement_security_deposit endorsement_security_deposit ; - block_reward = - unopt default.block_reward block_reward ; - endorsement_reward = - unopt default.endorsement_reward endorsement_reward ; - cost_per_byte = - unopt default.cost_per_byte cost_per_byte ; - hard_storage_limit_per_operation = - unopt default.hard_storage_limit_per_operation hard_storage_limit_per_operation ; - test_chain_duration = - unopt default.test_chain_duration test_chain_duration ; - } ) - (merge_objs - (obj9 - (opt "preserved_cycles" uint8) - (opt "blocks_per_cycle" int32) - (opt "blocks_per_commitment" int32) - (opt "blocks_per_roll_snapshot" int32) - (opt "blocks_per_voting_period" int32) - (opt "time_between_blocks" (list Period_repr.encoding)) - (opt "endorsers_per_block" uint16) - (opt "hard_gas_limit_per_operation" z) - (opt "hard_gas_limit_per_block" z)) - (merge_objs - (obj8 - (opt "proof_of_work_threshold" int64) - (opt "tokens_per_roll" Tez_repr.encoding) - (opt "michelson_maximum_type_size" uint16) - (opt "seed_nonce_revelation_tip" Tez_repr.encoding) - (opt "origination_size" int31) - (opt "block_security_deposit" Tez_repr.encoding) - (opt "endorsement_security_deposit" Tez_repr.encoding) - (opt "block_reward" Tez_repr.encoding)) - (obj4 - (opt "endorsement_reward" Tez_repr.encoding) - (opt "cost_per_byte" Tez_repr.encoding) - (opt "hard_storage_limit_per_operation" z) - (opt "test_chain_duration" int64)))) + test_chain_duration)))) + (fun (( preserved_cycles, + blocks_per_cycle, + blocks_per_commitment, + blocks_per_roll_snapshot, + blocks_per_voting_period, + time_between_blocks, + endorsers_per_block, + hard_gas_limit_per_operation, + hard_gas_limit_per_block), + ((proof_of_work_threshold, + tokens_per_roll, + michelson_maximum_type_size, + seed_nonce_revelation_tip, + origination_size, + block_security_deposit, + endorsement_security_deposit, + block_reward), + (endorsement_reward, + cost_per_byte, + hard_storage_limit_per_operation, + test_chain_duration))) -> + let unopt def = function None -> def | Some v -> v in + { preserved_cycles = + unopt default.preserved_cycles preserved_cycles ; + blocks_per_cycle = + unopt default.blocks_per_cycle blocks_per_cycle ; + blocks_per_commitment = + unopt default.blocks_per_commitment blocks_per_commitment ; + blocks_per_roll_snapshot = + unopt default.blocks_per_roll_snapshot blocks_per_roll_snapshot ; + blocks_per_voting_period = + unopt default.blocks_per_voting_period blocks_per_voting_period ; + time_between_blocks = + unopt default.time_between_blocks @@ + time_between_blocks ; + endorsers_per_block = + unopt default.endorsers_per_block endorsers_per_block ; + hard_gas_limit_per_operation = + unopt default.hard_gas_limit_per_operation hard_gas_limit_per_operation ; + hard_gas_limit_per_block = + unopt default.hard_gas_limit_per_block hard_gas_limit_per_block ; + proof_of_work_threshold = + unopt default.proof_of_work_threshold proof_of_work_threshold ; + tokens_per_roll = + unopt default.tokens_per_roll tokens_per_roll ; + michelson_maximum_type_size = + unopt default.michelson_maximum_type_size michelson_maximum_type_size ; + seed_nonce_revelation_tip = + unopt default.seed_nonce_revelation_tip seed_nonce_revelation_tip ; + origination_size = + unopt default.origination_size origination_size ; + block_security_deposit = + unopt default.block_security_deposit block_security_deposit ; + endorsement_security_deposit = + unopt default.endorsement_security_deposit endorsement_security_deposit ; + block_reward = + unopt default.block_reward block_reward ; + endorsement_reward = + unopt default.endorsement_reward endorsement_reward ; + cost_per_byte = + unopt default.cost_per_byte cost_per_byte ; + hard_storage_limit_per_operation = + unopt default.hard_storage_limit_per_operation hard_storage_limit_per_operation ; + test_chain_duration = + unopt default.test_chain_duration test_chain_duration ; + } ) + (merge_objs + (obj9 + (opt "preserved_cycles" uint8) + (opt "blocks_per_cycle" int32) + (opt "blocks_per_commitment" int32) + (opt "blocks_per_roll_snapshot" int32) + (opt "blocks_per_voting_period" int32) + (opt "time_between_blocks" (list Period_repr.encoding)) + (opt "endorsers_per_block" uint16) + (opt "hard_gas_limit_per_operation" z) + (opt "hard_gas_limit_per_block" z)) + (merge_objs + (obj8 + (opt "proof_of_work_threshold" int64) + (opt "tokens_per_roll" Tez_repr.encoding) + (opt "michelson_maximum_type_size" uint16) + (opt "seed_nonce_revelation_tip" Tez_repr.encoding) + (opt "origination_size" int31) + (opt "block_security_deposit" Tez_repr.encoding) + (opt "endorsement_security_deposit" Tez_repr.encoding) + (opt "block_reward" Tez_repr.encoding)) + (obj4 + (opt "endorsement_reward" Tez_repr.encoding) + (opt "cost_per_byte" Tez_repr.encoding) + (opt "hard_storage_limit_per_operation" z) + (opt "test_chain_duration" int64)))) -let encoding = - let open Data_encoding in - conv - (fun { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ; - security_deposit_ramp_up_cycles ; no_reward_cycles } -> - ((bootstrap_accounts, bootstrap_contracts, commitments, - security_deposit_ramp_up_cycles, no_reward_cycles), - constants)) - (fun ( (bootstrap_accounts, bootstrap_contracts, commitments, - security_deposit_ramp_up_cycles, no_reward_cycles), - constants) -> - { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ; - security_deposit_ramp_up_cycles ; no_reward_cycles }) - (merge_objs - (obj5 - (req "bootstrap_accounts" (list bootstrap_account_encoding)) - (dft "bootstrap_contracts" (list bootstrap_contract_encoding) []) - (dft "commitments" (list Commitment_repr.encoding) []) - (opt "security_deposit_ramp_up_cycles" int31) - (opt "no_reward_cycles" int31)) - constants_encoding) +end diff --git a/src/proto_alpha/lib_protocol/parameters_repr.mli b/src/proto_alpha/lib_protocol/parameters_repr.mli index 45818219585ea1fe195ec5544b56b771ad24c54d..c679c58f11123d3a05827a0f41eac014d9632ea9 100644 --- a/src/proto_alpha/lib_protocol/parameters_repr.mli +++ b/src/proto_alpha/lib_protocol/parameters_repr.mli @@ -45,4 +45,34 @@ type t = { } val encoding: t Data_encoding.t -val constants_encoding: Constants_repr.parametric Data_encoding.t + + +(* Only for migration from 004 to 005 *) + +module Proto_004 : sig + type parametric = { + preserved_cycles: int ; + blocks_per_cycle: int32 ; + blocks_per_commitment: int32 ; + blocks_per_roll_snapshot: int32 ; + blocks_per_voting_period: int32 ; + time_between_blocks: Period_repr.t list ; + endorsers_per_block: int ; + hard_gas_limit_per_operation: Z.t ; + hard_gas_limit_per_block: Z.t ; + proof_of_work_threshold: int64 ; + tokens_per_roll: Tez_repr.t ; + michelson_maximum_type_size: int; + seed_nonce_revelation_tip: Tez_repr.t ; + origination_size: int ; + block_security_deposit: Tez_repr.t ; + endorsement_security_deposit: Tez_repr.t ; + block_reward: Tez_repr.t ; + endorsement_reward: Tez_repr.t ; + cost_per_byte: Tez_repr.t ; + hard_storage_limit_per_operation: Z.t ; + test_chain_duration: int64 ; + } + + val constants_encoding: parametric Data_encoding.t +end diff --git a/src/proto_alpha/lib_protocol/period_repr.ml b/src/proto_alpha/lib_protocol/period_repr.ml index f1a97d561acf19c37b43b1f92279c46626fe0683..3719221f4c8448a51133360ebd9917e4a6173469 100644 --- a/src/proto_alpha/lib_protocol/period_repr.ml +++ b/src/proto_alpha/lib_protocol/period_repr.ml @@ -28,6 +28,8 @@ type period = t include (Compare.Int64 : Compare.S with type t := t) let encoding = Data_encoding.int64 +let rpc_arg = RPC_arg.int64 + let pp ppf v = Format.fprintf ppf "%Ld" v type error += (* `Permanent *) @@ -73,6 +75,7 @@ let mult i p = then error Invalid_arg else ok (Int64.mul (Int64.of_int32 i) p) +let zero = of_seconds_exn 0L let one_second = of_seconds_exn 1L let one_minute = of_seconds_exn 60L let one_hour = of_seconds_exn 3600L diff --git a/src/proto_alpha/lib_protocol/period_repr.mli b/src/proto_alpha/lib_protocol/period_repr.mli index 555b704dfdc94f60f5577a797083a0f97219d7e3..a84fba7d239e9fab181e9150e11b5a9b5aec57bb 100644 --- a/src/proto_alpha/lib_protocol/period_repr.mli +++ b/src/proto_alpha/lib_protocol/period_repr.mli @@ -27,6 +27,7 @@ type t type period = t include Compare.S with type t := t val encoding : period Data_encoding.t +val rpc_arg : period RPC_arg.t val pp: Format.formatter -> period -> unit @@ -41,6 +42,7 @@ val of_seconds_exn : int64 -> period val mult : int32 -> period -> period tzresult +val zero : period val one_second : period val one_minute : period val one_hour : period diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index e1eb7386bf9bee1d28bce86adc5a5fe2dd33b55c..26841b7db2a4bef709c440a1c0f02996a0ae922d 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -30,18 +30,22 @@ type t = { constants: Constants_repr.parametric ; first_level: Raw_level_repr.t ; level: Level_repr.t ; + predecessor_timestamp: Time.t ; timestamp: Time.t ; fitness: Int64.t ; deposits: Tez_repr.t Signature.Public_key_hash.Map.t ; + included_endorsements: int ; allowed_endorsements: (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ; fees: Tez_repr.t ; rewards: Tez_repr.t ; block_gas: Z.t ; operation_gas: Gas_limit_repr.t ; + internal_gas: Gas_limit_repr.internal_gas ; storage_space_to_pay: Z.t option ; allocated_contracts: int option ; origination_nonce: Contract_repr.origination_nonce option ; + temporary_big_map: Z.t ; internal_nonce: int ; internal_nonces_used: Int_set.t ; } @@ -50,6 +54,7 @@ type context = t type root_context = t let current_level ctxt = ctxt.level +let predecessor_timestamp ctxt = ctxt.predecessor_timestamp let current_timestamp ctxt = ctxt.timestamp let current_fitness ctxt = ctxt.fitness let first_level ctxt = ctxt.first_level @@ -62,6 +67,7 @@ let record_endorsement ctxt k = | Some (_, _, true) -> assert false (* right already used *) | Some (d, s, false) -> { ctxt with + included_endorsements = ctxt.included_endorsements + (List.length s); allowed_endorsements = Signature.Public_key_hash.Map.add k (d,s,true) ctxt.allowed_endorsements } @@ -77,6 +83,8 @@ let init_endorsements ctxt allowed_endorsements = let allowed_endorsements ctxt = ctxt.allowed_endorsements +let included_endorsements ctxt = ctxt.included_endorsements + type error += Too_many_internal_operations (* `Permanent *) let () = @@ -184,16 +192,22 @@ let check_gas_limit ctxt remaining = else ok () let set_gas_limit ctxt remaining = - { ctxt with operation_gas = Limited { remaining } } + { ctxt with operation_gas = Limited { remaining } ; + internal_gas = Gas_limit_repr.internal_gas_zero } let set_gas_unlimited ctxt = { ctxt with operation_gas = Unaccounted } let consume_gas ctxt cost = - Gas_limit_repr.consume ctxt.block_gas ctxt.operation_gas cost >>? fun (block_gas, operation_gas) -> - ok { ctxt with block_gas ; operation_gas } + Gas_limit_repr.consume + ctxt.block_gas + ctxt.operation_gas + ctxt.internal_gas + cost >>? fun (block_gas, operation_gas, internal_gas) -> + ok { ctxt with block_gas ; operation_gas ; internal_gas } let check_enough_gas ctxt cost = - Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas cost + Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas ctxt.internal_gas cost let gas_level ctxt = ctxt.operation_gas let block_gas_level ctxt = ctxt.block_gas + let gas_consumed ~since ~until = match gas_level since, gas_level until with | Limited { remaining = before }, Limited { remaining = after } -> Z.sub before after @@ -400,7 +414,7 @@ let get_proto_param ctxt = let set_constants ctxt constants = let bytes = Data_encoding.Binary.to_bytes_exn - Parameters_repr.constants_encoding constants in + Constants_repr.parametric_encoding constants in Context.set ctxt constants_key bytes let get_constants ctxt = @@ -409,7 +423,20 @@ let get_constants ctxt = failwith "Internal error: cannot read constants in context." | Some bytes -> match - Data_encoding.Binary.of_bytes Parameters_repr.constants_encoding bytes + Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes + with + | None -> + failwith "Internal error: cannot parse constants in context." + | Some constants -> return constants + +(* only for migration from 004 to 005 *) +let get_004_constants ctxt = + Context.get ctxt constants_key >>= function + | None -> + failwith "Internal error: cannot read constants in context." + | Some bytes -> + match + Data_encoding.Binary.of_bytes Parameters_repr.Proto_004.constants_encoding bytes with | None -> failwith "Internal error: cannot parse constants in context." @@ -431,7 +458,7 @@ let check_inited ctxt = else storage_error (Incompatible_protocol_version s) -let prepare ~level ~timestamp ~fitness ctxt = +let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt = Lwt.return (Raw_level_repr.of_int32 level) >>=? fun level -> Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness -> check_inited ctxt >>=? fun () -> @@ -446,16 +473,20 @@ let prepare ~level ~timestamp ~fitness ctxt = level in return { context = ctxt ; constants ; level ; + predecessor_timestamp ; timestamp ; fitness ; first_level ; allowed_endorsements = Signature.Public_key_hash.Map.empty ; + included_endorsements = 0 ; fees = Tez_repr.zero ; rewards = Tez_repr.zero ; deposits = Signature.Public_key_hash.Map.empty ; operation_gas = Unaccounted ; + internal_gas = Gas_limit_repr.internal_gas_zero ; storage_space_to_pay = None ; allocated_contracts = None ; block_gas = constants.Constants_repr.hard_gas_limit_per_block ; origination_nonce = None ; + temporary_big_map = Z.sub Z.zero Z.one ; internal_nonce = 0 ; internal_nonces_used = Int_set.empty ; } @@ -495,9 +526,40 @@ let prepare_first_block ~level ~timestamp ~fitness ctxt = set_constants ctxt param.constants >>= fun ctxt -> return ctxt | Alpha_previous -> + get_004_constants ctxt >>=? fun c -> + let constants = Constants_repr.{ + preserved_cycles = c.preserved_cycles ; + blocks_per_cycle = c.blocks_per_cycle ; + blocks_per_commitment = c.blocks_per_commitment ; + blocks_per_roll_snapshot = c.blocks_per_roll_snapshot ; + blocks_per_voting_period = c.blocks_per_voting_period ; + time_between_blocks = + List.map Period_repr.of_seconds_exn [ 60L ; 40L ] ; + endorsers_per_block = c.endorsers_per_block ; + hard_gas_limit_per_operation = c.hard_gas_limit_per_operation ; + hard_gas_limit_per_block = c.hard_gas_limit_per_block ; + proof_of_work_threshold = c.proof_of_work_threshold ; + tokens_per_roll = c.tokens_per_roll ; + michelson_maximum_type_size = c.michelson_maximum_type_size; + seed_nonce_revelation_tip = c.seed_nonce_revelation_tip ; + origination_size = c.origination_size ; + block_security_deposit = c.block_security_deposit ; + endorsement_security_deposit = c.endorsement_security_deposit ; + block_reward = c.block_reward ; + endorsement_reward = c.endorsement_reward ; + cost_per_byte = c.cost_per_byte ; + hard_storage_limit_per_operation = c.hard_storage_limit_per_operation ; + test_chain_duration = c.test_chain_duration ; + quorum_min = 20_00l ; (* quorum is in centile of a percentage *) + quorum_max = 70_00l ; + min_proposal_quorum = 5_00l ; + initial_endorsers = 24 ; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L ; + } in + set_constants ctxt constants >>= fun ctxt -> return ctxt end >>=? fun ctxt -> - prepare ctxt ~level ~timestamp ~fitness >>=? fun ctxt -> + prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness >>=? fun ctxt -> return (previous_proto, ctxt) let activate ({ context = c ; _ } as s) h = @@ -507,30 +569,6 @@ let fork_test_chain ({ context = c ; _ } as s) protocol expiration = Updater.fork_test_chain c ~protocol ~expiration >>= fun c -> Lwt.return { s with context = c } -let register_resolvers enc resolve = - let resolve context str = - let faked_context = { - context ; - constants = Constants_repr.default ; - first_level = Raw_level_repr.root ; - level = Level_repr.root Raw_level_repr.root ; - timestamp = Time.of_seconds 0L ; - fitness = 0L ; - allowed_endorsements = Signature.Public_key_hash.Map.empty ; - storage_space_to_pay = None ; - allocated_contracts = None ; - fees = Tez_repr.zero ; - rewards = Tez_repr.zero ; - deposits = Signature.Public_key_hash.Map.empty ; - block_gas = Constants_repr.default.hard_gas_limit_per_block ; - operation_gas = Unaccounted ; - origination_nonce = None ; - internal_nonce = 0 ; - internal_nonces_used = Int_set.empty ; - } in - resolve faked_context str in - Context.register_resolver enc resolve - (* Generic context ********************************************************) type key = string list @@ -650,3 +688,19 @@ let project x = x let absolute_key _ k = k let description = Storage_description.create () + +let fresh_temporary_big_map ctxt = + { ctxt with temporary_big_map = Z.sub ctxt.temporary_big_map Z.one }, + ctxt.temporary_big_map + +let reset_temporary_big_map ctxt = + { ctxt with temporary_big_map = Z.sub Z.zero Z.one } + +let temporary_big_maps ctxt f acc = + let rec iter acc id = + if Z.equal id ctxt.temporary_big_map then + Lwt.return acc + else + f acc id >>= fun acc -> + iter acc (Z.sub id Z.one) in + iter acc (Z.sub Z.zero Z.one) diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index 2dfc0ca3d2617a3957a5db1238aa8de6b68223a1..6bec232523bd13a4d1ebf97143d0f2428f114e4f 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(** {1 Errors} ****************************************************************) +(** {1 Errors} *) type error += Too_many_internal_operations (* `Permanent *) @@ -40,7 +40,7 @@ type error += Failed_to_decode_parameter of Data_encoding.json * string val storage_error: storage_error -> 'a tzresult Lwt.t -(** {1 Abstract Context} **************************************************) +(** {1 Abstract Context} *) (** Abstract view of the context. Includes a handle to the functional key-value database @@ -54,6 +54,7 @@ type root_context = t with this version of the protocol. *) val prepare: level: Int32.t -> + predecessor_timestamp: Time.t -> timestamp: Time.t -> fitness: Fitness.t -> Context.t -> context tzresult Lwt.t @@ -71,14 +72,12 @@ val prepare_first_block: val activate: context -> Protocol_hash.t -> t Lwt.t val fork_test_chain: context -> Protocol_hash.t -> Time.t -> t Lwt.t -val register_resolvers: - 'a Base58.encoding -> (context -> string -> 'a list Lwt.t) -> unit - (** Returns the state of the database resulting of operations on its abstract view *) val recover: context -> Context.t val current_level: context -> Level_repr.t +val predecessor_timestamp: context -> Time.t val current_timestamp: context -> Time.t val current_fitness: context -> Int64.t @@ -129,7 +128,7 @@ val origination_nonce: t -> Contract_repr.origination_nonce tzresult val increment_origination_nonce: t -> (t * Contract_repr.origination_nonce) tzresult val unset_origination_nonce: t -> t -(** {1 Generic accessors} *************************************************) +(** {1 Generic accessors} *) type key = string list @@ -241,6 +240,9 @@ val allowed_endorsements: context -> (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t +(** Keep track of the number of endorsements that are included in a block *) +val included_endorsements: context -> int + (** Initializes the map of allowed endorsements, this function must only be called once. *) val init_endorsements: @@ -251,3 +253,12 @@ val init_endorsements: (** Marks an endorsment in the map as used. *) val record_endorsement: context -> Signature.Public_key_hash.t -> context + +(** Provide a fresh identifier for a temporary big map (negative index). *) +val fresh_temporary_big_map: context -> context * Z.t + +(** Reset the temporary big_map identifier generator to [-1]. *) +val reset_temporary_big_map: context -> context + +(** Iterate over all created temporary big maps since the last {!reset_temporary_big_map}. *) +val temporary_big_maps: context -> ('a -> Z.t -> 'a Lwt.t) -> 'a -> 'a Lwt.t diff --git a/src/proto_alpha/lib_protocol/raw_level_repr.ml b/src/proto_alpha/lib_protocol/raw_level_repr.ml index 8af1b45439f47c83d23f1ce64b82cf5803f7c17c..16b4f2d62c60a4a8c86abd6450f118dc7bf2a33a 100644 --- a/src/proto_alpha/lib_protocol/raw_level_repr.ml +++ b/src/proto_alpha/lib_protocol/raw_level_repr.ml @@ -72,7 +72,7 @@ let () = let of_int32 l = try Ok (of_int32_exn l) - with _ -> Error [Unexpected_level l] + with _ -> error (Unexpected_level l) module Index = struct type t = raw_level diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 04229a1aa8f61fbaca161fec79cb9b23b945e350..3e4917b1af3a62691e09740b36c4da97b6cef836 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -157,677 +157,818 @@ let unparse_stack ctxt (stack, stack_ty) = return ((data, annot) :: rest) in unparse_stack (stack, stack_ty) -module Interp_costs = Michelson_v1_gas.Cost_of +module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter -let rec interp - : type p r. +let rec interp_stack_prefix_preserving_operation : type fbef bef faft aft result . + (fbef stack -> (faft stack * result) tzresult Lwt.t) + -> (fbef, faft, bef, aft) stack_prefix_preservation_witness + -> bef stack + -> (aft stack * result) tzresult Lwt.t = + fun f n stk -> + match n,stk with + | Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))), + Item (v0, Item (v1, Item (v2, Item (v3, Item (v4, Item (v5, Item (v6, Item (v7, Item (v8, Item (v9, Item (va, Item (vb, Item (vc, Item (vd, Item (ve, Item (vf, rest)))))))))))))))) -> + interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) -> + return (Item (v0, Item (v1, Item (v2, Item (v3, Item (v4, Item (v5, Item (v6, Item (v7, Item (v8, Item (v9, Item (va, Item (vb, Item (vc, Item (vd, Item (ve, Item (vf, rest')))))))))))))))), result) + | Prefix (Prefix (Prefix (Prefix n))), + Item (v0, Item (v1, Item (v2, Item (v3, rest)))) -> + interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) -> + return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result) + | Prefix n, Item (v, rest) -> + interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) -> + return (Item (v, rest'), result) + | Rest, v -> f v + +type step_constants = + { source : Contract.t ; + payer : Contract.t ; + self : Contract.t ; + amount : Tez.t ; + chain_id : Chain_id.t } + +let rec step + : type b a. (?log: execution_trace ref -> - context -> - source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t -> - (p, r) lambda -> p -> - (r * context) tzresult Lwt.t) - = fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg -> - let rec step - : type b a. - context -> (b, a) descr -> b stack -> - (a stack * context) tzresult Lwt.t = - fun ctxt ({ instr ; loc ; _ } as descr) stack -> - Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> - let logged_return : type a b. - (b, a) descr -> - a stack * context -> - (a stack * context) tzresult Lwt.t = - fun descr (ret, ctxt) -> - match log with - | None -> return (ret, ctxt) - | Some log -> - trace - Cannot_serialize_log - (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> - log := (descr.loc, Gas.level ctxt, stack) :: !log ; - return (ret, ctxt) in - let get_log (log : execution_trace ref option) = - Option.map ~f:(fun l -> List.rev !l) log in - let consume_gas_terop : type ret arg1 arg2 arg3 rest. - (_ * (_ * (_ * rest)), ret * rest) descr -> - ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> - (arg1 -> arg2 -> arg3 -> Gas.cost) -> - rest stack -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2, x3) cost_func rest -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2 x3, rest), ctxt) in - let consume_gas_binop : type ret arg1 arg2 rest. - (_ * (_ * rest), ret * rest) descr -> - ((arg1 -> arg2 -> ret) * arg1 * arg2) -> - (arg1 -> arg2 -> Gas.cost) -> - rest stack -> - context -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2, rest), ctxt) in - let consume_gas_unop : type ret arg rest. - (_ * rest, ret * rest) descr -> - ((arg -> ret) * arg) -> - (arg -> Gas.cost) -> - rest stack -> - context -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, arg) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> - logged_return descr (Item (op arg, rest), ctxt) in - let consume_gaz_comparison : - type t rest. - (t * (t * rest), Script_int.z Script_int.num * rest) descr -> - (t -> t -> int) -> - (t -> t -> Gas.cost) -> - t -> t -> - rest stack -> - ((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t = - fun descr op cost x1 x2 rest -> - Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt -> - logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in - let logged_return : - a stack * context -> - (a stack * context) tzresult Lwt.t = - logged_return descr in - match instr, stack with - (* stack ops *) - | Drop, Item (_, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (rest, ctxt) - | Dup, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (v, Item (v, rest)), ctxt) - | Swap, Item (vi, Item (vo, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (vo, Item (vi, rest)), ctxt) - | Const v, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - (* options *) - | Cons_some, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (Some v, rest), ctxt) - | Cons_none _, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | If_none (bt, _), Item (None, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt rest - | If_none (_, bf), Item (Some v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf (Item (v, rest)) - (* pairs *) - | Cons_pair, Item (a, Item (b, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> - logged_return (Item ((a, b), rest), ctxt) - | Car, Item ((a, _), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (a, rest), ctxt) - | Cdr, Item ((_, b), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (b, rest), ctxt) - (* unions *) - | Left, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (L v, rest), ctxt) - | Right, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (R v, rest), ctxt) - | If_left (bt, _), Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt (Item (v, rest)) - | If_left (_, bf), Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf (Item (v, rest)) - (* lists *) - | Cons_list, Item (hd, Item (tl, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> - logged_return (Item (hd :: tl, rest), ctxt) - | Nil, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item ([], rest), ctxt) - | If_cons (_, bf), Item ([], rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf rest - | If_cons (bt, _), Item (hd :: tl, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt (Item (hd, Item (tl, rest))) - | List_map body, Item (l, rest) -> - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (Item (List.rev acc, rest), ctxt) - | hd :: tl -> - step ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (hd :: acc) - in loop rest ctxt l [] >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | List_size, Item (list, rest) -> - Lwt.return - (List.fold_left - (fun acc _ -> - acc >>? fun (size, ctxt) -> - Gas.consume ctxt Interp_costs.list_size >>? fun ctxt -> - ok (size + 1 (* FIXME: overflow *), ctxt)) - (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> - logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) - | List_iter body, Item (l, init) -> - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - (* sets *) - | Empty_set t, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> - logged_return (Item (empty_set t, rest), ctxt) - | Set_iter body, Item (set, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> - let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Set_mem, Item (v, Item (set, rest)) -> - consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt - | Set_update, Item (v, Item (presence, Item (set, rest))) -> - consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest - | Set_size, Item (set, rest) -> - consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt - (* maps *) - | Empty_map (t, _), rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> - logged_return (Item (empty_map t, rest), ctxt) - | Map_map body, Item (map, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (acc, ctxt) - | (k, _) as hd :: tl -> - step ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (map_update k (Some hd) acc) - in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Map_iter body, Item (map, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Map_mem, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt - | Map_get, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt - | Map_update, Item (k, Item (v, Item (map, rest))) -> - consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest - | Map_size, Item (map, rest) -> - consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt - (* Big map operations *) - | Big_map_mem, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_get, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> - consume_gas_terop descr - (Script_ir_translator.big_map_update, key, maybe_value, map) - Interp_costs.big_map_update rest - (* timestamp operations *) - | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> - consume_gas_binop descr - (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> - consume_gas_binop descr (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> - consume_gas_binop descr (Script_timestamp.sub_delta, t, s) - Interp_costs.sub_timestamp rest ctxt - | Diff_timestamps, Item (t1, Item (t2, rest)) -> - consume_gas_binop descr (Script_timestamp.diff, t1, t2) - Interp_costs.diff_timestamps rest ctxt - (* string operations *) - | Concat_string_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> - let s = String.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_string, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> - let s = String.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_string, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (String.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | String_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) - (* bytes operations *) - | Concat_bytes_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> - let s = MBytes.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_bytes, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> - let s = MBytes.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (MBytes.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | Bytes_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) - (* currency operations *) - | Add_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x +? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Sub_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x -? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Mul_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - | Mul_nattez, Item (y, Item (x, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - (* boolean operations *) - | Or, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt - | And, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt - | Xor, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt - | Not, Item (x, rest) -> - consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt - (* integer operations *) - | Is_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt - | Abs_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt - | Int_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt - | Neg_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Neg_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Add_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt - | Sub_int, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt - | Mul_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt - | Ediv_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - let x = Script_int.of_int64 (Tez.to_mutez x) in - consume_gas_binop descr - ((fun x y -> - match Script_int.ediv x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 q, - Script_int.to_int64 r with - | Some q, Some r -> - begin - match Tez.of_mutez q, Tez.of_mutez r with - | Some q, Some r -> Some (q,r) - (* Cannot overflow *) - | _ -> assert false - end - (* Cannot overflow *) - | _ -> assert false), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in - let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in - consume_gas_binop descr - ((fun x y -> match Script_int.ediv_n x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 r with + context -> step_constants -> (b, a) descr -> b stack -> + (a stack * context) tzresult Lwt.t) = + fun ?log ctxt step_constants ({ instr ; loc ; _ } as descr) stack -> + Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> + let logged_return : type a b. + (b, a) descr -> + a stack * context -> + (a stack * context) tzresult Lwt.t = + fun descr (ret, ctxt) -> + match log with + | None -> return (ret, ctxt) + | Some log -> + trace + Cannot_serialize_log + (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> + log := (descr.loc, Gas.level ctxt, stack) :: !log ; + return (ret, ctxt) in + let get_log (log : execution_trace ref option) = + Option.map ~f:(fun l -> List.rev !l) log in + let consume_gas_terop : type ret arg1 arg2 arg3 rest. + (_ * (_ * (_ * rest)), ret * rest) descr -> + ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> + (arg1 -> arg2 -> arg3 -> Gas.cost) -> + rest stack -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2, x3) cost_func rest -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2 x3, rest), ctxt) in + let consume_gas_binop : type ret arg1 arg2 rest. + (_ * (_ * rest), ret * rest) descr -> + ((arg1 -> arg2 -> ret) * arg1 * arg2) -> + (arg1 -> arg2 -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2, rest), ctxt) in + let consume_gas_unop : type ret arg rest. + (_ * rest, ret * rest) descr -> + ((arg -> ret) * arg) -> + (arg -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, arg) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> + logged_return descr (Item (op arg, rest), ctxt) in + let logged_return : + a stack * context -> + (a stack * context) tzresult Lwt.t = + logged_return descr in + match instr, stack with + (* stack ops *) + | Drop, Item (_, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (rest, ctxt) + | Dup, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (v, Item (v, rest)), ctxt) + | Swap, Item (vi, Item (vo, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (vo, Item (vi, rest)), ctxt) + | Const v, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + (* options *) + | Cons_some, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (Some v, rest), ctxt) + | Cons_none _, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | If_none (bt, _), Item (None, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bt rest + | If_none (_, bf), Item (Some v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bf (Item (v, rest)) + (* pairs *) + | Cons_pair, Item (a, Item (b, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> + logged_return (Item ((a, b), rest), ctxt) + (* Peephole optimization for UNPAIR *) + | Seq ({instr=Dup;_}, + {instr=Seq ({instr=Car;_}, + {instr=Seq ({instr=Dip {instr=Cdr}}, + {instr=Nop;_});_});_}), + Item ((a, b), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (a, Item (b, rest)), ctxt) + | Car, Item ((a, _), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (a, rest), ctxt) + | Cdr, Item ((_, b), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (b, rest), ctxt) + (* unions *) + | Left, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (L v, rest), ctxt) + | Right, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (R v, rest), ctxt) + | If_left (bt, _), Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bt (Item (v, rest)) + | If_left (_, bf), Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bf (Item (v, rest)) + (* lists *) + | Cons_list, Item (hd, Item (tl, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> + logged_return (Item (hd :: tl, rest), ctxt) + | Nil, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item ([], rest), ctxt) + | If_cons (_, bf), Item ([], rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bf rest + | If_cons (bt, _), Item (hd :: tl, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bt (Item (hd, Item (tl, rest))) + | List_map body, Item (l, rest) -> + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_map) >>=? fun ctxt -> + match l with + | [] -> return (Item (List.rev acc, rest), ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (hd :: acc) + in loop rest ctxt l [] >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | List_size, Item (list, rest) -> + Lwt.return + (List.fold_left + (fun acc _ -> + acc >>? fun (size, ctxt) -> + Gas.consume ctxt Interp_costs.loop_size >>? fun ctxt -> + ok (size + 1 (* FIXME: overflow *), ctxt)) + (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> + logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) + | List_iter body, Item (l, init) -> + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + (* sets *) + | Empty_set t, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> + logged_return (Item (empty_set t, rest), ctxt) + | Set_iter body, Item (set, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> + let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Set_mem, Item (v, Item (set, rest)) -> + consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt + | Set_update, Item (v, Item (presence, Item (set, rest))) -> + consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest + | Set_size, Item (set, rest) -> + consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt + (* maps *) + | Empty_map (t, _), rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> + logged_return (Item (empty_map t, rest), ctxt) + | Map_map body, Item (map, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_map) >>=? fun ctxt -> + match l with + | [] -> return (acc, ctxt) + | (k, _) as hd :: tl -> + step ?log ctxt step_constants body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (map_update k (Some hd) acc) + in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Map_iter body, Item (map, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Map_mem, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt + | Map_get, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt + | Map_update, Item (k, Item (v, Item (map, rest))) -> + consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest + | Map_size, Item (map, rest) -> + consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt + (* Big map operations *) + | Empty_big_map (tk, tv), rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> + logged_return (Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt) + | Big_map_mem, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff)) >>=? fun ctxt -> + Script_ir_translator.big_map_mem ctxt key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_get, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_get key map.diff)) >>=? fun ctxt -> + Script_ir_translator.big_map_get ctxt key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> + consume_gas_terop descr + (Script_ir_translator.big_map_update, key, maybe_value, map) + (fun k v m -> Interp_costs.map_update k (Some v) m.diff) rest + (* timestamp operations *) + | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> + consume_gas_binop descr + (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> + consume_gas_binop descr (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> + consume_gas_binop descr (Script_timestamp.sub_delta, t, s) + Interp_costs.sub_timestamp rest ctxt + | Diff_timestamps, Item (t1, Item (t2, rest)) -> + consume_gas_binop descr (Script_timestamp.diff, t1, t2) + Interp_costs.diff_timestamps rest ctxt + (* string operations *) + | Concat_string_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> + let s = String.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_string, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> + let s = String.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_string, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (String.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | String_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) + (* bytes operations *) + | Concat_bytes_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> + let s = MBytes.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_bytes, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> + let s = MBytes.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (MBytes.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Bytes_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) + (* currency operations *) + | Add_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x +? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Sub_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x -? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Mul_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + | Mul_nattez, Item (y, Item (x, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + (* boolean operations *) + | Or, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt + | And, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt + | Xor, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt + | Not, Item (x, rest) -> + consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt + (* integer operations *) + | Is_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt + | Abs_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt + | Int_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt + | Neg_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Neg_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Add_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt + | Sub_int, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt + | Mul_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt + | Ediv_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + let x = Script_int.of_int64 (Tez.to_mutez x) in + consume_gas_binop descr + ((fun x y -> + match Script_int.ediv x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 q, + Script_int.to_int64 r with + | Some q, Some r -> + begin + match Tez.of_mutez q, Tez.of_mutez r with + | Some q, Some r -> Some (q,r) + (* Cannot overflow *) + | _ -> assert false + end + (* Cannot overflow *) + | _ -> assert false), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in + let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in + consume_gas_binop descr + ((fun x y -> match Script_int.ediv_n x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 r with + | None -> assert false (* Cannot overflow *) + | Some r -> + match Tez.of_mutez r with | None -> assert false (* Cannot overflow *) - | Some r -> - match Tez.of_mutez r with - | None -> assert false (* Cannot overflow *) - | Some r -> Some (q, r)), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt - | Lsl_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> - begin - match Script_int.shift_left_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some x -> logged_return (Item (x, rest), ctxt) - end - | Lsr_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> - begin - match Script_int.shift_right_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some r -> logged_return (Item (r, rest), ctxt) - end - | Or_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt - | And_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | And_int_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | Xor_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt - | Not_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - | Not_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - (* control *) - | Seq (hd, tl), stack -> - step ctxt hd stack >>=? fun (trans, ctxt) -> - step ctxt tl trans - | If (bt, _), Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt rest - | If (_, bf), Item (false, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf rest - | Loop body, Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step ctxt body rest >>=? fun (trans, ctxt) -> - step ctxt descr trans - | Loop _, Item (false, rest) -> - logged_return (rest, ctxt) - | Loop_left body, Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) -> - step ctxt descr trans - | Loop_left _, Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - | Dip b, Item (ign, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - step ctxt b rest >>=? fun (res, ctxt) -> - logged_return (Item (ign, res), ctxt) - | Exec, Item (arg, Item (lam, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> - interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Lambda lam, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (lam, rest), ctxt) - | Failwith tv, Item (v, _) -> - trace Cannot_serialize_failure - (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - fail (Reject (loc, v, get_log log)) - | Nop, stack -> - logged_return (stack, ctxt) - (* comparison *) - | Compare (Bool_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest - | Compare (String_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest - | Compare (Bytes_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest - | Compare (Mutez_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest - | Compare (Int_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest - | Compare (Nat_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest - | Compare (Key_hash_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Signature.Public_key_hash.compare - Interp_costs.compare_key_hash a b rest - | Compare (Timestamp_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest - | Compare (Address_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest - (* comparators *) - | Eq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres = 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Neq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <> 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Lt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres < 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Le, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Gt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres > 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Ge, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres >= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - (* packing *) - | Pack t, Item (value, rest) -> - Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> - logged_return (Item (bytes, rest), ctxt) - | Unpack t, Item (bytes, rest) -> - Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> - if Compare.Int.(MBytes.length bytes >= 1) && - Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then - let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in - match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with - | None -> + | Some r -> Some (q, r)), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt + | Lsl_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> + begin + match Script_int.shift_left_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some x -> logged_return (Item (x, rest), ctxt) + end + | Lsr_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> + begin + match Script_int.shift_right_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some r -> logged_return (Item (r, rest), ctxt) + end + | Or_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt + | And_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | And_int_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | Xor_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt + | Not_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + | Not_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + (* control *) + | Seq (hd, tl), stack -> + step ?log ctxt step_constants hd stack >>=? fun (trans, ctxt) -> + step ?log ctxt step_constants tl trans + | If (bt, _), Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bt rest + | If (_, bf), Item (false, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step ?log ctxt step_constants bf rest + | Loop body, Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step ?log ctxt step_constants body rest >>=? fun (trans, ctxt) -> + step ?log ctxt step_constants descr trans + | Loop _, Item (false, rest) -> + logged_return (rest, ctxt) + | Loop_left body, Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step ?log ctxt step_constants body (Item (v, rest)) >>=? fun (trans, ctxt) -> + step ?log ctxt step_constants descr trans + | Loop_left _, Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + | Dip b, Item (ign, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + step ?log ctxt step_constants b rest >>=? fun (res, ctxt) -> + logged_return (Item (ign, res), ctxt) + | Exec, Item (arg, Item (lam, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> + interp ?log ctxt step_constants lam arg >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Apply capture_ty, Item (capture, Item (lam, rest)) -> ( + Lwt.return (Gas.consume ctxt Interp_costs.apply) >>=? fun ctxt -> + let (Lam (descr, expr)) = lam in + let (Item_t (full_arg_ty , _ , _)) = descr.bef in + unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> + unparse_ty ctxt capture_ty >>=? fun (ty_expr, ctxt) -> + match full_arg_ty with + | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _, _) -> ( + let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in + let const_descr = ({ + loc = descr.loc ; + bef = arg_stack_ty ; + aft = Item_t (capture_ty, arg_stack_ty, None) ; + instr = Const capture ; + } : (_, _) descr) in + let pair_descr = ({ + loc = descr.loc ; + bef = Item_t (capture_ty, arg_stack_ty, None) ; + aft = Item_t (full_arg_ty, Empty_t, None) ; + instr = Cons_pair ; + } : (_, _) descr) in + let seq_descr = ({ + loc = descr.loc ; + bef = arg_stack_ty ; + aft = Item_t (full_arg_ty, Empty_t, None) ; + instr = Seq (const_descr, pair_descr) ; + } : (_, _) descr) in + let full_descr = ({ + loc = descr.loc ; + bef = arg_stack_ty ; + aft = descr.aft ; + instr = Seq (seq_descr, descr) ; + } : (_, _) descr) in + let full_expr = Micheline.Seq (0, [ + Prim (0, I_PUSH, [ ty_expr ; const_expr ], []) ; + Prim (0, I_PAIR, [], []) ; + expr ]) in + let lam' = Lam (full_descr, full_expr) in + logged_return (Item (lam', rest), ctxt) + ) + | _ -> assert false + ) + | Lambda lam, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (lam, rest), ctxt) + | Failwith tv, Item (v, _) -> + trace Cannot_serialize_failure + (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + fail (Reject (loc, v, get_log log)) + | Nop, stack -> + logged_return (stack, ctxt) + (* comparison *) + | Compare ty, Item (a, Item (b, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b)) >>=? fun ctxt -> + logged_return (Item (Script_int.of_int @@ Script_ir_translator.compare_comparable ty a b, rest), ctxt) + (* comparators *) + | Eq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres = 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Neq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <> 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Lt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres < 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Le, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Gt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres > 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Ge, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres >= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + (* packing *) + | Pack t, Item (value, rest) -> + Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> + logged_return (Item (bytes, rest), ctxt) + | Unpack t, Item (bytes, rest) -> + Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> + if Compare.Int.(MBytes.length bytes >= 1) && + Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then + let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in + match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Some expr -> + Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> + parse_data ctxt ~legacy:false t (Micheline.root expr) >>= function + | Ok (value, ctxt) -> + logged_return (Item (Some value, rest), ctxt) + | Error _ignored -> Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> logged_return (Item (None, rest), ctxt) - | Some expr -> - Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> - parse_data ctxt t (Micheline.root expr) >>= function - | Ok (value, ctxt) -> - logged_return (Item (Some value, rest), ctxt) - | Error _ignored -> - Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - else - logged_return (Item (None, rest), ctxt) - (* protocol *) - | Address, Item ((_, contract), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> - logged_return (Item (contract, rest), ctxt) - | Contract t, Item (contract, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> - Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) -> - logged_return (Item (maybe_contract, rest), ctxt) - | Transfer_tokens, - Item (p, Item (amount, Item ((tp, destination), rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> - unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> - let operation = - Transaction - { amount ; destination ; - parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) - | Create_account, - Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; manager ; delegate ; preorigination = Some contract ; - delegatable ; script = None ; spendable = true } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, - Item (contract, rest)), ctxt) - | Implicit_account, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> - let contract = Contract.implicit_contract key in - logged_return (Item ((Unit_t None, contract), rest), ctxt) - | Create_contract (storage_type, param_type, Lam (_, code)), - Item (manager, Item - (delegate, Item - (spendable, Item - (delegatable, Item - (credit, Item - (init, rest)))))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> - unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> - unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> - let code = - Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; - Prim (0, K_storage, [ unparsed_storage_type ], []) ; - Prim (0, K_code, [ Micheline.root code ], []) ])) in - unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> - let storage = Micheline.strip_locations storage in - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; manager ; delegate ; preorigination = Some contract ; - delegatable ; spendable ; - script = Some { code = Script.lazy_expr code ; - storage = Script.lazy_expr storage } } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return - (Item (Internal_operation { source = self ; operation ; nonce }, - Item (contract, rest)), ctxt) - | Set_delegate, - Item (delegate, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - let operation = Delegation delegate in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) - | Balance, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> - Contract.get_balance ctxt self >>=? fun balance -> - logged_return (Item (balance, rest), ctxt) - | Now, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> - let now = Script_timestamp.now ctxt in - logged_return (Item (now, rest), ctxt) - | Check_signature, Item (key, Item (signature, Item (message, rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt -> - let res = Signature.check key signature message in - logged_return (Item (res, rest), ctxt) - | Hash_key, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> - logged_return (Item (Signature.Public_key.hash key, rest), ctxt) - | Blake2b, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> - let hash = Raw_hashes.blake2b bytes in - logged_return (Item (hash, rest), ctxt) - | Sha256, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> - let hash = Raw_hashes.sha256 bytes in - logged_return (Item (hash, rest), ctxt) - | Sha512, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt -> - let hash = Raw_hashes.sha512 bytes in - logged_return (Item (hash, rest), ctxt) - | Steps_to_quota, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> - let steps = match Gas.level ctxt with - | Limited { remaining } -> remaining - | Unaccounted -> Z.of_string "99999999" in - logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) - | Source, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item (payer, rest), ctxt) - | Sender, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item (source, rest), ctxt) - | Self t, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> - logged_return (Item ((t,self), rest), ctxt) - | Amount, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> - logged_return (Item (amount, rest), ctxt) in + else + logged_return (Item (None, rest), ctxt) + (* protocol *) + | Address, Item ((_, address), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> + logged_return (Item (address, rest), ctxt) + | Contract (t, entrypoint), Item (contract, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> + begin match contract, entrypoint with + | (contract, "default"), entrypoint | (contract, entrypoint), "default" -> + Script_ir_translator.parse_contract_for_script + ~legacy:false ctxt loc t contract ~entrypoint >>=? fun (ctxt, maybe_contract) -> + logged_return (Item (maybe_contract, rest), ctxt) + | _ -> logged_return (Item (None, rest), ctxt) + end + | Transfer_tokens, + Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> + collect_big_maps ctxt tp p >>=? fun (to_duplicate, ctxt) -> + let to_update = no_big_map_id in + extract_big_map_diff ctxt Optimized tp p + ~to_duplicate ~to_update ~temporary:true >>=? fun (p, big_map_diff, ctxt) -> + unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> + let operation = + Transaction + { amount ; destination ; entrypoint ; + parameters = Script.lazy_expr (Micheline.strip_locations p) } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), rest), ctxt) + | Create_account, + Item (manager, Item (delegate, Item (_delegatable, Item (credit, rest)))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + (* store in optimized binary representation - as unparsed with [Optimized]. *) + let manager_bytes = + Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager in + let storage = + Script_repr.lazy_expr @@ Micheline.strip_locations @@ + Micheline.Bytes (0, manager_bytes) in + let script = + { code = Legacy_support.manager_script_code ; + storage ; + } in + let operation = + Origination + { credit ; delegate ; preorigination = Some contract ; script } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, None), + Item ((contract, "default"), rest)), ctxt) + | Implicit_account, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> + let contract = Contract.implicit_contract key in + logged_return (Item ((Unit_t None, (contract, "default")), rest), ctxt) + | Create_contract (storage_type, param_type, Lam (_, code), root_name), + Item (manager, Item + (delegate, Item + (spendable, Item + (delegatable, Item + (credit, Item + (init, rest)))))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> + unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> + let unparsed_param_type = + Script_ir_translator.add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None unparsed_param_type in + unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> + let code = + Script.lazy_expr @@ + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; + Prim (0, K_storage, [ unparsed_storage_type ], []) ; + Prim (0, K_code, [ code ], []) ])) in + collect_big_maps ctxt storage_type init >>=? fun (to_duplicate, ctxt) -> + let to_update = no_big_map_id in + extract_big_map_diff ctxt Optimized storage_type init + ~to_duplicate ~to_update ~temporary:true >>=? fun (init, big_map_diff, ctxt) -> + unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> + let storage = Script.lazy_expr @@ Micheline.strip_locations storage in + begin + if spendable then + Legacy_support.add_do ~manager_pkh:manager + ~script_code:code ~script_storage:storage + else if delegatable then + Legacy_support.add_set_delegate ~manager_pkh:manager + ~script_code:code ~script_storage:storage + else if Legacy_support.has_default_entrypoint code then + Legacy_support.add_root_entrypoint code >>=? fun code -> + return (code, storage) + else return (code, storage) + end >>=? fun (code, storage) -> + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; delegate ; preorigination = Some contract ; + script = { code ; storage } } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return + (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), + Item ((contract, "default"), rest)), ctxt) + | Create_contract_2 (storage_type, param_type, Lam (_, code), root_name), + (* Removed the instruction's arguments manager, spendable and delegatable *) + Item (delegate, Item + (credit, Item + (init, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> + unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> + let unparsed_param_type = + Script_ir_translator.add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None unparsed_param_type in + unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> + let code = + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; + Prim (0, K_storage, [ unparsed_storage_type ], []) ; + Prim (0, K_code, [ code ], []) ])) in + collect_big_maps ctxt storage_type init >>=? fun (to_duplicate, ctxt) -> + let to_update = no_big_map_id in + extract_big_map_diff ctxt Optimized storage_type init + ~to_duplicate ~to_update ~temporary:true >>=? fun (init, big_map_diff, ctxt) -> + unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> + let storage = Micheline.strip_locations storage in + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; delegate ; preorigination = Some contract ; + script = { code = Script.lazy_expr code ; + storage = Script.lazy_expr storage } } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return + (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), + Item ((contract, "default"), rest)), ctxt) + | Set_delegate, + Item (delegate, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + let operation = Delegation delegate in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, None), rest), ctxt) + | Balance, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> + Contract.get_balance ctxt step_constants.self >>=? fun balance -> + logged_return (Item (balance, rest), ctxt) + | Now, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> + let now = Script_timestamp.now ctxt in + logged_return (Item (now, rest), ctxt) + | Check_signature, Item (key, Item (signature, Item (message, rest))) -> + Lwt.return (Gas.consume ctxt (Interp_costs.check_signature key message)) >>=? fun ctxt -> + let res = Signature.check key signature message in + logged_return (Item (res, rest), ctxt) + | Hash_key, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> + logged_return (Item (Signature.Public_key.hash key, rest), ctxt) + | Blake2b, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash_blake2b bytes)) >>=? fun ctxt -> + let hash = Raw_hashes.blake2b bytes in + logged_return (Item (hash, rest), ctxt) + | Sha256, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha256 bytes)) >>=? fun ctxt -> + let hash = Raw_hashes.sha256 bytes in + logged_return (Item (hash, rest), ctxt) + | Sha512, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha512 bytes)) >>=? fun ctxt -> + let hash = Raw_hashes.sha512 bytes in + logged_return (Item (hash, rest), ctxt) + | Steps_to_quota, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> + let steps = match Gas.level ctxt with + | Limited { remaining } -> remaining + | Unaccounted -> Z.of_string "99999999" in + logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) + | Source, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item ((step_constants.payer, "default"), rest), ctxt) + | Sender, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item ((step_constants.source, "default"), rest), ctxt) + | Self (t, entrypoint), rest -> + Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> + logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt) + | Amount, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> + logged_return (Item (step_constants.amount, rest), ctxt) + | Dig (n, n'), stack -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> + interp_stack_prefix_preserving_operation (fun (Item (v, rest)) -> return (rest, v)) n' stack + >>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt) + | Dug (n, n'), Item (v, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> + interp_stack_prefix_preserving_operation (fun stk -> return (Item (v, stk), ())) n' rest + >>=? fun (aft, ()) -> logged_return (aft, ctxt) + | Dipn (n, n', b), stack -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> + interp_stack_prefix_preserving_operation (fun stk -> + step ?log ctxt step_constants b stk >>=? fun (res, ctxt') -> + return (res, ctxt')) n' stack + >>=? fun (aft, ctxt') -> logged_return (aft, ctxt') + | Dropn (n, n'), stack -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> + interp_stack_prefix_preserving_operation (fun stk -> return (stk, stk)) n' stack + >>=? fun (_, rest) -> logged_return (rest, ctxt) + | ChainId, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.chain_id) >>=? fun ctxt -> + logged_return (Item (step_constants.chain_id, rest), ctxt) + +and interp + : type p r. + (?log: execution_trace ref -> + context -> + step_constants -> (p, r) lambda -> p -> + (r * context) tzresult Lwt.t) + = fun ?log ctxt step_constants (Lam (code, _)) arg -> let stack = (Item (arg, Empty)) in begin match log with | None -> return_unit @@ -837,28 +978,40 @@ let rec interp log := (code.loc, Gas.level ctxt, stack) :: !log ; return_unit end >>=? fun () -> - step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) -> + step ?log ctxt step_constants code stack >>=? fun (Item (ret, Empty), ctxt) -> return (ret, ctxt) (* ---- contract handling ---------------------------------------------------*) -and execute ?log ctxt mode ~source ~payer ~self script amount arg : - (Script.expr * packed_internal_operation list * context * - Script_typed_ir.ex_big_map option) tzresult Lwt.t = - parse_script ctxt script - >>=? fun ((Ex_script { code ; arg_type ; storage ; storage_type }), ctxt) -> +and execute ?log ctxt mode step_constants ~entrypoint unparsed_script arg : + (Script.expr * packed_internal_operation list * context * Contract.big_map_diff option) tzresult Lwt.t = + parse_script ctxt unparsed_script ~legacy:true + >>=? fun (Ex_script { code ; arg_type ; storage ; storage_type ; root_name }, ctxt) -> + trace + (Bad_contract_parameter step_constants.self) + (Lwt.return (find_entrypoint arg_type ~root_name entrypoint)) >>=? fun (box, _) -> trace - (Bad_contract_parameter self) - (parse_data ctxt arg_type arg) >>=? fun (arg, ctxt) -> - Script.force_decode ctxt script.code >>=? fun (script_code, ctxt) -> + (Bad_contract_parameter step_constants.self) + (parse_data ctxt ~legacy:false arg_type (box arg)) >>=? fun (arg, ctxt) -> + Script.force_decode ctxt unparsed_script.code >>=? fun (script_code, ctxt) -> + Script_ir_translator.collect_big_maps ctxt arg_type arg >>=? fun (to_duplicate, ctxt) -> + Script_ir_translator.collect_big_maps ctxt storage_type storage >>=? fun (to_update, ctxt) -> trace - (Runtime_contract_error (self, script_code)) - (interp ?log ctxt ~source ~payer ~self amount code (arg, storage)) - >>=? fun ((ops, sto), ctxt) -> + (Runtime_contract_error (step_constants.self, script_code)) + (interp ?log ctxt step_constants code (arg, storage)) + >>=? fun ((ops, storage), ctxt) -> + Script_ir_translator.extract_big_map_diff ctxt mode + ~temporary:false ~to_duplicate ~to_update storage_type storage + >>=? fun (storage, big_map_diff, ctxt) -> trace Cannot_serialize_storage - (unparse_data ctxt mode storage_type sto) >>=? fun (storage, ctxt) -> - return (Micheline.strip_locations storage, ops, ctxt, - Script_ir_translator.extract_big_map storage_type sto) + (unparse_data ctxt mode storage_type storage) >>=? fun (storage, ctxt) -> + let ops, op_diffs = List.split ops in + let big_map_diff = match + List.flatten (List.map (Option.unopt ~default:[]) (op_diffs @ [ big_map_diff ])) + with + | [] -> None + | diff -> Some diff in + return (Micheline.strip_locations storage, ops, ctxt, big_map_diff) type execution_result = { ctxt : context ; @@ -866,26 +1019,14 @@ type execution_result = big_map_diff : Contract.big_map_diff option ; operations : packed_internal_operation list } -let trace ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount = +let trace ctxt mode step_constants ~script ~entrypoint ~parameter = let log = ref [] in - execute ~log ctxt mode ~source ~payer ~self script amount (Micheline.root parameter) - >>=? fun (storage, operations, ctxt, big_map) -> - begin match big_map with - | None -> return (None, ctxt) - | Some big_map -> - Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) -> - return (Some big_map_diff, ctxt) - end >>=? fun (big_map_diff, ctxt) -> + execute ~log ctxt mode step_constants ~entrypoint script (Micheline.root parameter) + >>=? fun (storage, operations, ctxt, big_map_diff) -> let trace = List.rev !log in return ({ ctxt ; storage ; big_map_diff ; operations }, trace) -let execute ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount = - execute ctxt mode ~source ~payer ~self script amount (Micheline.root parameter) - >>=? fun (storage, operations, ctxt, big_map) -> - begin match big_map with - | None -> return (None, ctxt) - | Some big_map -> - Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) -> - return (Some big_map_diff, ctxt) - end >>=? fun (big_map_diff, ctxt) -> +let execute ctxt mode step_constants ~script ~entrypoint ~parameter = + execute ctxt mode step_constants ~entrypoint script (Micheline.root parameter) + >>=? fun (storage, operations, ctxt, big_map_diff) -> return { ctxt ; storage ; big_map_diff ; operations } diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index af616319bb562324c3aca7345e7b4580fe0acd8c..7d583d37ab2f772a86fb4d938f8ca93ea8fd5ae4 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -42,22 +42,38 @@ type execution_result = big_map_diff : Contract.big_map_diff option ; operations : packed_internal_operation list } +type step_constants = + { source : Contract.t ; + payer : Contract.t ; + self : Contract.t ; + amount : Tez.t ; + chain_id : Chain_id.t } + +type 'tys stack = + | Item : 'ty * 'rest stack -> ('ty * 'rest) stack + | Empty : Script_typed_ir.end_of_stack stack + +val step: + ?log: execution_trace ref -> + context -> step_constants -> + ('bef, 'aft) Script_typed_ir.descr -> + 'bef stack -> + ('aft stack * context) tzresult Lwt.t + val execute: Alpha_context.t -> Script_ir_translator.unparsing_mode -> - source: Contract.t -> - payer: Contract.t -> - self: (Contract.t * Script.t) -> + step_constants -> + script: Script.t -> + entrypoint: string -> parameter: Script.expr -> - amount: Tez.t -> execution_result tzresult Lwt.t val trace: Alpha_context.t -> Script_ir_translator.unparsing_mode -> - source: Contract.t -> - payer: Contract.t -> - self: (Contract.t * Script.t) -> + step_constants -> + script: Script.t -> + entrypoint: string -> parameter: Script.expr -> - amount: Tez.t -> (execution_result * execution_trace) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 57c0af937f9d69790e892681a96eef3694db35af..33660d98e1f254261e595639bf30371e760cfc32 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -101,26 +101,26 @@ let gen_access_annot Some (`Var_annot (String.concat "." [v; f])) let merge_type_annot - : type_annot option -> type_annot option -> type_annot option tzresult - = fun annot1 annot2 -> + : legacy: bool -> type_annot option -> type_annot option -> type_annot option tzresult + = fun ~legacy annot1 annot2 -> match annot1, annot2 with | None, None | Some _, None | None, Some _ -> ok None | Some `Type_annot a1, Some `Type_annot a2 -> - if String.equal a1 a2 + if legacy || String.equal a1 a2 then ok annot1 else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2)) let merge_field_annot - : field_annot option -> field_annot option -> field_annot option tzresult - = fun annot1 annot2 -> + : legacy: bool -> field_annot option -> field_annot option -> field_annot option tzresult + = fun ~legacy annot1 annot2 -> match annot1, annot2 with | None, None | Some _, None | None, Some _ -> ok None | Some `Field_annot a1, Some `Field_annot a2 -> - if String.equal a1 a2 + if legacy || String.equal a1 a2 then ok annot1 else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2)) @@ -257,26 +257,6 @@ let parse_composed_type_annot get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2) -let check_const_type_annot - : int -> string list -> type_annot option -> field_annot option list -> unit tzresult Lwt.t - = fun loc annot expected_name expected_fields -> - Lwt.return - (parse_composed_type_annot loc annot >>? fun (ty_name, field1, field2) -> - merge_type_annot expected_name ty_name >>? fun _ -> - match expected_fields, field1, field2 with - | [], Some _, _ | [], _, Some _ | [_], Some _, Some _ -> - (* Too many annotations *) - error (Unexpected_annotation loc) - | _ :: _ :: _ :: _, _, _ | [_], None, Some _ -> - error (Unexpected_annotation loc) - | [], None, None -> ok () - | [ f1; f2 ], _, _ -> - merge_field_annot f1 field1 >>? fun _ -> - merge_field_annot f2 field2 >|? fun _ -> () - | [ f1 ], _, None -> - merge_field_annot f1 field1 >|? fun _ -> () - ) - let parse_field_annot : int -> string list -> field_annot option tzresult = fun loc annot -> @@ -290,12 +270,18 @@ let extract_field_annot : Script.node -> (Script.node * field_annot option) tzresult = function | Prim (loc, prim, args, annot) -> - let field_annots, annot = List.partition (fun s -> - Compare.Int.(String.length s > 0) && - Compare.Char.(s.[0] = '%') - ) annot in - parse_field_annot loc field_annots >|? fun field_annot -> - Prim (loc, prim, args, annot), field_annot + let rec extract_first acc = function + | [] -> None, annot + | s :: rest -> + if Compare.Int.(String.length s > 0) && + Compare.Char.(s.[0] = '%') then + Some s, List.rev_append acc rest + else extract_first (s :: acc) rest in + let field_annot, annot = extract_first [] annot in + let field_annot = match field_annot with + | None -> None + | Some field_annot -> Some (`Field_annot (String.sub field_annot 1 (String.length field_annot - 1))) in + ok (Prim (loc, prim, args, annot), field_annot) | expr -> ok (expr, None) let check_correct_field @@ -402,6 +388,19 @@ let parse_destr_annot | None -> value_annot in (v, f) +let parse_entrypoint_annot + : int -> ?default:var_annot option -> string list -> (var_annot option * field_annot option) tzresult + = fun loc ?default annot -> + parse_annots loc annot >>? + classify_annot loc >>? fun (vars, types, fields) -> + error_unexpected_annot loc types >>? fun () -> + get_one_annot loc fields >>? fun f -> + get_one_annot loc vars >|? function + | Some _ as a -> (a, f) + | None -> match default with + | Some a -> (a, f) + | None -> (None, f) + let parse_var_type_annot : int -> string list -> (var_annot option * type_annot option) tzresult = fun loc annot -> diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index 0ad19733a937c7709427ea5d3f30e1e579a5db18..7ac4701391aa1de1c9b599413d8ce29bf42cc981 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -72,28 +72,28 @@ val var_to_field_annot : var_annot option -> field_annot option (** Replace an annotation by its default value if it is [None] *) val default_annot : default:'a option -> 'a option -> 'a option -(** Generate annotation for field accesses, of the form @var.field1.field2 *) +(** Generate annotation for field accesses, of the form [var.field1.field2] *) val gen_access_annot : var_annot option -> ?default:field_annot option -> field_annot option -> var_annot option (** Merge type annotations. - @returns an error {!Inconsistent_type_annotations} if they are both present - and different *) + @return an error {!Inconsistent_type_annotations} if they are both present + and different, unless [legacy] *) val merge_type_annot : - type_annot option -> type_annot option -> type_annot option tzresult + legacy: bool -> type_annot option -> type_annot option -> type_annot option tzresult (** Merge field annotations. - @returns an error {!Inconsistent_type_annotations} if they are both present - and different *) + @return an error {!Inconsistent_type_annotations} if they are both present + and different, unless [legacy] *) val merge_field_annot : - field_annot option -> field_annot option -> field_annot option tzresult + legacy: bool -> field_annot option -> field_annot option -> field_annot option tzresult (** Merge variable annotations, does not fail ([None] if different). *) val merge_var_annot : var_annot option -> var_annot option -> var_annot option -(** @returns an error {!Unexpected_annotation} in the monad the list is not empty. *) +(** @return an error {!Unexpected_annotation} in the monad the list is not empty. *) val error_unexpected_annot : int -> 'a list -> unit tzresult (** Same as {!error_unexpected_annot} in Lwt. *) @@ -117,11 +117,6 @@ val parse_composed_type_annot : int -> string list -> (type_annot option * field_annot option * field_annot option) tzresult -(** Check that type annotations on constants are consistent *) -val check_const_type_annot : - int -> string list -> type_annot option -> field_annot option list -> - unit tzresult Lwt.t - (** Extract and remove a field annotation from a node *) val extract_field_annot : Script.node -> (Script.node * field_annot option) tzresult @@ -157,5 +152,11 @@ val parse_destr_annot : value_annot:var_annot option -> (var_annot option * field_annot option) tzresult +val parse_entrypoint_annot : + int -> + ?default:var_annot option -> + string list -> + (var_annot option * field_annot option) tzresult + val parse_var_type_annot : int -> string list -> (var_annot option * type_annot option) tzresult diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 7deac792051aab56fa9478a5e7ee15f801cb3fa3..b73d610ba73fe17b3dff5019f0bdcde760be41c1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -40,7 +40,8 @@ type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty type tc_context = | Lambda : tc_context | Dip : 'a stack_ty * tc_context -> tc_context - | Toplevel : { storage_type : 'sto ty ; param_type : 'param ty } -> tc_context + | Toplevel : { storage_type : 'sto ty ; param_type : 'param ty ; root_name : string option ; + legacy_create_contract_literal : bool } -> tc_context type unparsing_mode = Optimized | Readable @@ -54,8 +55,7 @@ let add_dip ty annot prev = (* ---- Type size accounting ------------------------------------------------*) -(* TODO include annot in size ? *) -let comparable_type_size : type t. t comparable_ty -> int = fun ty -> +let rec comparable_type_size : type t a. (t, a) comparable_struct -> int = fun ty -> (* No wildcard to force the update when comparable_ty chages. *) match ty with | Int_key _ -> 1 @@ -67,8 +67,8 @@ let comparable_type_size : type t. t comparable_ty -> int = fun ty -> | Key_hash_key _ -> 1 | Timestamp_key _ -> 1 | Address_key _ -> 1 + | Pair_key (_, (t, _), _) -> 1 + comparable_type_size t -(* TODO include annot in size ? *) let rec type_size : type t. t ty -> int = fun ty -> match ty with | Unit_t _ -> 1 @@ -84,24 +84,25 @@ let rec type_size : type t. t ty -> int = | Address_t _ -> 1 | Bool_t _ -> 1 | Operation_t _ -> 1 - | Pair_t ((l, _, _), (r, _, _), _) -> + | Pair_t ((l, _, _), (r, _, _), _, _) -> 1 + type_size l + type_size r - | Union_t ((l, _), (r, _), _) -> + | Union_t ((l, _), (r, _), _, _) -> 1 + type_size l + type_size r | Lambda_t (arg, ret, _) -> 1 + type_size arg + type_size ret - | Option_t ((t,_), _, _) -> + | Option_t (t, _, _) -> 1 + type_size t - | List_t (t, _) -> + | List_t (t, _, _) -> 1 + type_size t | Set_t (k, _) -> 1 + comparable_type_size k - | Map_t (k, v, _) -> + | Map_t (k, v, _, _) -> 1 + comparable_type_size k + type_size v | Big_map_t (k, v, _) -> 1 + comparable_type_size k + type_size v | Contract_t (arg, _) -> 1 + type_size arg + | Chain_id_t _ -> 1 let rec type_size_of_stack_head : type st. st stack_ty -> up_to:int -> int @@ -152,6 +153,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Map_get -> 0 | Map_update -> 0 | Map_size -> 0 + | Empty_big_map _ -> 1 | Big_map_get -> 0 | Big_map_update -> 0 | Big_map_mem -> 0 @@ -209,6 +211,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Loop_left _ -> 0 | Dip _ -> 0 | Exec -> 0 + | Apply _ -> 0 | Lambda _ -> 1 | Failwith _ -> 1 | Nop -> 0 @@ -225,6 +228,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Create_account -> 0 | Implicit_account -> 0 | Create_contract _ -> 1 + | Create_contract_2 _ -> 1 | Now -> 0 | Balance -> 0 | Check_signature -> 0 @@ -240,6 +244,11 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Set_delegate -> 0 | Pack _ -> 0 | Unpack _ -> 1 + | Dig _ -> 0 + | Dug _ -> 0 + | Dipn _ -> 0 + | Dropn _ -> 0 + | ChainId -> 0 (* ---- Error helpers -------------------------------------------------------*) @@ -282,6 +291,7 @@ let namespace = function | I_BALANCE | I_CAR | I_CDR + | I_CHAIN_ID | I_CHECK_SIGNATURE | I_COMPARE | I_CONCAT @@ -293,10 +303,12 @@ let namespace = function | I_DROP | I_DUP | I_EDIV + | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC + | I_APPLY | I_FAILWITH | I_GE | I_GET @@ -347,7 +359,9 @@ let namespace = function | I_CONTRACT | I_ISNAT | I_CAST - | I_RENAME -> Instr_namespace + | I_RENAME + | I_DIG + | I_DUG -> Instr_namespace | T_bool | T_contract | T_int @@ -369,7 +383,8 @@ let namespace = function | T_timestamp | T_unit | T_operation - | T_address -> Type_namespace + | T_address + | T_chain_id -> Type_namespace let unexpected expr exp_kinds exp_ns exp_prims = @@ -397,26 +412,35 @@ let check_kind kinds expr = (* ---- Sets and Maps -------------------------------------------------------*) -let compare_comparable - : type a. a comparable_ty -> a -> a -> int - = fun kind x y -> match kind with - | String_key _ -> Compare.String.compare x y - | Bool_key _ -> Compare.Bool.compare x y - | Mutez_key _ -> Tez.compare x y - | Key_hash_key _ -> Signature.Public_key_hash.compare x y - | Int_key _ -> - let res = (Script_int.compare x y) in - if Compare.Int.(res = 0) then 0 - else if Compare.Int.(res > 0) then 1 - else -1 - | Nat_key _ -> - let res = (Script_int.compare x y) in - if Compare.Int.(res = 0) then 0 - else if Compare.Int.(res > 0) then 1 - else -1 - | Timestamp_key _ -> Script_timestamp.compare x y - | Address_key _ -> Contract.compare x y - | Bytes_key _ -> MBytes.compare x y +let wrap_compare compare a b = + let res = compare a b in + if Compare.Int.(res = 0) then 0 + else if Compare.Int.(res > 0) then 1 + else -1 + +let rec compare_comparable + : type a s. (a, s) comparable_struct -> a -> a -> int + = fun kind -> match kind with + | String_key _ -> wrap_compare Compare.String.compare + | Bool_key _ -> wrap_compare Compare.Bool.compare + | Mutez_key _ -> wrap_compare Tez.compare + | Key_hash_key _ -> wrap_compare Signature.Public_key_hash.compare + | Int_key _ -> wrap_compare Script_int.compare + | Nat_key _ -> wrap_compare Script_int.compare + | Timestamp_key _ -> wrap_compare Script_timestamp.compare + | Address_key _ -> + wrap_compare @@ fun (x, ex) (y, ey) -> + let lres = Contract.compare x y in + if Compare.Int.(lres = 0) then + Compare.String.compare ex ey + else lres + | Bytes_key _ -> wrap_compare MBytes.compare + | Pair_key ((tl, _), (tr, _), _) -> + fun (lx, rx) (ly, ry) -> + let lres = compare_comparable tl lx ly in + if Compare.Int.(lres = 0) then + compare_comparable tr rx ry + else lres let empty_set : type a. a comparable_ty -> a set @@ -427,6 +451,7 @@ let empty_set end) in (module struct type elt = a + let elt_ty = ty module OPS = OPS let boxed = OPS.empty let size = 0 @@ -437,6 +462,7 @@ let set_update = fun v b (module Box) -> (module struct type elt = a + let elt_ty = Box.elt_ty module OPS = Box.OPS let boxed = if b @@ -534,8 +560,8 @@ let map_size (* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*) -let ty_of_comparable_ty - : type a. a comparable_ty -> a ty +let rec ty_of_comparable_ty + : type a s. (a, s) comparable_struct -> a ty = function | Int_key tname -> Int_t tname | Nat_key tname -> Nat_t tname @@ -546,9 +572,47 @@ let ty_of_comparable_ty | Key_hash_key tname -> Key_hash_t tname | Timestamp_key tname -> Timestamp_t tname | Address_key tname -> Address_t tname + | Pair_key ((l, al), (r, ar), tname) -> + Pair_t ((ty_of_comparable_ty l, al, None), (ty_of_comparable_ty r, ar, None), tname, false) -let unparse_comparable_ty - : type a. a comparable_ty -> Script.node +let rec comparable_ty_of_ty + : type a. a ty -> a comparable_ty option + = function + | Int_t tname -> Some (Int_key tname) + | Nat_t tname -> Some (Nat_key tname) + | String_t tname -> Some (String_key tname) + | Bytes_t tname -> Some (Bytes_key tname) + | Mutez_t tname -> Some (Mutez_key tname) + | Bool_t tname -> Some (Bool_key tname) + | Key_hash_t tname -> Some (Key_hash_key tname) + | Timestamp_t tname -> Some (Timestamp_key tname) + | Address_t tname -> Some (Address_key tname) + | Pair_t ((l, al, _), (r, ar, _), pname, _) -> + begin match comparable_ty_of_ty r with + | None -> None + | Some rty -> + match comparable_ty_of_ty l with + | None -> None + | Some (Pair_key _) -> None (* not a comb *) + | Some (Int_key tname) -> Some (Pair_key ((Int_key tname, al), (rty, ar), pname)) + | Some (Nat_key tname) -> Some (Pair_key ((Nat_key tname, al), (rty, ar), pname)) + | Some (String_key tname) -> Some (Pair_key ((String_key tname, al), (rty, ar), pname)) + | Some (Bytes_key tname) -> Some (Pair_key ((Bytes_key tname, al), (rty, ar), pname)) + | Some (Mutez_key tname) -> Some (Pair_key ((Mutez_key tname, al), (rty, ar), pname)) + | Some (Bool_key tname) -> Some (Pair_key ((Bool_key tname, al), (rty, ar), pname)) + | Some (Key_hash_key tname) -> Some (Pair_key ((Key_hash_key tname, al), (rty, ar), pname)) + | Some (Timestamp_key tname) -> Some (Pair_key ((Timestamp_key tname, al), (rty, ar), pname)) + | Some (Address_key tname) -> Some (Pair_key ((Address_key tname, al), (rty, ar), pname)) + end + | _ -> None + +let add_field_annot a var = function + | Prim (loc, prim, args, annots) -> + Prim (loc, prim, args, annots @ unparse_field_annot a @ unparse_var_annot var ) + | expr -> expr + +let rec unparse_comparable_ty + : type a s. (a, s) comparable_struct -> Script.node = function | Int_key tname -> Prim (-1, T_int, [], unparse_type_annot tname) | Nat_key tname -> Prim (-1, T_nat, [], unparse_type_annot tname) @@ -559,11 +623,10 @@ let unparse_comparable_ty | Key_hash_key tname -> Prim (-1, T_key_hash, [], unparse_type_annot tname) | Timestamp_key tname -> Prim (-1, T_timestamp, [], unparse_type_annot tname) | Address_key tname -> Prim (-1, T_address, [], unparse_type_annot tname) - -let add_field_annot a var = function - | Prim (loc, prim, args, annots) -> - Prim (loc, prim, args, annots @ unparse_field_annot a @ unparse_var_annot var ) - | expr -> expr + | Pair_key ((l, al), (r, ar), pname) -> + let tl = add_field_annot al None (unparse_comparable_ty l) in + let tr = add_field_annot ar None (unparse_comparable_ty r) in + Prim (-1, T_pair, [ tl ; tr ], unparse_type_annot pname) let rec unparse_ty_no_lwt : type a. context -> a ty -> (Script.node * context) tzresult @@ -587,17 +650,18 @@ let rec unparse_ty_no_lwt | Address_t tname -> return ctxt (T_address, [], unparse_type_annot tname) | Signature_t tname -> return ctxt (T_signature, [], unparse_type_annot tname) | Operation_t tname -> return ctxt (T_operation, [], unparse_type_annot tname) + | Chain_id_t tname -> return ctxt (T_chain_id, [], unparse_type_annot tname) | Contract_t (ut, tname) -> unparse_ty_no_lwt ctxt ut >>? fun (t, ctxt) -> return ctxt (T_contract, [ t ], unparse_type_annot tname) - | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname) -> + | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname, _) -> let annot = unparse_type_annot tname in unparse_ty_no_lwt ctxt utl >>? fun (utl, ctxt) -> let tl = add_field_annot l_field l_var utl in unparse_ty_no_lwt ctxt utr >>? fun (utr, ctxt) -> let tr = add_field_annot r_field r_var utr in return ctxt (T_pair, [ tl; tr ], annot) - | Union_t ((utl, l_field), (utr, r_field), tname) -> + | Union_t ((utl, l_field), (utr, r_field), tname, _) -> let annot = unparse_type_annot tname in unparse_ty_no_lwt ctxt utl >>? fun (utl, ctxt) -> let tl = add_field_annot l_field None utl in @@ -608,18 +672,17 @@ let rec unparse_ty_no_lwt unparse_ty_no_lwt ctxt uta >>? fun (ta, ctxt) -> unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> return ctxt (T_lambda, [ ta; tr ], unparse_type_annot tname) - | Option_t ((ut, some_field), _none_field, tname) -> + | Option_t (ut, tname, _) -> let annot = unparse_type_annot tname in unparse_ty_no_lwt ctxt ut >>? fun (ut, ctxt) -> - let t = add_field_annot some_field None ut in - return ctxt (T_option, [ t ], annot) - | List_t (ut, tname) -> + return ctxt (T_option, [ ut ], annot) + | List_t (ut, tname, _) -> unparse_ty_no_lwt ctxt ut >>? fun (t, ctxt) -> return ctxt (T_list, [ t ], unparse_type_annot tname) | Set_t (ut, tname) -> let t = unparse_comparable_ty ut in return ctxt (T_set, [ t ], unparse_type_annot tname) - | Map_t (uta, utr, tname) -> + | Map_t (uta, utr, tname, _) -> let ta = unparse_comparable_ty uta in unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> return ctxt (T_map, [ ta; tr ], unparse_type_annot tname) @@ -671,14 +734,15 @@ let name_of_ty | Address_t tname -> tname | Signature_t tname -> tname | Operation_t tname -> tname + | Chain_id_t tname -> tname | Contract_t (_, tname) -> tname - | Pair_t (_, _, tname) -> tname - | Union_t (_, _, tname) -> tname + | Pair_t (_, _, tname, _) -> tname + | Union_t (_, _, tname, _) -> tname | Lambda_t (_, _, tname) -> tname - | Option_t (_, _, tname) -> tname - | List_t (_, tname) -> tname + | Option_t (_, tname, _) -> tname + | List_t (_, tname, _) -> tname | Set_t (_, tname) -> tname - | Map_t (_, _, tname) -> tname + | Map_t (_, _, tname, _) -> tname | Big_map_t (_, _, tname) -> tname (* ---- Equality witnesses --------------------------------------------------*) @@ -736,10 +800,11 @@ let rec ty_eq | Signature_t _, Signature_t _ -> ok Eq ctxt 0 | Mutez_t _, Mutez_t _ -> ok Eq ctxt 0 | Timestamp_t _, Timestamp_t _ -> ok Eq ctxt 0 + | Chain_id_t _, Chain_id_t _ -> ok Eq ctxt 0 | Address_t _, Address_t _ -> ok Eq ctxt 0 | Bool_t _, Bool_t _ -> ok Eq ctxt 0 | Operation_t _, Operation_t _ -> ok Eq ctxt 0 - | Map_t (tal, tar, _), Map_t (tbl, tbr, _) -> + | Map_t (tal, tar, _, _), Map_t (tbl, tbr, _, _) -> (comparable_ty_eq ctxt tal tbl >>? fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> (ok Eq ctxt 2)) |> @@ -753,13 +818,14 @@ let rec ty_eq (comparable_ty_eq ctxt ea eb >>? fun Eq -> (ok Eq ctxt 1)) |> record_inconsistent ctxt ta tb - | Pair_t ((tal, _, _), (tar, _, _), _), - Pair_t ((tbl, _, _), (tbr, _, _), _) -> + | Pair_t ((tal, _, _), (tar, _, _), _, _), + Pair_t ((tbl, _, _), (tbr, _, _), _, _) -> (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> (ok Eq ctxt 2)) |> record_inconsistent ctxt ta tb - | Union_t ((tal, _), (tar, _), _), Union_t ((tbl, _), (tbr, _), _) -> + | Union_t ((tal, _), (tar, _), _, _), + Union_t ((tbl, _), (tbr, _), _, _) -> (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> (ok Eq ctxt 2)) |> @@ -773,11 +839,11 @@ let rec ty_eq (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> (ok Eq ctxt 1)) |> record_inconsistent ctxt ta tb - | Option_t ((tva, _), _, _), Option_t ((tvb, _), _, _) -> + | Option_t (tva, _, _), Option_t (tvb, _, _) -> (ty_eq ctxt tva tvb >>? fun (Eq, ctxt) -> (ok Eq ctxt 1)) |> record_inconsistent ctxt ta tb - | List_t (tva, _), List_t (tvb, _) -> + | List_t (tva, _, _), List_t (tvb, _, _) -> (ty_eq ctxt tva tvb >>? fun (Eq, ctxt) -> (ok Eq ctxt 1)) |> record_inconsistent ctxt ta tb @@ -800,154 +866,148 @@ let rec stack_ty_eq | _, _ -> error Bad_stack_length let merge_comparable_types - : type ta. ta comparable_ty -> ta comparable_ty -> ta comparable_ty tzresult - = fun ta tb -> + : type ta. legacy: bool -> ta comparable_ty -> ta comparable_ty -> ta comparable_ty tzresult + = fun ~legacy ta tb -> match ta, tb with | Int_key annot_a, Int_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Int_key annot | Nat_key annot_a, Nat_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Nat_key annot | String_key annot_a, String_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> String_key annot | Bytes_key annot_a, Bytes_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bytes_key annot | Mutez_key annot_a, Mutez_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Mutez_key annot | Bool_key annot_a, Bool_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bool_key annot | Key_hash_key annot_a, Key_hash_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Key_hash_key annot | Timestamp_key annot_a, Timestamp_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Timestamp_key annot | Address_key annot_a, Address_key annot_b -> - merge_type_annot annot_a annot_b >|? fun annot -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Address_key annot | _, _ -> assert false (* FIXME: fix injectivity of some types *) -let rec strip_annotations = function - | (Int (_,_) as i) -> i - | (String (_,_) as s) -> s - | (Bytes (_,_) as s) -> s - | Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, []) - | Seq (loc, items) -> Seq (loc, List.map strip_annotations items) - let merge_types : - type b. context -> Script.location -> b ty -> b ty -> (b ty * context) tzresult = + type b. legacy: bool -> context -> Script.location -> b ty -> b ty -> (b ty * context) tzresult = fun ~legacy -> let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult = fun ctxt ty1 ty2 -> match ty1, ty2 with | Unit_t tn1, Unit_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Unit_t tname, ctxt | Int_t tn1, Int_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Int_t tname, ctxt | Nat_t tn1, Nat_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Nat_t tname, ctxt | Key_t tn1, Key_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Key_t tname, ctxt | Key_hash_t tn1, Key_hash_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Key_hash_t tname, ctxt | String_t tn1, String_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> String_t tname, ctxt | Bytes_t tn1, Bytes_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Bytes_t tname, ctxt | Signature_t tn1, Signature_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Signature_t tname, ctxt | Mutez_t tn1, Mutez_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Mutez_t tname, ctxt | Timestamp_t tn1, Timestamp_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Timestamp_t tname, ctxt | Address_t tn1, Address_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Address_t tname, ctxt | Bool_t tn1, Bool_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Bool_t tname, ctxt + | Chain_id_t tn1, Chain_id_t tn2 -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> + Chain_id_t tname, ctxt | Operation_t tn1, Operation_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> Operation_t tname, ctxt - | Map_t (tal, tar, tn1), Map_t (tbl, tbr, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + | Map_t (tal, tar, tn1, has_big_map), Map_t (tbl, tbr, tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tar tbr >>? fun (value, ctxt) -> ty_eq ctxt tar value >>? fun (Eq, ctxt) -> - merge_comparable_types tal tbl >|? fun tk -> - Map_t (tk, value, tname), ctxt + merge_comparable_types ~legacy tal tbl >|? fun tk -> + Map_t (tk, value, tname, has_big_map), ctxt | Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tar tbr >>? fun (value, ctxt) -> ty_eq ctxt tar value >>? fun (Eq, ctxt) -> - merge_comparable_types tal tbl >|? fun tk -> + merge_comparable_types ~legacy tal tbl >|? fun tk -> Big_map_t (tk, value, tname), ctxt | Set_t (ea, tn1), Set_t (eb, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_comparable_types ea eb >|? fun e -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> + merge_comparable_types ~legacy ea eb >|? fun e -> Set_t (e, tname), ctxt - | Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1), - Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_field_annot l_field1 l_field2 >>? fun l_field -> - merge_field_annot r_field1 r_field2 >>? fun r_field -> + | Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1, has_big_map), + Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> + merge_field_annot ~legacy l_field1 l_field2 >>? fun l_field -> + merge_field_annot ~legacy r_field1 r_field2 >>? fun r_field -> let l_var = merge_var_annot l_var1 l_var2 in let r_var = merge_var_annot r_var1 r_var2 in help ctxt tal tbl >>? fun (left_ty, ctxt) -> help ctxt tar tbr >|? fun (right_ty, ctxt) -> - Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname), + Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname, has_big_map), ctxt - | Union_t ((tal, tal_annot), (tar, tar_annot), tn1), - Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_field_annot tal_annot tbl_annot >>? fun left_annot -> - merge_field_annot tar_annot tbr_annot >>? fun right_annot -> + | Union_t ((tal, tal_annot), (tar, tar_annot), tn1, has_big_map), + Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> + merge_field_annot ~legacy tal_annot tbl_annot >>? fun left_annot -> + merge_field_annot ~legacy tar_annot tbr_annot >>? fun right_annot -> help ctxt tal tbl >>? fun (left_ty, ctxt) -> help ctxt tar tbr >|? fun (right_ty, ctxt) -> - Union_t ((left_ty, left_annot), (right_ty, right_annot), tname), + Union_t ((left_ty, left_annot), (right_ty, right_annot), tname, has_big_map), ctxt | Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tal tbl >>? fun (left_ty, ctxt) -> help ctxt tar tbr >|? fun (right_ty, ctxt) -> Lambda_t (left_ty, right_ty, tname), ctxt | Contract_t (tal, tn1), Contract_t (tbl, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tal tbl >|? fun (arg_ty, ctxt) -> Contract_t (arg_ty, tname), ctxt - | Option_t ((tva, some_annot_a), none_annot_a, tn1), - Option_t ((tvb, some_annot_b), none_annot_b, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_field_annot some_annot_a some_annot_b >>? fun some_annot -> - merge_field_annot none_annot_a none_annot_b >>? fun none_annot -> + | Option_t (tva, tn1, has_big_map), + Option_t (tvb, tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tva tvb >|? fun (ty, ctxt) -> - Option_t ((ty, some_annot), none_annot, tname), ctxt - | List_t (tva, tn1), List_t (tvb, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> + Option_t (ty, tname, has_big_map), ctxt + | List_t (tva, tn1, has_big_map), List_t (tvb, tn2, _) -> + merge_type_annot ~legacy tn1 tn2 >>? fun tname -> help ctxt tva tvb >|? fun (ty, ctxt) -> - List_t (ty, tname), ctxt + List_t (ty, tname, has_big_map), ctxt | _, _ -> assert false in (fun ctxt loc ty1 ty2 -> record_inconsistent_type_annotations ctxt loc ty1 ty2 (help ctxt ty1 ty2)) let merge_stacks - : type ta. Script.location -> context -> ta stack_ty -> ta stack_ty -> - (ta stack_ty * context) tzresult - = fun loc -> + : type ta. legacy: bool -> Script.location -> context -> ta stack_ty -> ta stack_ty -> + (ta stack_ty * context) tzresult + = fun ~legacy loc -> let rec help : type a. context -> a stack_ty -> a stack_ty -> (a stack_ty * context) tzresult = fun ctxt stack1 stack2 -> @@ -956,11 +1016,38 @@ let merge_stacks | Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2) -> let annot = merge_var_annot annot1 annot2 in - merge_types ctxt loc ty1 ty2 >>? fun (ty, ctxt) -> + merge_types ~legacy ctxt loc ty1 ty2 >>? fun (ty, ctxt) -> help ctxt rest1 rest2 >|? fun (rest, ctxt) -> Item_t (ty, rest, annot), ctxt in help +let has_big_map + : type t. t ty -> bool + = function + | Unit_t _ -> false + | Int_t _ -> false + | Nat_t _ -> false + | Signature_t _ -> false + | String_t _ -> false + | Bytes_t _ -> false + | Mutez_t _ -> false + | Key_hash_t _ -> false + | Key_t _ -> false + | Timestamp_t _ -> false + | Address_t _ -> false + | Bool_t _ -> false + | Lambda_t (_, _, _) -> false + | Set_t (_, _) -> false + | Big_map_t (_, _, _) -> true + | Contract_t (_, _) -> false + | Operation_t _ -> false + | Chain_id_t _ -> false + | Pair_t (_, _, _, has_big_map) -> has_big_map + | Union_t (_, _, _, has_big_map) -> has_big_map + | Option_t (_, _, has_big_map) -> has_big_map + | List_t (_, _, has_big_map) -> has_big_map + | Map_t (_, _, _, has_big_map) -> has_big_map + (* ---- Type checker results -------------------------------------------------*) type 'bef judgement = @@ -974,10 +1061,10 @@ type ('t, 'f, 'b) branch = let merge_branches - : type bef a b. context -> int -> a judgement -> b judgement -> - (a, b, bef) branch -> - (bef judgement * context) tzresult Lwt.t - = fun ctxt loc btr bfr { branch } -> + : type bef a b. legacy: bool -> context -> int -> a judgement -> b judgement -> + (a, b, bef) branch -> + (bef judgement * context) tzresult Lwt.t + = fun ~legacy ctxt loc btr bfr { branch } -> match btr, bfr with | Typed ({ aft = aftbt ; _ } as dbt), Typed ({ aft = aftbf ; _ } as dbf) -> let unmatched_branches () = @@ -986,7 +1073,7 @@ let merge_branches Unmatched_branches (loc, aftbt, aftbf) in trace_eval unmatched_branches (Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf) >>=? fun (Eq, ctxt) -> - Lwt.return (merge_stacks loc ctxt aftbt aftbf) >>=? fun (merged_stack, ctxt) -> + Lwt.return (merge_stacks ~legacy loc ctxt aftbt aftbf) >>=? fun (merged_stack, ctxt) -> return ( Typed (branch {dbt with aft=merged_stack} {dbf with aft=merged_stack}), ctxt)) @@ -1046,12 +1133,32 @@ let rec parse_comparable_ty T_string ; T_mutez ; T_bool ; T_key ; T_key_hash ; T_timestamp ] +and parse_packable_ty : + context -> legacy:bool -> + Script.node -> (ex_ty * context) tzresult + = fun ctxt ~legacy -> + parse_ty ctxt ~legacy ~allow_big_map:false ~allow_operation:false ~allow_contract:legacy + +and parse_parameter_ty : + context -> legacy:bool -> + Script.node -> (ex_ty * context) tzresult + = fun ctxt ~legacy -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:true + +and parse_any_ty : + context -> legacy:bool -> + Script.node -> (ex_ty * context) tzresult + = fun ctxt ~legacy -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:true ~allow_contract:true + and parse_ty : context -> + legacy: bool -> allow_big_map: bool -> allow_operation: bool -> + allow_contract: bool -> Script.node -> (ex_ty * context) tzresult - = fun ctxt ~allow_big_map ~allow_operation node -> + = fun ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract node -> Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> match node with | Prim (loc, T_unit, [], annot) -> @@ -1109,44 +1216,58 @@ and parse_ty : Ex_ty (Operation_t ty_name), ctxt else error (Unexpected_operation loc) - | Prim (loc, T_contract, [ utl ], annot) -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false utl >>? fun (Ex_ty tl, ctxt) -> + | Prim (loc, T_chain_id, [], annot) -> parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> - Ex_ty (Contract_t (tl, ty_name)), ctxt + Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> + Ex_ty (Chain_id_t ty_name), ctxt + | Prim (loc, T_contract, [ utl ], annot) -> + if allow_contract then + parse_parameter_ty ctxt ~legacy utl >>? fun (Ex_ty tl, ctxt) -> + parse_type_annot loc annot >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> + Ex_ty (Contract_t (tl, ty_name)), ctxt + else + error (Unexpected_contract loc) | Prim (loc, T_pair, [ utl; utr ], annot) -> extract_field_annot utl >>? fun (utl, left_field) -> extract_field_annot utr >>? fun (utr, right_field) -> - parse_ty ctxt ~allow_big_map ~allow_operation utl >>? fun (Ex_ty tl, ctxt) -> - parse_ty ctxt ~allow_big_map ~allow_operation utr >>? fun (Ex_ty tr, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl >>? fun (Ex_ty tl, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr >>? fun (Ex_ty tr, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Pair_t ((tl, left_field, None), (tr, right_field, None), ty_name)), ctxt + Ex_ty (Pair_t ((tl, left_field, None), (tr, right_field, None), ty_name, has_big_map tl || has_big_map tr)), ctxt | Prim (loc, T_or, [ utl; utr ], annot) -> extract_field_annot utl >>? fun (utl, left_constr) -> extract_field_annot utr >>? fun (utr, right_constr) -> - parse_ty ctxt ~allow_big_map ~allow_operation utl >>? fun (Ex_ty tl, ctxt) -> - parse_ty ctxt ~allow_big_map ~allow_operation utr >>? fun (Ex_ty tr, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl >>? fun (Ex_ty tl, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr >>? fun (Ex_ty tr, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Union_t ((tl, left_constr), (tr, right_constr), ty_name)), ctxt + Ex_ty (Union_t ((tl, left_constr), (tr, right_constr), ty_name, has_big_map tl || has_big_map tr)), ctxt | Prim (loc, T_lambda, [ uta; utr ], annot) -> - parse_ty ctxt ~allow_big_map:true ~allow_operation:true uta >>? fun (Ex_ty ta, ctxt) -> - parse_ty ctxt ~allow_big_map:true ~allow_operation:true utr >>? fun (Ex_ty tr, ctxt) -> + parse_any_ty ctxt ~legacy uta >>? fun (Ex_ty ta, ctxt) -> + parse_any_ty ctxt ~legacy utr >>? fun (Ex_ty tr, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt | Prim (loc, T_option, [ ut ], annot) -> - extract_field_annot ut >>? fun (ut, some_constr) -> - parse_ty ctxt ~allow_big_map ~allow_operation ut >>? fun (Ex_ty t, ctxt) -> - parse_composed_type_annot loc annot >>? fun (ty_name, none_constr, _) -> + begin if legacy then + (* legacy semantics with (broken) field annotations *) + extract_field_annot ut >>? fun (ut, _some_constr) -> + parse_composed_type_annot loc annot >>? fun (ty_name, _none_constr, _) -> + ok (ut, ty_name) + else + parse_type_annot loc annot >>? fun ty_name -> + ok (ut, ty_name) + end >>? fun (ut, ty_name) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut >>? fun (Ex_ty t, ctxt) -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Option_t ((t, some_constr), none_constr, ty_name)), ctxt + Ex_ty (Option_t (t, ty_name, has_big_map t)), ctxt | Prim (loc, T_list, [ ut ], annot) -> - parse_ty ctxt ~allow_big_map ~allow_operation ut >>? fun (Ex_ty t, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut >>? fun (Ex_ty t, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> - Ex_ty (List_t (t, ty_name)), ctxt + Ex_ty (List_t (t, ty_name, has_big_map t)), ctxt | Prim (loc, T_set, [ ut ], annot) -> parse_comparable_ty ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> @@ -1154,13 +1275,13 @@ and parse_ty : Ex_ty (Set_t (t, ty_name)), ctxt | Prim (loc, T_map, [ uta; utr ], annot) -> parse_comparable_ty ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty ctxt ~allow_big_map ~allow_operation utr >>? fun (Ex_ty tr, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr >>? fun (Ex_ty tr, ctxt) -> parse_type_annot loc annot >>? fun ty_name -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Map_t (ta, tr, ty_name)), ctxt + Ex_ty (Map_t (ta, tr, ty_name, has_big_map tr)), ctxt | Prim (loc, T_big_map, args, annot) when allow_big_map -> - parse_big_map_ty ctxt loc args annot >>? fun (big_map_ty, ctxt) -> + parse_big_map_ty ctxt ~legacy loc args annot >>? fun (big_map_ty, ctxt) -> Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> big_map_ty, ctxt | Prim (loc, T_big_map, _, _) -> @@ -1171,9 +1292,9 @@ and parse_ty : | T_key | T_key_hash | T_timestamp | T_address as prim), l, _) -> error (Invalid_arity (loc, prim, 0, List.length l)) - | Prim (loc, (T_set | T_list | T_option as prim), l, _) -> + | Prim (loc, (T_set | T_list | T_option | T_contract as prim), l, _) -> error (Invalid_arity (loc, prim, 1, List.length l)) - | Prim (loc, (T_pair | T_or | T_map | T_lambda | T_contract as prim), l, _) -> + | Prim (loc, (T_pair | T_or | T_map | T_lambda as prim), l, _) -> error (Invalid_arity (loc, prim, 2, List.length l)) | expr -> error @@ unexpected expr [] Type_namespace @@ -1182,14 +1303,14 @@ and parse_ty : T_unit ; T_signature ; T_contract ; T_int ; T_nat ; T_operation ; T_string ; T_bytes ; T_mutez ; T_bool ; - T_key ; T_key_hash ; T_timestamp ] + T_key ; T_key_hash ; T_timestamp ; T_chain_id ] -and parse_big_map_ty ctxt big_map_loc args map_annot = +and parse_big_map_ty ctxt ~legacy big_map_loc args map_annot = Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> begin match args with | [ key_ty ; value_ty ] -> parse_comparable_ty ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false value_ty + parse_packable_ty ctxt ~legacy value_ty >>? fun (Ex_ty value_ty, ctxt) -> parse_type_annot big_map_loc map_annot >|? fun map_name -> let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in @@ -1198,27 +1319,35 @@ and parse_big_map_ty ctxt big_map_loc args map_annot = end and parse_storage_ty : - context -> Script.node -> (ex_ty * context) tzresult - = fun ctxt node -> + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult + = fun ctxt ~legacy node -> match node with | Prim (loc, T_pair, [ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ], - storage_annot) -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - parse_big_map_ty ctxt big_map_loc args map_annot >>? fun (Ex_ty big_map_ty, ctxt) -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false remaining_storage - >>? fun (Ex_ty remaining_storage, ctxt) -> - parse_composed_type_annot loc storage_annot - >>? fun (ty_name, map_field, storage_field) -> - Gas.consume ctxt (Typecheck_costs.type_ 5) >|? fun ctxt -> - Ex_ty (Pair_t ((big_map_ty, map_field, None), - (remaining_storage, storage_field, None), - ty_name)), - ctxt + storage_annot) when legacy -> + begin match storage_annot with + | [] -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy node + | [ single ] when Compare.Int.(String.length single > 0) && Compare.Char.(String.get single 0 = '%') -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy node + | _ -> + (* legacy semantics of big maps used the wrong annotation parser *) + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + parse_big_map_ty ctxt ~legacy big_map_loc args map_annot >>? fun (Ex_ty big_map_ty, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy remaining_storage + >>? fun (Ex_ty remaining_storage, ctxt) -> + parse_composed_type_annot loc storage_annot + >>? fun (ty_name, map_field, storage_field) -> + Gas.consume ctxt (Typecheck_costs.type_ 5) >|? fun ctxt -> + Ex_ty (Pair_t ((big_map_ty, map_field, None), + (remaining_storage, storage_field, None), + ty_name, true)), + ctxt + end | _ -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false node + parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy node -let check_no_big_map_or_operation loc root = +let check_packable ~legacy loc root = let rec check : type t. t ty -> unit tzresult = function | Big_map_t _ -> error (Unexpected_big_map loc) | Operation_t _ -> error (Unexpected_operation loc) @@ -1234,23 +1363,55 @@ let check_no_big_map_or_operation loc root = | Timestamp_t _ -> ok () | Address_t _ -> ok () | Bool_t _ -> ok () - | Pair_t ((l_ty, _, _), (r_ty, _, _), _) -> + | Chain_id_t _ -> ok () + | Pair_t ((l_ty, _, _), (r_ty, _, _), _, _) -> check l_ty >>? fun () -> check r_ty - | Union_t ((l_ty, _), (r_ty, _), _) -> + | Union_t ((l_ty, _), (r_ty, _), _, _) -> check l_ty >>? fun () -> check r_ty - | Option_t ((v_ty, _), _, _) -> check v_ty - | List_t (elt_ty, _) -> check elt_ty + | Option_t (v_ty, _, _) -> check v_ty + | List_t (elt_ty, _, _) -> check elt_ty | Set_t (_, _) -> ok () - | Map_t (_, elt_ty, _) -> check elt_ty + | Map_t (_, elt_ty, _, _) -> check elt_ty | Lambda_t (_l_ty, _r_ty, _) -> ok () - | Contract_t (_, _) -> ok () in + | Contract_t (_, _) when legacy -> ok () + | Contract_t (_, _) -> error (Unexpected_contract loc) in check root type ex_script = Ex_script : ('a, 'c) script -> ex_script +type _ dig_proof_argument = + Dig_proof_argument + : ((('x * 'rest), 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * ('x ty * var_annot option) + * 'aft stack_ty) + -> 'bef dig_proof_argument + +type (_, _) dug_proof_argument = + Dug_proof_argument + : (('rest, ('x * 'rest), 'bef, 'aft) stack_prefix_preservation_witness + * unit + * 'aft stack_ty) + -> ('bef, 'x) dug_proof_argument + +type (_) dipn_proof_argument = + Dipn_proof_argument + : (('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + * (context * ('fbef, 'faft) descr) + * 'aft stack_ty) + -> 'bef dipn_proof_argument + +type (_) dropn_proof_argument = + Dropn_proof_argument + : (('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * 'rest stack_ty + * 'aft stack_ty) + -> 'bef dropn_proof_argument + (* Lwt versions *) let parse_var_annot loc ?default annot = Lwt.return (parse_var_annot loc ?default annot) +let parse_entrypoint_annot loc ?default annot = + Lwt.return (parse_entrypoint_annot loc ?default annot) let parse_constr_annot loc ?if_special_first ?if_special_second annot = Lwt.return (parse_constr_annot loc ?if_special_first ?if_special_second annot) let parse_two_var_annot loc annot = @@ -1260,11 +1421,105 @@ let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot ~value let parse_var_type_annot loc annot = Lwt.return (parse_var_type_annot loc annot) + +let find_entrypoint (type full) (full : full ty) ~root_name entrypoint = + let rec find_entrypoint + : type t. t ty -> string -> ((Script.node -> Script.node) * ex_ty) + = fun t entrypoint -> match t with + | Union_t ((tl, al), (tr, ar), _, _) -> + if match al with None -> false | Some (`Field_annot l) -> Compare.String.(l = entrypoint) then + ((fun e -> Prim (0, D_Left, [ e ], [])), Ex_ty tl) + else if match ar with None -> false | Some (`Field_annot r) -> Compare.String.(r = entrypoint) then + ((fun e -> Prim (0, D_Right, [ e ], [])), Ex_ty tr) + else begin try + let (f, t) = find_entrypoint tl entrypoint in + ((fun e -> Prim (0, D_Left, [ f e ], [])), t) + with Not_found -> + let (f, t) = find_entrypoint tr entrypoint in + ((fun e -> Prim (0, D_Right, [ f e ], [])), t) + end + | _ -> raise Not_found in + let entrypoint = if Compare.String.(entrypoint = "") then "default" else entrypoint in + if Compare.Int.(String.length entrypoint > 31) then + error (Entrypoint_name_too_long entrypoint) + else match root_name with + | Some root_name when Compare.String.(entrypoint = root_name) -> + ok ((fun e -> e), Ex_ty full) + | _ -> + try ok (find_entrypoint full entrypoint) with Not_found -> + match entrypoint with + | "default" -> ok ((fun e -> e), Ex_ty full) + | _ -> error (No_such_entrypoint entrypoint) + +let find_entrypoint_for_type + (type full) (type exp) ~(full : full ty) ~(expected : exp ty) ~root_name entrypoint ctxt + : (context * string * exp ty) tzresult = + match entrypoint, root_name with + | "default", Some "root" -> + begin match find_entrypoint full ~root_name entrypoint with + | Error _ as err -> err + | Ok (_, Ex_ty ty) -> + match ty_eq ctxt expected ty with + | Ok (Eq, ctxt) -> + ok (ctxt, "default", (ty : exp ty)) + | Error _ -> + ty_eq ctxt expected full >>? fun (Eq, ctxt) -> + ok (ctxt, "root", (full : exp ty)) + end + | _ -> + find_entrypoint full ~root_name entrypoint >>? fun (_, Ex_ty ty) -> + ty_eq ctxt expected ty >>? fun (Eq, ctxt) -> + ok (ctxt, entrypoint, (ty : exp ty)) + + +module Entrypoints = Set.Make (String) + +exception Duplicate of string +exception Too_long of string + +let well_formed_entrypoints (type full) (full : full ty) ~root_name = + let merge path annot (type t) (ty : t ty) reachable ((first_unreachable, all) as acc) = + match annot with + | None | Some (`Field_annot "") -> + if reachable then acc + else begin match ty with + | Union_t _ -> acc + | _ -> match first_unreachable with + | None -> (Some (List.rev path), all) + | Some _ -> acc + end + | Some (`Field_annot name) -> + if Compare.Int.(String.length name > 31) then raise (Too_long name) + else if Entrypoints.mem name all then raise (Duplicate name) + else (first_unreachable, Entrypoints.add name all) in + let rec check + : type t. t ty -> prim list -> bool -> (prim list) option * Entrypoints.t -> (prim list) option * Entrypoints.t + = fun t path reachable acc -> + match t with + | Union_t ((tl, al), (tr, ar), _, _) -> + let acc = merge (D_Left :: path) al tl reachable acc in + let acc = merge (D_Right :: path) ar tr reachable acc in + let acc = check tl (D_Left :: path) (match al with Some _ -> true | None -> reachable) acc in + check tr (D_Right :: path) (match ar with Some _ -> true | None -> reachable) acc + | _ -> acc in + try + let init, reachable = match root_name with + | None | Some "" -> Entrypoints.empty, false + | Some name -> Entrypoints.singleton name, true in + let first_unreachable, all = check full [] reachable (None, init) in + if not (Entrypoints.mem "default" all) then ok () + else match first_unreachable with + | None -> ok () + | Some path -> error (Unreachable_entrypoint path) + with + | Duplicate name -> error (Duplicate_entrypoint name) + | Too_long name -> error (Entrypoint_name_too_long name) + let rec parse_data : type a. ?type_logger: type_logger -> - context -> a ty -> Script.node -> (a * context) tzresult Lwt.t - = fun ?type_logger ctxt ty script_data -> + context -> legacy: bool -> a ty -> Script.node -> (a * context) tzresult Lwt.t + = fun ?type_logger ctxt ~legacy ty script_data -> Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> let error () = Lwt.return (serialize_ty_for_error ctxt ty) >>|? fun (ty, _ctxt) -> @@ -1279,7 +1534,7 @@ let rec parse_data match item with | Prim (_, D_Elt, [ k; v ], _) -> parse_comparable_data ?type_logger ctxt key_type k >>=? fun (k, ctxt) -> - parse_data ?type_logger ctxt value_type v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy value_type v >>=? fun (v, ctxt) -> begin match last_value with | Some value -> if Compare.Int.(0 <= (compare_comparable key_type value k)) @@ -1301,8 +1556,9 @@ let rec parse_data (items, ctxt) in match ty, script_data with (* Unit *) - | Unit_t ty_name, Prim (loc, D_Unit, [], annot) -> - check_const_type_annot loc annot ty_name [] >>=? fun () -> + | Unit_t _, Prim (loc, D_Unit, [], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.unit) >>|? fun ctxt -> ((() : a), ctxt) | Unit_t _, Prim (loc, D_Unit, l, _) -> @@ -1310,12 +1566,14 @@ let rec parse_data | Unit_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Unit ])) (* Booleans *) - | Bool_t ty_name, Prim (loc, D_True, [], annot) -> - check_const_type_annot loc annot ty_name [] >>=? fun () -> + | Bool_t _, Prim (loc, D_True, [], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> (true, ctxt) - | Bool_t ty_name, Prim (loc, D_False, [], annot) -> - check_const_type_annot loc annot ty_name [] >>=? fun () -> + | Bool_t _, Prim (loc, D_False, [], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> (false, ctxt) | Bool_t _, Prim (loc, (D_True | D_False as c), l, _) -> @@ -1361,7 +1619,7 @@ let rec parse_data | Mutez_t _, Int (_, v) -> Lwt.return ( Gas.consume ctxt Typecheck_costs.tez >>? fun ctxt -> - Gas.consume ctxt Michelson_v1_gas.Cost_of.z_to_int64 + Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64 ) >>=? fun ctxt -> begin try match Tez.of_mutez (Z.to_int64 v) with @@ -1434,64 +1692,123 @@ let rec parse_data (* operations cannot appear in parameters or storage, the protocol should never parse the bytes of an operation *) assert false + (* Chain_ids *) + | Chain_id_t _, Bytes (_, bytes) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id) >>=? fun ctxt -> + begin match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with + | Some k -> return (k, ctxt) + | None -> error () >>=? fail + end + | Chain_id_t _, String (_, s) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id) >>=? fun ctxt -> + begin match Chain_id.of_b58check_opt s with + | Some s -> return (s, ctxt) + | None -> error () >>=? fail + end + | Chain_id_t _, expr -> + traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) (* Addresses *) - | Address_t _, Bytes (_, bytes) (* As unparsed with [O[ptimized]. *) -> + | Address_t _, Bytes (loc, bytes) (* As unparsed with [O[ptimized]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> begin - match Data_encoding.Binary.of_bytes Contract.encoding bytes with - | Some c -> return (c, ctxt) + match Data_encoding.Binary.of_bytes + Data_encoding.(tup2 Contract.encoding Variable.string) + bytes with + | Some (c, entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + fail (Entrypoint_name_too_long entrypoint) + else + begin match entrypoint with + | "" -> return "default" + | "default" -> fail (Unexpected_annotation loc) + | name -> return name end >>=? fun entrypoint -> + return ((c, entrypoint), ctxt) | None -> error () >>=? fail end - | Address_t _, String (_, s) (* As unparsed with [Readable]. *) -> + | Address_t _, String (loc, s) (* As unparsed with [Readable]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> - traced (Lwt.return (Contract.of_b58check s)) >>=? fun c -> - return (c, ctxt) + begin match String.index_opt s '%' with + | None -> return (s, "default") + | Some pos -> + let len = String.length s - pos - 1 in + let name = String.sub s (pos + 1) len in + if Compare.Int.(len > 31) then + fail (Entrypoint_name_too_long name) + else + match String.sub s 0 pos, name with + | _, "default" -> traced (fail (Unexpected_annotation loc)) + | addr_and_name -> return addr_and_name + end >>=? fun (addr, entrypoint) -> + Lwt.return (Contract.of_b58check addr) >>=? fun c -> + return ((c, entrypoint), ctxt) | Address_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) (* Contracts *) | Contract_t (ty, _), Bytes (loc, bytes) (* As unparsed with [Optimized]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> begin - match Data_encoding.Binary.of_bytes Contract.encoding bytes with - | Some c -> - traced (parse_contract ctxt loc ty c) >>=? fun (ctxt, _) -> - return ((ty, c), ctxt) + match Data_encoding.Binary.of_bytes + Data_encoding.(tup2 Contract.encoding Variable.string) + bytes with + | Some (c, entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + fail (Entrypoint_name_too_long entrypoint) + else + begin match entrypoint with + | "" -> return "default" + | "default" -> traced (fail (Unexpected_annotation loc)) + | name -> return name end >>=? fun entrypoint -> + traced (parse_contract ~legacy ctxt loc ty c ~entrypoint) >>=? fun (ctxt, _) -> + return ((ty, (c, entrypoint)), ctxt) | None -> error () >>=? fail end | Contract_t (ty, _), String (loc, s) (* As unparsed with [Readable]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> - traced @@ - Lwt.return (Contract.of_b58check s) >>=? fun c -> - parse_contract ctxt loc ty c >>=? fun (ctxt, _) -> - return ((ty, c), ctxt) + begin match String.index_opt s '%' with + | None -> return (s, "default") + | Some pos -> + let len = String.length s - pos - 1 in + let name = String.sub s (pos + 1) len in + if Compare.Int.(len > 31) then + fail (Entrypoint_name_too_long name) + else + match String.sub s 0 pos, name with + | _, "default" -> traced (fail (Unexpected_annotation loc)) + | addr_and_name -> return addr_and_name + end >>=? fun (addr, entrypoint) -> + traced (Lwt.return (Contract.of_b58check addr)) >>=? fun c -> + parse_contract ~legacy ctxt loc ty c ~entrypoint >>=? fun (ctxt, _) -> + return ((ty, (c, entrypoint)), ctxt) | Contract_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) (* Pairs *) - | Pair_t ((ta, af, _), (tb, bf, _), ty_name), Prim (loc, D_Pair, [ va; vb ], annot) -> - check_const_type_annot loc annot ty_name [af; bf] >>=? fun () -> + | Pair_t ((ta, _, _), (tb, _, _), _, _), Prim (loc, D_Pair, [ va; vb ], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.pair) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt ta va >>=? fun (va, ctxt) -> - parse_data ?type_logger ctxt tb vb >>=? fun (vb, ctxt) -> + parse_data ?type_logger ctxt ~legacy ta va >>=? fun (va, ctxt) -> + parse_data ?type_logger ctxt ~legacy tb vb >>=? fun (vb, ctxt) -> return ((va, vb), ctxt) | Pair_t _, Prim (loc, D_Pair, l, _) -> fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) | Pair_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Pair ])) (* Unions *) - | Union_t ((tl, lconstr), _, ty_name), Prim (loc, D_Left, [ v ], annot) -> - check_const_type_annot loc annot ty_name [lconstr]>>=? fun () -> + | Union_t ((tl, _), _, _, _), Prim (loc, D_Left, [ v ], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt tl v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy tl v >>=? fun (v, ctxt) -> return (L v, ctxt) | Union_t _, Prim (loc, D_Left, l, _) -> fail @@ Invalid_arity (loc, D_Left, 1, List.length l) - | Union_t (_, (tr, rconstr), ty_name), Prim (loc, D_Right, [ v ], annot) -> - check_const_type_annot loc annot ty_name [rconstr] >>=? fun () -> + | Union_t (_, (tr, _), _, _), Prim (loc, D_Right, [ v ], annot) -> + fail_unexpected_annot loc annot >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt tr v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy tr v >>=? fun (v, ctxt) -> return (R v, ctxt) | Union_t _, Prim (loc, D_Right, l, _) -> fail @@ Invalid_arity (loc, D_Right, 1, List.length l) @@ -1501,20 +1818,22 @@ let rec parse_data | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt -> traced @@ - parse_returning Lambda ?type_logger ctxt (ta, Some (`Var_annot "@arg")) tr script_instr + parse_returning Lambda ?type_logger ctxt ~legacy (ta, Some (`Var_annot "@arg")) tr script_instr | Lambda_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Options *) - | Option_t ((t, some_constr), _, ty_name), Prim (loc, D_Some, [ v ], annot) -> - check_const_type_annot loc annot ty_name [some_constr] >>=? fun () -> + | Option_t (t, _, _), Prim (loc, D_Some, [ v ], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.some) >>=? fun ctxt -> traced @@ - parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy t v >>=? fun (v, ctxt) -> return (Some v, ctxt) | Option_t _, Prim (loc, D_Some, l, _) -> fail @@ Invalid_arity (loc, D_Some, 1, List.length l) - | Option_t (_, none_constr, ty_name), Prim (loc, D_None, [], annot) -> - check_const_type_annot loc annot ty_name [none_constr] >>=? fun () -> + | Option_t (_, _, _), Prim (loc, D_None, [], annot) -> + (if legacy then return () else + fail_unexpected_annot loc annot) >>=? fun () -> Lwt.return (Gas.consume ctxt Typecheck_costs.none) >>=? fun ctxt -> return (None, ctxt) | Option_t _, Prim (loc, D_None, l, _) -> @@ -1522,12 +1841,12 @@ let rec parse_data | Option_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ])) (* Lists *) - | List_t (t, _ty_name), Seq (_loc, items) -> + | List_t (t, _ty_name, _), Seq (_loc, items) -> traced @@ fold_right_s (fun v (rest, ctxt) -> Lwt.return (Gas.consume ctxt Typecheck_costs.list_element) >>=? fun ctxt -> - parse_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> + parse_data ?type_logger ctxt ~legacy t v >>=? fun (v, ctxt) -> return ((v :: rest), ctxt)) items ([], ctxt) | List_t _, expr -> @@ -1550,38 +1869,51 @@ let rec parse_data else return_unit | None -> return_unit end >>=? fun () -> - Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.set_update v false set)) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.set_update v false set)) >>=? fun ctxt -> return (Some v, set_update v true set, ctxt)) (None, empty_set t, ctxt) vs >>|? fun (_, set, ctxt) -> (set, ctxt) | Set_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Maps *) - | Map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) -> + | Map_t (tk, tv, _ty_name, _), (Seq (loc, vs) as expr) -> parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) | Map_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) | Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) -> parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) -> - ({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) + ({ id = None ; diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) + | Big_map_t (tk, tv, _ty_name), Int (loc, id) -> + Big_map.exists ctxt id >>=? begin function + | _, None -> + traced (fail (Invalid_big_map (loc, id))) + | ctxt, Some (btk, btv) -> + Lwt.return begin + parse_comparable_ty ctxt (Micheline.root btk) >>? fun (Ex_comparable_ty btk, ctxt) -> + parse_packable_ty ctxt ~legacy (Micheline.root btv) >>? fun (Ex_ty btv, ctxt) -> + comparable_ty_eq ctxt tk btk >>? fun Eq -> + ty_eq ctxt tv btv >>? fun (Eq, ctxt) -> + ok ({ id = Some id ; diff = empty_map tk ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) + end + end | Big_map_t (_tk, _tv, _), expr -> - traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) + traced (fail (Invalid_kind (location expr, [ Seq_kind ; Int_kind ], kind expr))) and parse_comparable_data : type a. ?type_logger:type_logger -> context -> a comparable_ty -> Script.node -> (a * context) tzresult Lwt.t = fun ?type_logger ctxt ty script_data -> - parse_data ?type_logger ctxt (ty_of_comparable_ty ty) script_data + parse_data ?type_logger ctxt ~legacy: false (ty_of_comparable_ty ty) script_data and parse_returning : type arg ret. ?type_logger: type_logger -> - tc_context -> context -> - arg ty * var_annot option -> ret ty -> Script.node -> - ((arg, ret) lambda * context) tzresult Lwt.t = - fun ?type_logger tc_context ctxt (arg, arg_annot) ret script_instr -> - parse_instr ?type_logger tc_context ctxt + tc_context -> context -> legacy:bool -> + arg ty * var_annot option -> ret ty -> Script.node -> + ((arg, ret) lambda * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt ~legacy (arg, arg_annot) ret script_instr -> + parse_instr ?type_logger tc_context ctxt ~legacy script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function | (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), ctxt) -> trace_eval @@ -1590,30 +1922,70 @@ and parse_returning serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> Bad_return (loc, stack_ty, ret)) (Lwt.return (ty_eq ctxt ty ret) >>=? fun (Eq, ctxt) -> - Lwt.return (merge_types ctxt loc ty ret) >>=? fun (_ret, ctxt) -> - return ((Lam (descr, strip_locations script_instr) : (arg, ret) lambda), ctxt)) + Lwt.return (merge_types ~legacy ctxt loc ty ret) >>=? fun (_ret, ctxt) -> + return ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt)) | (Typed { loc ; aft = stack_ty ; _ }, ctxt) -> Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) -> serialize_stack_for_error ctxt stack_ty >>=? fun (stack_ty, _ctxt) -> fail (Bad_return (loc, stack_ty, ret)) | (Failed { descr }, ctxt) -> - return ((Lam (descr (Item_t (ret, Empty_t, None)), strip_locations script_instr) + return ((Lam (descr (Item_t (ret, Empty_t, None)), script_instr) : (arg, ret) lambda), ctxt) +and parse_int32 (n : (location, prim) Micheline.node) : int tzresult = + let error' () = + Invalid_syntactic_constant (location n, strip_locations n, + "a positive 32-bit integer (between 0 and " + ^ (Int32.to_string Int32.max_int) ^ ")") in + match n with + | Micheline.Int (_, n') -> + begin try + let n'' = Z.to_int n' in + if (Compare.Int.(0 <= n'')) && (Compare.Int.(n'' <= Int32.to_int Int32.max_int)) then + ok n'' + else + error @@ error' () + with _ -> + error @@ error' () + end + | _ -> error @@ error' () + and parse_instr : type bef. ?type_logger: type_logger -> - tc_context -> context -> - Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = - fun ?type_logger tc_context ctxt script_instr stack_ty -> - let check_item check loc name n m = + tc_context -> context -> legacy: bool -> + Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> + let _check_item check loc name n m = trace_eval (fun () -> serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty)) @@ trace (Bad_stack_item n) @@ Lwt.return check in - let check_item_ty ctxt exp got loc n = - check_item (ty_eq ctxt exp got) loc n in + let check_item_ty + (type a) (type b) + ctxt (exp : a ty) (got : b ty) loc name n m + : ((a, b) eq * a ty * context) tzresult Lwt.t = + trace_eval (fun () -> + serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> + Bad_stack (loc, name, m, stack_ty)) @@ + trace (Bad_stack_item n) @@ Lwt.return begin + ty_eq ctxt exp got >>? fun (Eq, ctxt) -> + merge_types ~legacy ctxt loc exp got >>? fun (ty, ctxt) -> + ok ((Eq : (a, b) eq), (ty : a ty), ctxt) + end in + let check_item_comparable_ty + (type a) (type b) + (exp : a comparable_ty) (got : b comparable_ty) loc name n m + : ((a, b) eq * a comparable_ty) tzresult Lwt.t = + trace_eval (fun () -> + serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> + Bad_stack (loc, name, m, stack_ty)) @@ + trace (Bad_stack_item n) @@ Lwt.return begin + comparable_ty_eq ctxt exp got >>? fun Eq -> + merge_comparable_types ~legacy exp got >>? fun ty -> + ok ((Eq : (a, b) eq), (ty : a comparable_ty)) + end in let log_stack ctxt loc stack_ty aft = match type_logger, script_instr with | None, _ @@ -1627,7 +1999,8 @@ and parse_instr log loc stack_ty aft; return_unit in - let return : + let outer_return = return in + let return : type bef . context -> bef judgement -> (bef judgement * context) tzresult Lwt.t = fun ctxt judgement -> match judgement with | Typed { instr ; loc ; aft ; _ } -> @@ -1650,14 +2023,83 @@ and parse_instr (* stack ops *) | Prim (loc, I_DROP, [], annot), Item_t (_, rest, _) -> - fail_unexpected_annot loc annot >>=? fun () -> - typed ctxt loc Drop - rest + (fail_unexpected_annot loc annot >>=? fun () -> + typed ctxt loc Drop rest : (bef judgement * context) tzresult Lwt.t) + | Prim (loc, I_DROP, [n], result_annot), whole_stack -> + Lwt.return (parse_int32 n) >>=? fun whole_n -> + let rec make_proof_argument + : type tstk . int -> (tstk stack_ty) -> (tstk dropn_proof_argument) tzresult Lwt.t = + fun n stk -> + match (Compare.Int.(n = 0)), stk with + true, rest -> + outer_return @@ (Dropn_proof_argument (Rest, rest, rest)) + | false, Item_t (v, rest, annot) -> + make_proof_argument (n - 1) rest + >>=? fun (Dropn_proof_argument (n', stack_after_drops, aft')) -> + outer_return @@ (Dropn_proof_argument (Prefix n', stack_after_drops, Item_t (v, aft', annot))) + | _, _ -> + serialize_stack_for_error ctxt whole_stack >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DROP, whole_n, whole_stack)) + in + fail_unexpected_annot loc result_annot >>=? fun () -> + make_proof_argument whole_n whole_stack >>=? fun (Dropn_proof_argument (n', stack_after_drops, _aft)) -> + typed ctxt loc (Dropn (whole_n, n')) stack_after_drops + | Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _ -> + (* Technically, the arities 0 and 1 are allowed but the error only mentions 1. + However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *) + fail (Invalid_arity (loc, I_DROP, 1, List.length l)) | Prim (loc, I_DUP, [], annot), Item_t (v, rest, stack_annot) -> parse_var_annot loc annot ~default:stack_annot >>=? fun annot -> typed ctxt loc Dup (Item_t (v, Item_t (v, rest, stack_annot), annot)) + | Prim (loc, I_DIG, [n], result_annot), stack -> + let rec make_proof_argument + : type tstk . int -> (tstk stack_ty) -> (tstk dig_proof_argument) tzresult Lwt.t = + fun n stk -> + match (Compare.Int.(n = 0)), stk with + true, Item_t (v, rest, annot) -> + outer_return @@ (Dig_proof_argument (Rest, (v, annot), rest)) + | false, Item_t (v, rest, annot) -> + make_proof_argument (n - 1) rest + >>=? fun (Dig_proof_argument (n', (x, xv), aft')) -> + outer_return @@ (Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot))) + | _, _ -> + serialize_stack_for_error ctxt stack >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DIG, 1, whole_stack)) + in + Lwt.return (parse_int32 n) >>=? fun n -> + fail_unexpected_annot loc result_annot >>=? fun () -> + make_proof_argument n stack >>=? fun (Dig_proof_argument (n', (x, stack_annot), aft)) -> + typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot)) + | Prim (loc, I_DIG, ([] | _ :: _ :: _ as l), _), _ -> + fail (Invalid_arity (loc, I_DIG, 1, List.length l)) + | Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack, stack_annot) -> + Lwt.return (parse_int32 n) >>=? fun whole_n -> + let rec make_proof_argument + : type tstk x . int -> x ty -> var_annot option -> (tstk stack_ty) + -> ((tstk, x) dug_proof_argument) tzresult Lwt.t = + fun n x stack_annot stk -> + match (Compare.Int.(n = 0)), stk with + true, rest -> + outer_return @@ (Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot))) + | false, Item_t (v, rest, annot) -> + make_proof_argument (n - 1) x stack_annot rest + >>=? fun (Dug_proof_argument (n', (), aft')) -> + outer_return @@ (Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot))) + | _, _ -> + serialize_stack_for_error ctxt whole_stack >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DUG, whole_n, whole_stack)) + in + fail_unexpected_annot loc result_annot >>=? fun () -> + make_proof_argument whole_n x stack_annot whole_stack >>=? fun (Dug_proof_argument (n', (), aft)) -> + typed ctxt loc (Dug (whole_n, n')) aft + | Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack) -> + fail_unexpected_annot loc result_annot >>=? fun () -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, I_DUG, 1, stack)) + | Prim (loc, I_DUG, ([] | _ :: _ :: _ as l), _), _ -> + fail (Invalid_arity (loc, I_DUG, 1, List.length l)) | Prim (loc, I_SWAP, [], annot), Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) -> fail_unexpected_annot loc annot >>=? fun () -> @@ -1666,8 +2108,8 @@ and parse_instr | Prim (loc, I_PUSH, [ t ; d ], annot), stack -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false t >>=? fun (Ex_ty t, ctxt) -> - parse_data ?type_logger ctxt t d >>=? fun (v, ctxt) -> + Lwt.return @@ parse_packable_ty ctxt ~legacy t >>=? fun (Ex_ty t, ctxt) -> + parse_data ?type_logger ctxt ~legacy t d >>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, annot)) | Prim (loc, I_UNIT, [], annot), stack -> @@ -1675,29 +2117,27 @@ and parse_instr typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot)) (* options *) | Prim (loc, I_SOME, [], annot), - Item_t (t, rest, stack_annot) -> - parse_constr_annot loc annot - ~if_special_first:(var_to_field_annot stack_annot) - >>=? fun (annot, ty_name, some_field, none_field) -> + Item_t (t, rest, _) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> typed ctxt loc Cons_some - (Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot)) + (Item_t (Option_t (t, ty_name, has_big_map t), rest, annot)) | Prim (loc, I_NONE, [ t ], annot), stack -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true t >>=? fun (Ex_ty t, ctxt) -> - parse_constr_annot loc annot >>=? fun (annot, ty_name, some_field, none_field) -> + Lwt.return @@ parse_any_ty ctxt ~legacy t >>=? fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> typed ctxt loc (Cons_none t) - (Item_t (Option_t ((t, some_field), none_field, ty_name), stack, annot)) + (Item_t (Option_t (t, ty_name, has_big_map t), stack, annot)) | Prim (loc, I_IF_NONE, [ bt ; bf ], annot), - (Item_t (Option_t ((t, some_field), _none_field, _), rest, option_annot) as bef) -> + (Item_t (Option_t (t, _, _), rest, option_annot) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> - let annot = gen_access_annot option_annot some_field ~default:default_some_annot in - parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt bf (Item_t (t, rest, annot)) >>=? fun (bfr, ctxt) -> + let annot = gen_access_annot option_annot default_some_annot in + parse_instr ?type_logger tc_context ctxt ~legacy bt rest >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bf (Item_t (t, rest, annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> return ctxt judgement (* pairs *) | Prim (loc, I_PAIR, [], annot), @@ -1707,9 +2147,9 @@ and parse_instr ~if_special_second:(var_to_field_annot snd_annot) >>=? fun (annot, ty_name, l_field, r_field) -> typed ctxt loc Cons_pair - (Item_t (Pair_t((a, l_field, fst_annot), (b, r_field, snd_annot), ty_name), rest, annot)) + (Item_t (Pair_t((a, l_field, fst_annot), (b, r_field, snd_annot), ty_name, has_big_map a || has_big_map b), rest, annot)) | Prim (loc, I_CAR, [], annot), - Item_t (Pair_t ((a, expected_field_annot, a_annot), _, _), rest, pair_annot) -> + Item_t (Pair_t ((a, expected_field_annot, a_annot), _, _, _), rest, pair_annot) -> parse_destr_annot loc annot ~pair_annot ~value_annot:a_annot @@ -1719,7 +2159,7 @@ and parse_instr Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () -> typed ctxt loc Car (Item_t (a, rest, annot)) | Prim (loc, I_CDR, [], annot), - Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _), rest, pair_annot) -> + Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _, _), rest, pair_annot) -> parse_destr_annot loc annot ~pair_annot ~value_annot:b_annot @@ -1731,69 +2171,69 @@ and parse_instr (* unions *) | Prim (loc, I_LEFT, [ tr ], annot), Item_t (tl, rest, stack_annot) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true tr >>=? fun (Ex_ty tr, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy tr >>=? fun (Ex_ty tr, ctxt) -> parse_constr_annot loc annot ~if_special_first:(var_to_field_annot stack_annot) >>=? fun (annot, tname, l_field, r_field) -> - typed ctxt loc Left (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) + typed ctxt loc Left (Item_t (Union_t ((tl, l_field), (tr, r_field), tname, has_big_map tl || has_big_map tr), rest, annot)) | Prim (loc, I_RIGHT, [ tl ], annot), Item_t (tr, rest, stack_annot) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true tl >>=? fun (Ex_ty tl, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy tl >>=? fun (Ex_ty tl, ctxt) -> parse_constr_annot loc annot ~if_special_second:(var_to_field_annot stack_annot) >>=? fun (annot, tname, l_field, r_field) -> - typed ctxt loc Right (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) + typed ctxt loc Right (Item_t (Union_t ((tl, l_field), (tr, r_field), tname, has_big_map tl || has_big_map tr), rest, annot)) | Prim (loc, I_IF_LEFT, [ bt ; bf ], annot), - (Item_t (Union_t ((tl, l_field), (tr, r_field), _), rest, union_annot) as bef) -> + (Item_t (Union_t ((tl, l_field), (tr, r_field), _, _), rest, union_annot) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let left_annot = gen_access_annot union_annot l_field ~default:default_left_annot in let right_annot = gen_access_annot union_annot r_field ~default:default_right_annot in - parse_instr ?type_logger tc_context ctxt bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> return ctxt judgement (* lists *) | Prim (loc, I_NIL, [ t ], annot), stack -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true t >>=? fun (Ex_ty t, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy t >>=? fun (Ex_ty t, ctxt) -> parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc Nil (Item_t (List_t (t, ty_name), stack, annot)) + typed ctxt loc Nil (Item_t (List_t (t, ty_name, has_big_map t), stack, annot)) | Prim (loc, I_CONS, [], annot), - Item_t (tv, Item_t (List_t (t, ty_name), rest, _), _) -> - check_item_ty ctxt tv t loc I_CONS 1 2 >>=? fun (Eq, ctxt) -> + Item_t (tv, Item_t (List_t (t, ty_name, has_big_map), rest, _), _) -> + check_item_ty ctxt tv t loc I_CONS 1 2 >>=? fun (Eq, t, ctxt) -> parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Cons_list (Item_t (List_t (t, ty_name), rest, annot)) + typed ctxt loc Cons_list (Item_t (List_t (t, ty_name, has_big_map), rest, annot)) | Prim (loc, I_IF_CONS, [ bt ; bf ], annot), - (Item_t (List_t (t, ty_name), rest, list_annot) as bef) -> + (Item_t (List_t (t, ty_name, has_big_map), rest, list_annot) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let hd_annot = gen_access_annot list_annot default_hd_annot in let tl_annot = gen_access_annot list_annot default_tl_annot in - parse_instr ?type_logger tc_context ctxt bt - (Item_t (t, Item_t (List_t (t, ty_name), rest, tl_annot), hd_annot)) + parse_instr ?type_logger tc_context ctxt ~legacy bt + (Item_t (t, Item_t (List_t (t, ty_name, has_big_map), rest, tl_annot), hd_annot)) >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt bf + parse_instr ?type_logger tc_context ctxt ~legacy bf rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> return ctxt judgement | Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _) -> parse_var_type_annot loc annot >>=? fun (annot, tname) -> typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_MAP, [ body ], annot), - (Item_t (List_t (elt, _), starting_rest, list_annot)) -> + (Item_t (List_t (elt, _, _), starting_rest, list_annot)) -> check_kind [ Seq_kind ] body >>=? fun () -> parse_var_type_annot loc annot >>=? fun (ret_annot, list_ty_name) -> let elt_annot = gen_access_annot list_annot default_elt_annot in - parse_instr ?type_logger tc_context ctxt + parse_instr ?type_logger tc_context ctxt ~legacy body (Item_t (elt, starting_rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> @@ -1802,20 +2242,20 @@ and parse_instr Invalid_map_body (loc, aft) in trace_eval invalid_map_body (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> typed ctxt loc (List_map ibody) - (Item_t (List_t (ret, list_ty_name), rest, ret_annot))) + (Item_t (List_t (ret, list_ty_name, has_big_map ret), rest, ret_annot))) | Typed { aft ; _ } -> serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft)) | Failed _ -> fail (Invalid_map_block_fail loc) end | Prim (loc, I_ITER, [ body ], annot), - Item_t (List_t (elt, _), rest, list_annot) -> + Item_t (List_t (elt, _, _), rest, list_annot) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let elt_annot = gen_access_annot list_annot default_elt_annot in - parse_instr ?type_logger tc_context ctxt + parse_instr ?type_logger tc_context ctxt ~legacy body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> @@ -1825,7 +2265,7 @@ and parse_instr Invalid_iter_body (loc, rest, aft) in trace_eval invalid_iter_body (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest >>=? fun (rest, ctxt) -> typed ctxt loc (List_iter ibody) rest) | Failed { descr } -> typed ctxt loc (List_iter (descr rest)) rest @@ -1842,7 +2282,7 @@ and parse_instr fail_unexpected_annot loc annot >>=? fun () -> let elt_annot = gen_access_annot set_annot default_elt_annot in let elt = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt + parse_instr ?type_logger tc_context ctxt ~legacy body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> @@ -1852,7 +2292,7 @@ and parse_instr Invalid_iter_body (loc, rest, aft) in trace_eval invalid_iter_body (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest >>=? fun (rest, ctxt) -> typed ctxt loc (Set_iter ibody) rest) | Failed { descr } -> typed ctxt loc (Set_iter (descr rest)) rest @@ -1861,14 +2301,19 @@ and parse_instr Item_t (v, Item_t (Set_t (elt, _), rest, _), _) -> let elt = ty_of_comparable_ty elt in parse_var_type_annot loc annot >>=? fun (annot, tname) -> - check_item_ty ctxt elt v loc I_MEM 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt elt v loc I_MEM 1 2 >>=? fun (Eq, _, ctxt) -> typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot)) | Prim (loc, I_UPDATE, [], annot), Item_t (v, Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _), _) -> - let ty = ty_of_comparable_ty elt in - parse_var_annot loc annot ~default:set_annot >>=? fun annot -> - check_item_ty ctxt ty v loc I_UPDATE 1 3 >>=? fun (Eq, ctxt) -> - typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) + begin match comparable_ty_of_ty v with + | None -> + unparse_ty ctxt v >>=? fun (v, _ctxt) -> + fail (Comparable_type_expected (loc, Micheline.strip_locations v)) + | Some v -> + parse_var_annot loc annot ~default:set_annot >>=? fun annot -> + check_item_comparable_ty elt v loc I_UPDATE 1 3 >>=? fun (Eq, elt) -> + typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) + end | Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -1877,18 +2322,18 @@ and parse_instr | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], annot), stack -> Lwt.return @@ parse_comparable_ty ctxt tk >>=? fun (Ex_comparable_ty tk, ctxt) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true tv >>=? fun (Ex_ty tv, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy tv >>=? fun (Ex_ty tv, ctxt) -> parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv, ty_name), stack, annot)) + typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv, ty_name, has_big_map tv), stack, annot)) | Prim (loc, I_MAP, [ body ], annot), - Item_t (Map_t (ck, elt, _), starting_rest, _map_annot) -> + Item_t (Map_t (ck, elt, _, _), starting_rest, _map_annot) -> let k = ty_of_comparable_ty ck in check_kind [ Seq_kind ] body >>=? fun () -> parse_var_type_annot loc annot >>=? fun (ret_annot, ty_name) -> let k_name = field_to_var_annot default_key_annot in let e_name = field_to_var_annot default_elt_annot in - parse_instr ?type_logger tc_context ctxt - body (Item_t (Pair_t ((k, None, k_name), (elt, None, e_name), None), + parse_instr ?type_logger tc_context ctxt ~legacy + body (Item_t (Pair_t ((k, None, k_name), (elt, None, e_name), None, has_big_map elt), starting_rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> @@ -1897,23 +2342,23 @@ and parse_instr Invalid_map_body (loc, aft) in trace_eval invalid_map_body (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> typed ctxt loc (Map_map ibody) - (Item_t (Map_t (ck, ret, ty_name), rest, ret_annot))) + (Item_t (Map_t (ck, ret, ty_name, has_big_map ret), rest, ret_annot))) | Typed { aft ; _ } -> serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft)) | Failed _ -> fail (Invalid_map_block_fail loc) end | Prim (loc, I_ITER, [ body ], annot), - Item_t (Map_t (comp_elt, element_ty, _), rest, _map_annot) -> + Item_t (Map_t (comp_elt, element_ty, _, _), rest, _map_annot) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> let k_name = field_to_var_annot default_key_annot in let e_name = field_to_var_annot default_elt_annot in let key = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt body - (Item_t (Pair_t ((key, None, k_name), (element_ty, None, e_name), None), + parse_instr ?type_logger tc_context ctxt ~legacy body + (Item_t (Pair_t ((key, None, k_name), (element_ty, None, e_name), None, has_big_map element_ty), rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> @@ -1923,55 +2368,61 @@ and parse_instr Invalid_iter_body (loc, rest, aft) in trace_eval invalid_iter_body (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt aft rest >>=? fun (rest, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest >>=? fun (rest, ctxt) -> typed ctxt loc (Map_iter ibody) rest) | Failed { descr } -> typed ctxt loc (Map_iter (descr rest)) rest end | Prim (loc, I_MEM, [], annot), - Item_t (vk, Item_t (Map_t (ck, _, _), rest, _), _) -> + Item_t (vk, Item_t (Map_t (ck, _, _, _), rest, _), _) -> let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_MEM 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt vk k loc I_MEM 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot)) | Prim (loc, I_GET, [], annot), - Item_t (vk, Item_t (Map_t (ck, elt, _), rest, _), _) -> + Item_t (vk, Item_t (Map_t (ck, elt, _, has_big_map), rest, _), _) -> let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Map_get (Item_t (Option_t ((elt, None), None, None), rest, annot)) + typed ctxt loc Map_get (Item_t (Option_t (elt, None, has_big_map), rest, annot)) | Prim (loc, I_UPDATE, [], annot), - Item_t (vk, Item_t (Option_t ((vv, _), _, _), - Item_t (Map_t (ck, v, map_name), rest, map_annot), _), _) -> + Item_t (vk, Item_t (Option_t (vv, _, _), + Item_t (Map_t (ck, v, map_name, has_big_map), rest, map_annot), _), _) -> let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_UPDATE 1 3 >>=? fun (Eq, ctxt) -> - check_item_ty ctxt vv v loc I_UPDATE 2 3 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt vk k loc I_UPDATE 1 3 >>=? fun (Eq, _, ctxt) -> + check_item_ty ctxt vv v loc I_UPDATE 2 3 >>=? fun (Eq, v, ctxt) -> parse_var_annot loc annot ~default:map_annot >>=? fun annot -> - typed ctxt loc Map_update (Item_t (Map_t (ck, v, map_name), rest, annot)) + typed ctxt loc Map_update (Item_t (Map_t (ck, v, map_name, has_big_map), rest, annot)) | Prim (loc, I_SIZE, [], annot), - Item_t (Map_t (_, _, _), rest, _) -> + Item_t (Map_t (_, _, _, _), rest, _) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot)) (* big_map *) + | Prim (loc, I_EMPTY_BIG_MAP, [ tk ; tv ], annot), + stack -> + Lwt.return @@ parse_comparable_ty ctxt tk >>=? fun (Ex_comparable_ty tk, ctxt) -> + Lwt.return @@ parse_packable_ty ctxt ~legacy tv >>=? fun (Ex_ty tv, ctxt) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> + typed ctxt loc (Empty_big_map (tk, tv)) (Item_t (Big_map_t (tk, tv, ty_name), stack, annot)) | Prim (loc, I_MEM, [], annot), Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) -> let k = ty_of_comparable_ty map_key in - check_item_ty ctxt set_key k loc I_MEM 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt set_key k loc I_MEM 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot)) | Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) -> let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Big_map_get (Item_t (Option_t ((elt, None), None, None), rest, annot)) + typed ctxt loc Big_map_get (Item_t (Option_t (elt, None, has_big_map elt), rest, annot)) | Prim (loc, I_UPDATE, [], annot), Item_t (set_key, - Item_t (Option_t ((set_value, _), _, _), + Item_t (Option_t (set_value, _, _), Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot), _), _) -> let k = ty_of_comparable_ty map_key in - check_item_ty ctxt set_key k loc I_UPDATE 1 3 >>=? fun (Eq, ctxt) -> - check_item_ty ctxt set_value map_value loc I_UPDATE 2 3 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt set_key k loc I_UPDATE 1 3 >>=? fun (Eq, _, ctxt) -> + check_item_ty ctxt set_value map_value loc I_UPDATE 2 3 >>=? fun (Eq, map_value, ctxt) -> parse_var_annot loc annot ~default:map_annot >>=? fun annot -> typed ctxt loc Big_map_update (Item_t (Big_map_t (map_key, map_value, map_name), rest, annot)) (* control *) @@ -1980,7 +2431,7 @@ and parse_instr typed ctxt loc Nop stack | Seq (loc, [ single ]), stack -> - parse_instr ?type_logger tc_context ctxt single + parse_instr ?type_logger tc_context ctxt ~legacy single stack >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as instr) -> @@ -1995,13 +2446,13 @@ and parse_instr end | Seq (loc, hd :: tl), stack -> - parse_instr ?type_logger tc_context ctxt hd + parse_instr ?type_logger tc_context ctxt ~legacy hd stack >>=? begin fun (judgement, ctxt) -> match judgement with | Failed _ -> fail (Fail_not_in_tail_position (Micheline.location hd)) | Typed ({ aft = middle ; _ } as ihd) -> - parse_instr ?type_logger tc_context ctxt (Seq (-1, tl)) + parse_instr ?type_logger tc_context ctxt ~legacy (Seq (-1, tl)) middle >>=? fun (judgement, ctxt) -> match judgement with | Failed { descr } -> @@ -2017,17 +2468,17 @@ and parse_instr check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt bf rest >>=? fun (bfr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bt rest >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bf rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> + merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> return ctxt judgement | Prim (loc, I_LOOP, [ body ], annot), (Item_t (Bool_t _, rest, _stack_annot) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt body + parse_instr ?type_logger tc_context ctxt ~legacy body rest >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> @@ -2037,18 +2488,18 @@ and parse_instr Unmatched_branches (loc, aft, stack) in trace_eval unmatched_branches (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop ibody) rest) | Failed { descr } -> let ibody = descr stack in typed ctxt loc (Loop ibody) rest end | Prim (loc, I_LOOP_LEFT, [ body ], annot), - (Item_t (Union_t ((tl, l_field), (tr, _), _), rest, union_annot) as stack) -> + (Item_t (Union_t ((tl, l_field), (tr, _), _, _), rest, union_annot) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> parse_var_annot loc annot >>=? fun annot -> let l_annot = gen_access_annot union_annot l_field ~default:default_left_annot in - parse_instr ?type_logger tc_context ctxt body + parse_instr ?type_logger tc_context ctxt ~legacy body (Item_t (tl, rest, l_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> let unmatched_branches () = @@ -2057,7 +2508,7 @@ and parse_instr Unmatched_branches (loc, aft, stack) in trace_eval unmatched_branches (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot))) | Failed { descr } -> let ibody = descr stack in @@ -2065,31 +2516,72 @@ and parse_instr end | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], annot), stack -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true arg + Lwt.return @@ parse_any_ty ctxt ~legacy arg >>=? fun (Ex_ty arg, ctxt) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true ret + Lwt.return @@ parse_any_ty ctxt ~legacy ret >>=? fun (Ex_ty ret, ctxt) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_var_annot loc annot >>=? fun annot -> - parse_returning Lambda ?type_logger ctxt + parse_returning Lambda ?type_logger ctxt ~legacy (arg, default_arg_annot) ret code >>=? fun (lambda, ctxt) -> typed ctxt loc (Lambda lambda) (Item_t (Lambda_t (arg, ret, None), stack, annot)) | Prim (loc, I_EXEC, [], annot), Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) -> - check_item_ty ctxt arg param loc I_EXEC 1 2 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt arg param loc I_EXEC 1 2 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Exec (Item_t (ret, rest, annot)) + | Prim (loc, I_APPLY, [], annot), + Item_t (capture, Item_t (Lambda_t (Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot, _), ret, _), rest, _), _) -> + Lwt.return @@ check_packable ~legacy:false loc capture_ty >>=? fun () -> + check_item_ty ctxt capture capture_ty loc I_APPLY 1 2 >>=? fun (Eq, capture_ty, ctxt) -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc (Apply capture_ty) (Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot)) | Prim (loc, I_DIP, [ code ], annot), Item_t (v, rest, stack_annot) -> fail_unexpected_annot loc annot >>=? fun () -> check_kind [ Seq_kind ] code >>=? fun () -> - parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt code + parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt ~legacy code rest >>=? begin fun (judgement, ctxt) -> match judgement with | Typed descr -> typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot)) | Failed _ -> fail (Fail_not_in_tail_position loc) end + | Prim (loc, I_DIP, [n; code], result_annot), stack + when (match parse_int32 n with Ok _ -> true | Error _ -> false) -> + let rec make_proof_argument + : type tstk . int + (* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) + -> tc_context + -> (tstk stack_ty) + -> (tstk dipn_proof_argument) tzresult Lwt.t = + fun n inner_tc_context stk -> + match (Compare.Int.(n = 0)), stk with + true, rest -> + (parse_instr ?type_logger inner_tc_context ctxt ~legacy code + rest) >>=? begin fun (judgement, ctxt) -> match judgement with + | Typed descr -> + outer_return @@ (Dipn_proof_argument (Rest, (ctxt, descr), descr.aft)) + | Failed _ -> + fail (Fail_not_in_tail_position loc) + end + | false, Item_t (v, rest, annot) -> + make_proof_argument (n - 1) (add_dip v annot tc_context) rest + >>=? fun (Dipn_proof_argument (n', descr, aft')) -> + outer_return @@ (Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot))) + | _, _ -> + serialize_stack_for_error ctxt stack >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DIP, 1, whole_stack)) + in + Lwt.return (parse_int32 n) >>=? fun n -> + fail_unexpected_annot loc result_annot >>=? fun () -> + make_proof_argument n tc_context stack >>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) -> + (* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *) + typed new_ctxt loc (Dipn (n, n', descr)) aft + | Prim (loc, I_DIP, ([] | _ :: _ :: _ :: _ as l), _), _ -> + (* Technically, the arities 1 and 2 are allowed but the error only mentions 2. + However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *) + fail (Invalid_arity (loc, I_DIP, 2, List.length l)) | Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest, _) -> fail_unexpected_annot loc annot >>=? fun () -> @@ -2098,38 +2590,35 @@ and parse_instr return ctxt (Failed { descr }) (* timestamp operations *) | Prim (loc, I_ADD, [], annot), - Item_t (Timestamp_t tn1, Item_t (Int_t tn2, rest, _), _) -> + Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> typed ctxt loc Add_timestamp_to_seconds (Item_t (Timestamp_t tname, rest, annot)) | Prim (loc, I_ADD, [], annot), - Item_t (Int_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> + Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> typed ctxt loc Add_seconds_to_timestamp (Item_t (Timestamp_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), - Item_t (Timestamp_t tn1, Item_t (Int_t tn2, rest, _), _) -> + Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> typed ctxt loc Sub_timestamp_seconds (Item_t (Timestamp_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Diff_timestamps (Item_t (Int_t tname, rest, annot)) (* string operations *) | Prim (loc, I_CONCAT, [], annot), Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Concat_string_pair (Item_t (String_t tname, rest, annot)) | Prim (loc, I_CONCAT, [], annot), - Item_t (List_t (String_t tname, _), rest, list_annot) -> + Item_t (List_t (String_t tname, _, _), rest, list_annot) -> parse_var_annot ~default:list_annot loc annot >>=? fun annot -> typed ctxt loc Concat_string (Item_t (String_t tname, rest, annot)) @@ -2139,7 +2628,7 @@ and parse_instr ~default:(gen_access_annot string_annot default_slice_annot) loc annot >>=? fun annot -> typed ctxt loc Slice_string - (Item_t (Option_t ((String_t tname, None), None, None), rest, annot)) + (Item_t (Option_t (String_t tname, None, false), rest, annot)) | Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -2148,11 +2637,11 @@ and parse_instr | Prim (loc, I_CONCAT, [], annot), Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Concat_bytes_pair (Item_t (Bytes_t tname, rest, annot)) | Prim (loc, I_CONCAT, [], annot), - Item_t (List_t (Bytes_t tname, _), rest, list_annot) -> + Item_t (List_t (Bytes_t tname, _, _), rest, list_annot) -> parse_var_annot ~default:list_annot loc annot >>=? fun annot -> typed ctxt loc Concat_bytes (Item_t (Bytes_t tname, rest, annot)) @@ -2162,7 +2651,7 @@ and parse_instr ~default:(gen_access_annot bytes_annot default_slice_annot) loc annot >>=? fun annot -> typed ctxt loc Slice_bytes - (Item_t (Option_t ((Bytes_t tname, None), None, None), rest, annot)) + (Item_t (Option_t (Bytes_t tname, None, false), rest, annot)) | Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -2171,13 +2660,13 @@ and parse_instr | Prim (loc, I_ADD, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Add_tez (Item_t (Mutez_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Sub_tez (Item_t (Mutez_t tname, rest, annot)) | Prim (loc, I_MUL, [], annot), @@ -2194,19 +2683,19 @@ and parse_instr | Prim (loc, I_OR, [], annot), Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Or (Item_t (Bool_t tname, rest, annot)) | Prim (loc, I_AND, [], annot), Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc And (Item_t (Bool_t tname, rest, annot)) | Prim (loc, I_XOR, [], annot), Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Xor (Item_t (Bool_t tname, rest, annot)) | Prim (loc, I_NOT, [], annot), @@ -2224,7 +2713,7 @@ and parse_instr Item_t (Int_t _, rest, int_annot) -> parse_var_annot loc annot ~default:int_annot >>=? fun annot -> typed ctxt loc Is_nat - (Item_t (Option_t ((Nat_t None, None), None, None), rest, annot)) + (Item_t (Option_t (Nat_t None, None, false), rest, annot)) | Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -2243,7 +2732,7 @@ and parse_instr | Prim (loc, I_ADD, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Add_intint (Item_t (Int_t tname, rest, annot)) | Prim (loc, I_ADD, [], annot), @@ -2259,13 +2748,13 @@ and parse_instr | Prim (loc, I_ADD, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Add_natnat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot)) | Prim (loc, I_SUB, [], annot), @@ -2281,13 +2770,13 @@ and parse_instr | Prim (loc, I_SUB, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun _tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun _tname -> typed ctxt loc Sub_int (Item_t (Int_t None, rest, annot)) | Prim (loc, I_MUL, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Mul_intint (Item_t (Int_t tname, rest, annot)) | Prim (loc, I_MUL, [], annot), @@ -2303,7 +2792,7 @@ and parse_instr | Prim (loc, I_MUL, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Mul_natnat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_EDIV, [], annot), @@ -2311,71 +2800,71 @@ and parse_instr parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Ediv_teznat (Item_t (Option_t - ((Pair_t ((Mutez_t tname, None, None), - (Mutez_t tname, None, None), None), None), - None, None), rest, annot)) + (Pair_t ((Mutez_t tname, None, None), + (Mutez_t tname, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Ediv_tez - (Item_t (Option_t ((Pair_t ((Nat_t None, None, None), - (Mutez_t tname, None, None), None), None), - None, None), rest, annot)) + (Item_t (Option_t (Pair_t ((Nat_t None, None, None), + (Mutez_t tname, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Ediv_intint (Item_t (Option_t - ((Pair_t ((Int_t tname, None, None), - (Nat_t None, None, None), None), None), - None, None), rest, annot)) + (Pair_t ((Int_t tname, None, None), + (Nat_t None, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Ediv_intnat (Item_t (Option_t - ((Pair_t ((Int_t tname, None, None), - (Nat_t None, None, None), None), None), - None, None), rest, annot)) + (Pair_t ((Int_t tname, None, None), + (Nat_t None, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Ediv_natint - (Item_t (Option_t ((Pair_t ((Int_t None, None, None), - (Nat_t tname, None, None), None), None), - None, None), rest, annot)) + (Item_t (Option_t (Pair_t ((Int_t None, None, None), + (Nat_t tname, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Ediv_natnat - (Item_t (Option_t ((Pair_t ((Nat_t tname, None, None), - (Nat_t tname, None, None), None), None), - None, None), rest, annot)) + (Item_t (Option_t (Pair_t ((Nat_t tname, None, None), + (Nat_t tname, None, None), None, false), + None, false), rest, annot)) | Prim (loc, I_LSL, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Lsl_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_LSR, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Lsr_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_OR, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Or_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_AND, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc And_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_AND, [], annot), @@ -2386,7 +2875,7 @@ and parse_instr | Prim (loc, I_XOR, [], annot), Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> typed ctxt loc Xor_nat (Item_t (Nat_t tname, rest, annot)) | Prim (loc, I_NOT, [], annot), @@ -2401,59 +2890,17 @@ and parse_instr (Item_t (Int_t None, rest, annot)) (* comparison *) | Prim (loc, I_COMPARE, [], annot), - Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Int_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Nat_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Bool_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (String_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Mutez_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Key_hash_t tn1, Item_t (Key_hash_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Key_hash_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Timestamp_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Address_t tn1, Item_t (Address_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Address_key tname)) - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_COMPARE, [], annot), - Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> - typed ctxt loc (Compare (Bytes_key tname)) - (Item_t (Int_t None, rest, annot)) + Item_t (t1, Item_t (t2, rest, _), _) -> + parse_var_annot loc annot >>=? fun annot -> + check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 >>=? fun (Eq, t, ctxt) -> + begin match comparable_ty_of_ty t with + | None -> + Lwt.return (serialize_ty_for_error ctxt t) >>=? fun (t, _ctxt) -> + fail (Comparable_type_expected (loc, t)) + | Some key -> + typed ctxt loc (Compare key) + (Item_t (Int_t None, rest, annot)) + end (* comparators *) | Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest, _) -> @@ -2489,10 +2936,10 @@ and parse_instr | Prim (loc, I_CAST, [ cast_t ], annot), Item_t (t, stack, item_annot) -> parse_var_annot loc annot ~default:item_annot >>=? fun annot -> - (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true cast_t) + (Lwt.return @@ parse_any_ty ctxt ~legacy cast_t) >>=? fun (Ex_ty cast_t, ctxt) -> Lwt.return @@ ty_eq ctxt cast_t t >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ctxt loc cast_t t >>=? fun (_, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc cast_t t >>=? fun (_, ctxt) -> typed ctxt loc Nop (Item_t (cast_t, stack, annot)) | Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _) -> @@ -2501,20 +2948,17 @@ and parse_instr (* packing *) | Prim (loc, I_PACK, [], annot), Item_t (t, rest, unpacked_annot) -> - Lwt.return (check_no_big_map_or_operation loc t) >>=? fun () -> + Lwt.return (check_packable ~legacy:true (* allow to pack contracts for hash/signature checks *) loc t) >>=? fun () -> parse_var_annot loc annot ~default:(gen_access_annot unpacked_annot default_pack_annot) >>=? fun annot -> typed ctxt loc (Pack t) (Item_t (Bytes_t None, rest, annot)) | Prim (loc, I_UNPACK, [ ty ], annot), Item_t (Bytes_t _, rest, packed_annot) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t, ctxt) -> - let stack_annot = gen_access_annot packed_annot default_unpack_annot in - parse_constr_annot loc annot - ~if_special_first:(var_to_field_annot stack_annot) - >>=? fun (annot, ty_name, some_field, none_field) -> - typed ctxt loc (Unpack t) - (Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot)) + Lwt.return @@ parse_packable_ty ctxt ~legacy ty >>=? fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> + let annot = default_annot annot ~default:(gen_access_annot packed_annot default_unpack_annot) in + typed ctxt loc (Unpack t) (Item_t (Option_t (t, ty_name, false (* cannot unpack big_maps *)), rest, annot)) (* protocol *) | Prim (loc, I_ADDRESS, [], annot), Item_t (Contract_t _, rest, contract_annot) -> @@ -2524,31 +2968,46 @@ and parse_instr (Item_t (Address_t None, rest, annot)) | Prim (loc, I_CONTRACT, [ ty ], annot), Item_t (Address_t _, rest, addr_annot) -> - Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t, ctxt) -> - parse_var_annot loc annot ~default:(gen_access_annot addr_annot default_contract_annot) - >>=? fun annot -> - typed ctxt loc (Contract t) - (Item_t (Option_t ((Contract_t (t, None), None), None, None), rest, annot)) + Lwt.return @@ parse_parameter_ty ctxt ~legacy ty >>=? fun (Ex_ty t, ctxt) -> + parse_entrypoint_annot loc annot ~default:(gen_access_annot addr_annot default_contract_annot) + >>=? fun (annot, entrypoint) -> + Lwt.return @@ begin match entrypoint with + | None -> Ok "default" + | Some (`Field_annot "default") -> error (Unexpected_annotation loc) + | Some (`Field_annot entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + error (Entrypoint_name_too_long entrypoint) + else Ok entrypoint + end >>=? fun entrypoint -> + typed ctxt loc (Contract (t, entrypoint)) + (Item_t (Option_t (Contract_t (t, None), None, false), rest, annot)) | Prim (loc, I_TRANSFER_TOKENS, [], annot), Item_t (p, Item_t (Mutez_t _, Item_t (Contract_t (cp, _), rest, _), _), _) -> - check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4 >>=? fun (Eq, ctxt) -> + check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4 >>=? fun (Eq, _, ctxt) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot)) | Prim (loc, I_SET_DELEGATE, [], annot), - Item_t (Option_t ((Key_hash_t _, _), _, _), rest, _) -> + Item_t (Option_t (Key_hash_t _, _, _), rest, _) -> parse_var_annot loc annot >>=? fun annot -> typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot)) | Prim (loc, I_CREATE_ACCOUNT, [], annot), Item_t (Key_hash_t _, Item_t - (Option_t ((Key_hash_t _, _), _, _), Item_t + (Option_t (Key_hash_t _, _, _), Item_t (Bool_t _, Item_t (Mutez_t _, rest, _), _), _), _) -> - parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> - typed ctxt loc Create_account - (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) + if legacy + then begin + (* For existing contracts, this instruction is still allowed *) + parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> + typed ctxt loc Create_account + (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) + end + else + (* For new contracts this instruction is not allowed anymore *) + fail (Deprecated_instruction I_CREATE_ACCOUNT) | Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _) -> parse_var_annot loc annot >>=? fun annot -> @@ -2557,44 +3016,103 @@ and parse_instr | Prim (loc, I_CREATE_CONTRACT, [ (Seq _ as code)], annot), Item_t (Key_hash_t _, Item_t - (Option_t ((Key_hash_t _, _), _, _), Item_t + (Option_t (Key_hash_t _, _, _), Item_t (Bool_t _, Item_t (Bool_t _, Item_t (Mutez_t _, Item_t (ginit, rest, _), _), _), _), _), _) -> + if legacy then begin + (* For existing contracts, this instruction is still allowed *) + parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> + let cannonical_code = fst @@ Micheline.extract_locations code in + Lwt.return @@ parse_toplevel ~legacy cannonical_code >>=? fun (arg_type, storage_type, code_field, root_name) -> + trace + (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) + (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type) + >>=? fun (Ex_ty arg_type, ctxt) -> + begin + if legacy then Error_monad.return () else + Lwt.return (well_formed_entrypoints ~root_name arg_type) + end >>=? fun () -> + trace + (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) + (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type) + >>=? fun (Ex_ty storage_type, ctxt) -> + let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot in + let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot in + let arg_type_full = Pair_t ((arg_type, None, arg_annot), + (storage_type, None, storage_annot), None, + has_big_map arg_type || has_big_map storage_type) in + let ret_type_full = + Pair_t ((List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), None, + has_big_map storage_type) in + trace + (Ill_typed_contract (cannonical_code, [])) + (parse_returning (Toplevel { storage_type ; param_type = arg_type ; root_name ; + legacy_create_contract_literal = true }) + ctxt ~legacy ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? + fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; + aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> + Lwt.return @@ ty_eq ctxt arg arg_type_full >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt ret ret_type_full >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt storage_type ginit >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit >>=? fun (_, ctxt) -> + typed ctxt loc (Create_contract (storage_type, arg_type, lambda, root_name)) + (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) + end + else + (* For new contracts this instruction is not allowed anymore *) + fail (Deprecated_instruction I_CREATE_CONTRACT) + | Prim (loc, I_CREATE_CONTRACT, [ (Seq _ as code)], annot), + (* Removed the instruction's arguments manager, spendable and delegatable *) + Item_t + (Option_t (Key_hash_t _, _, _), Item_t + (Mutez_t _, Item_t + (ginit, rest, _), _), _) -> parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> let cannonical_code = fst @@ Micheline.extract_locations code in - Lwt.return @@ parse_toplevel cannonical_code >>=? fun (arg_type, storage_type, code_field) -> + Lwt.return @@ parse_toplevel ~legacy cannonical_code >>=? fun (arg_type, storage_type, code_field, root_name) -> trace (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) - (Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type) + (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type) >>=? fun (Ex_ty arg_type, ctxt) -> + begin + if legacy then Error_monad.return () else + Lwt.return (well_formed_entrypoints ~root_name arg_type) + end >>=? fun () -> trace (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) - (Lwt.return @@ parse_storage_ty ctxt storage_type) + (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type) >>=? fun (Ex_ty storage_type, ctxt) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) ~default:default_param_annot in let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) ~default:default_storage_annot in let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None) in + (storage_type, None, storage_annot), None, + has_big_map arg_type || has_big_map storage_type) in let ret_type_full = - Pair_t ((List_t (Operation_t None, None), None, None), - (storage_type, None, None), None) in + Pair_t ((List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), None, has_big_map storage_type) in trace (Ill_typed_contract (cannonical_code, [])) - (parse_returning (Toplevel { storage_type ; param_type = arg_type }) - ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? + (parse_returning (Toplevel { storage_type ; param_type = arg_type ; root_name ; + legacy_create_contract_literal = false }) + ctxt ~legacy ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> Lwt.return @@ ty_eq ctxt arg arg_type_full >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ctxt loc arg arg_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full >>=? fun (_, ctxt) -> Lwt.return @@ ty_eq ctxt ret ret_type_full >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ctxt loc ret ret_type_full >>=? fun (_, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full >>=? fun (_, ctxt) -> Lwt.return @@ ty_eq ctxt storage_type ginit >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ctxt loc storage_type ginit >>=? fun (_, ctxt) -> - typed ctxt loc (Create_contract (storage_type, arg_type, lambda)) + Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit >>=? fun (_, ctxt) -> + typed ctxt loc (Create_contract_2 (storage_type, arg_type, lambda, root_name)) (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) | Prim (loc, I_NOW, [], annot), stack -> @@ -2605,6 +3123,11 @@ and parse_instr parse_var_annot loc annot ~default:default_amount_annot >>=? fun annot -> typed ctxt loc Amount (Item_t (Mutez_t None, stack, annot)) + | Prim (loc, I_CHAIN_ID, [], annot), + stack -> + parse_var_annot loc annot >>=? fun annot -> + typed ctxt loc ChainId + (Item_t (Chain_id_t None, stack, annot)) | Prim (loc, I_BALANCE, [], annot), stack -> parse_var_annot loc annot ~default:default_balance_annot >>=? fun annot -> @@ -2637,9 +3160,16 @@ and parse_instr (Item_t (Bytes_t None, rest, annot)) | Prim (loc, I_STEPS_TO_QUOTA, [], annot), stack -> - parse_var_annot loc annot ~default:default_steps_annot >>=? fun annot -> - typed ctxt loc Steps_to_quota - (Item_t (Nat_t None, stack, annot)) + if legacy + then begin + (* For existing contracts, this instruction is still allowed *) + parse_var_annot loc annot ~default:default_steps_annot >>=? fun annot -> + typed ctxt loc Steps_to_quota + (Item_t (Nat_t None, stack, annot)) + end + else + (* For new contracts this instruction is not allowed anymore *) + fail (Deprecated_instruction I_STEPS_TO_QUOTA) | Prim (loc, I_SOURCE, [], annot), stack -> parse_var_annot loc annot ~default:default_source_annot >>=? fun annot -> @@ -2652,16 +3182,22 @@ and parse_instr (Item_t (Address_t None, stack, annot)) | Prim (loc, I_SELF, [], annot), stack -> - parse_var_annot loc annot ~default:default_self_annot >>=? fun annot -> + parse_entrypoint_annot loc annot ~default:default_self_annot + >>=? fun (annot, entrypoint) -> + let entrypoint = Option.unopt_map ~f:(fun (`Field_annot annot) -> annot) ~default:"default" entrypoint in let rec get_toplevel_type : tc_context -> (bef judgement * context) tzresult Lwt.t = function | Lambda -> fail (Self_in_lambda loc) | Dip (_, prev) -> get_toplevel_type prev - | Toplevel { param_type ; _ } -> - typed ctxt loc (Self param_type) + | Toplevel { param_type ; root_name ; legacy_create_contract_literal = false} -> + Lwt.return (find_entrypoint param_type ~root_name entrypoint) >>=? fun (_, Ex_ty param_type) -> + typed ctxt loc (Self (param_type, entrypoint)) + (Item_t (Contract_t (param_type, None), stack, annot)) + | Toplevel { param_type ; root_name = _ ; legacy_create_contract_literal = true} -> + typed ctxt loc (Self (param_type, "default")) (Item_t (Contract_t (param_type, None), stack, annot)) in get_toplevel_type tc_context (* Primitive parsing errors *) - | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT + | Prim (loc, (I_DUP | I_SWAP | I_SOME | I_UNIT | I_PAIR | I_CAR | I_CDR | I_CONS | I_CONCAT | I_SLICE | I_MEM | I_UPDATE | I_MAP | I_GET | I_EXEC | I_FAILWITH | I_SIZE @@ -2672,7 +3208,7 @@ and parse_instr | I_COMPARE | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE | I_TRANSFER_TOKENS | I_CREATE_ACCOUNT - | I_CREATE_CONTRACT | I_SET_DELEGATE | I_NOW + | I_SET_DELEGATE | I_NOW | I_IMPLICIT_ACCOUNT | I_AMOUNT | I_BALANCE | I_CHECK_SIGNATURE | I_HASH_KEY | I_SOURCE | I_SENDER | I_BLAKE2B | I_SHA256 | I_SHA512 | I_STEPS_TO_QUOTA | I_ADDRESS @@ -2693,8 +3229,7 @@ and parse_instr fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l)) (* Stack errors *) | Prim (loc, (I_ADD | I_SUB | I_MUL | I_EDIV - | I_AND | I_OR | I_XOR | I_LSL | I_LSR - | I_COMPARE as name), [], _), + | I_AND | I_OR | I_XOR | I_LSL | I_LSR as name), [], _), Item_t (ta, Item_t (tb, _, _), _) -> Lwt.return @@ serialize_ty_for_error ctxt ta >>=? fun (ta, ctxt) -> Lwt.return @@ serialize_ty_for_error ctxt tb >>=? fun (tb, _ctxt) -> @@ -2709,7 +3244,7 @@ and parse_instr stack -> serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 3, stack)) - | Prim (loc, I_CREATE_CONTRACT, [], _), + | Prim (loc, I_CREATE_CONTRACT, _, _), stack -> serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) @@ -2741,7 +3276,8 @@ and parse_instr (* Generic parsing errors *) | expr, _ -> fail @@ unexpected expr [ Seq_kind ] Instr_namespace - [ I_DROP ; I_DUP ; I_SWAP ; I_SOME ; I_UNIT ; + [ I_DROP ; I_DUP; I_DIG; I_DUG; + I_SWAP ; I_SOME ; I_UNIT ; I_PAIR ; I_CAR ; I_CDR ; I_CONS ; I_MEM ; I_UPDATE ; I_MAP ; I_ITER ; I_GET ; I_EXEC ; I_FAILWITH ; I_SIZE ; @@ -2762,9 +3298,9 @@ and parse_instr I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SENDER ; I_SELF ; I_LAMBDA ] and parse_contract - : type arg. context -> Script.location -> arg ty -> Contract.t -> - (context * arg typed_contract) tzresult Lwt.t - = fun ctxt loc arg contract -> + : type arg. legacy: bool -> context -> Script.location -> arg ty -> Contract.t -> entrypoint:string -> + (context * arg typed_contract) tzresult Lwt.t + = fun ~legacy ctxt loc arg contract ~entrypoint -> Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt -> Contract.exists ctxt contract >>=? function | false -> fail (Invalid_contract (loc, contract)) @@ -2772,30 +3308,36 @@ and parse_contract Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> trace (Invalid_contract (loc, contract)) @@ - Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with + Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> match code with | None -> Lwt.return (ty_eq ctxt arg (Unit_t None) >>? fun (Eq, ctxt) -> - let contract : arg typed_contract = (arg, contract) in - ok (ctxt, contract)) - | Some { code ; _ } -> + match entrypoint with + | "default" -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + ok (ctxt, contract) + | entrypoint -> error (No_such_entrypoint entrypoint)) + | Some code -> Script.force_decode ctxt code >>=? fun (code, ctxt) -> Lwt.return - (parse_toplevel code >>? fun (arg_type, _, _) -> - parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type >>? fun (Ex_ty targ, ctxt) -> - ty_eq ctxt targ arg >>? fun (Eq, ctxt) -> - merge_types ctxt loc targ arg >>? fun (arg, ctxt) -> - let contract : arg typed_contract = (arg, contract) in - ok (ctxt, contract)) + (parse_toplevel ~legacy:true code >>? fun (arg_type, _, _, root_name) -> + parse_parameter_ty ctxt ~legacy:true arg_type >>? fun (Ex_ty targ, ctxt) -> + let return ctxt targ entrypoint = + merge_types ~legacy ctxt loc targ arg >>? fun (arg, ctxt) -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + ok (ctxt, contract) in + find_entrypoint_for_type ~full:targ ~expected:arg ~root_name entrypoint ctxt >>? fun (ctxt, entrypoint, targ) -> + merge_types ~legacy ctxt loc targ arg >>? fun (targ, ctxt) -> + return ctxt targ entrypoint) (* Same as the one above, but does not fail when the contact is missing or if the expected type doesn't match the actual one. In that case None is returned and some overapproximation of the typechecking gas is consumed. This can still fail on gas exhaustion. *) and parse_contract_for_script - : type arg. context -> Script.location -> arg ty -> Contract.t -> - (context * arg typed_contract option) tzresult Lwt.t - = fun ctxt loc arg contract -> + : type arg. legacy: bool -> context -> Script.location -> arg ty -> Contract.t -> entrypoint:string -> + (context * arg typed_contract option) tzresult Lwt.t + = fun ~legacy ctxt loc arg contract ~entrypoint -> Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt -> Contract.exists ctxt contract >>=? function | false -> return (ctxt, None) @@ -2803,43 +3345,48 @@ and parse_contract_for_script Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> trace (Invalid_contract (loc, contract)) @@ - Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with (* can only fail because of gas *) + Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> match code with (* can only fail because of gas *) | None -> - Lwt.return - (match ty_eq ctxt arg (Unit_t None) with - | Ok (Eq, ctxt) -> - let contract : arg typed_contract = (arg, contract) in - ok (ctxt, Some contract) - | Error _ -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - ok (ctxt, None)) - | Some { code ; _ } -> + begin match entrypoint with + | "default" -> + Lwt.return + (match ty_eq ctxt arg (Unit_t None) with + | Ok (Eq, ctxt) -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + ok (ctxt, Some contract) + | Error _ -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + ok (ctxt, None)) + | _ -> return (ctxt, None) + end + | Some code -> Script.force_decode ctxt code >>=? fun (code, ctxt) -> (* can only fail because of gas *) Lwt.return - (match parse_toplevel code with + (match parse_toplevel ~legacy:true code with | Error _ -> error (Invalid_contract (loc, contract)) - | Ok (arg_type, _, _) -> - match parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type with + | Ok (arg_type, _, _, root_name) -> + match parse_parameter_ty ctxt ~legacy:true arg_type with | Error _ -> error (Invalid_contract (loc, contract)) | Ok (Ex_ty targ, ctxt) -> match - (ty_eq ctxt targ arg >>? fun (Eq, ctxt) -> - merge_types ctxt loc targ arg >>? fun (arg, ctxt) -> - let contract : arg typed_contract = (arg, contract) in - ok (ctxt, Some contract)) + find_entrypoint_for_type ~full:targ ~expected:arg ~root_name entrypoint ctxt >>? fun (ctxt, entrypoint, targ) -> + merge_types ~legacy ctxt loc targ arg >>? fun (targ, ctxt) -> + merge_types ~legacy ctxt loc targ arg >>? fun (arg, ctxt) -> + let contract : arg typed_contract = (arg, (contract, entrypoint)) in + ok (ctxt, Some contract) with | Ok res -> ok res | Error _ -> (* overapproximation by checking if targ = targ, - can only fail because of gas *) + can only fail because of gas *) ty_eq ctxt targ targ >>? fun (Eq, ctxt) -> - merge_types ctxt loc targ targ >>? fun (_, ctxt) -> + merge_types ~legacy ctxt loc targ targ >>? fun (_, ctxt) -> ok (ctxt, None)) and parse_toplevel - : Script.expr -> (Script.node * Script.node * Script.node) tzresult - = fun toplevel -> + : legacy: bool -> Script.expr -> (Script.node * Script.node * Script.node * string option) tzresult + = fun ~legacy toplevel -> record_trace (Ill_typed_contract (toplevel, [])) @@ match root toplevel with | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) @@ -2854,19 +3401,19 @@ and parse_toplevel | String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_kind)) | Bytes (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Bytes_kind)) | Seq (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind)) - | Prim (loc, K_parameter, [ arg ], _) :: rest -> + | Prim (loc, K_parameter, [ arg ], annot) :: rest -> begin match p with - | None -> find_fields (Some arg) s c rest + | None -> find_fields (Some (arg, loc, annot)) s c rest | Some _ -> error (Duplicate_field (loc, K_parameter)) end - | Prim (loc, K_storage, [ arg ], _) :: rest -> + | Prim (loc, K_storage, [ arg ], annot) :: rest -> begin match s with - | None -> find_fields p (Some arg) c rest + | None -> find_fields p (Some (arg, loc, annot)) c rest | Some _ -> error (Duplicate_field (loc, K_storage)) end - | Prim (loc, K_code, [ arg ], _) :: rest -> + | Prim (loc, K_code, [ arg ], annot) :: rest -> begin match c with - | None -> find_fields p s (Some arg) rest + | None -> find_fields p s (Some (arg, loc, annot)) rest | Some _ -> error (Duplicate_field (loc, K_code)) end | Prim (loc, (K_parameter | K_storage | K_code as name), args, _) :: _ -> @@ -2879,70 +3426,106 @@ and parse_toplevel | (None, _, _) -> error (Missing_field K_parameter) | (Some _, None, _) -> error (Missing_field K_storage) | (Some _, Some _, None) -> error (Missing_field K_code) - | (Some p, Some s, Some c) -> ok (p, s, c) + | (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot)) -> + let maybe_root_name = + (* root name can be attached to either the parameter + primitive or the toplevel constructor *) + Script_ir_annot.extract_field_annot p >>? fun (p, root_name) -> + match root_name with + | Some (`Field_annot root_name) -> + ok (p, pannot, Some root_name) + | None -> + match pannot with + | [ single ] when Compare.Int.(String.length single > 0) && Compare.Char.(String.get single 0 = '%') -> + ok (p, [], Some (String.sub single 1 (String.length single - 1))) + | _ -> ok (p, pannot, None) in + if legacy then + (* legacy semantics ignores spurious annotations *) + let p, root_name = match maybe_root_name with Ok (p, _, root_name) -> (p, root_name) | Error _ -> (p, None) in + ok (p, s, c, root_name) + else + (* only one field annot is allowed to set the root entrypoint name *) + maybe_root_name >>? fun (p, pannot, root_name) -> + Script_ir_annot.error_unexpected_annot ploc pannot >>? fun () -> + Script_ir_annot.error_unexpected_annot cloc carrot >>? fun () -> + Script_ir_annot.error_unexpected_annot sloc sannot >>? fun () -> + ok (p, s, c, root_name) let parse_script : ?type_logger: type_logger -> - context -> Script.t -> (ex_script * context) tzresult Lwt.t - = fun ?type_logger ctxt { code ; storage } -> + context -> legacy: bool -> Script.t -> (ex_script * context) tzresult Lwt.t + = fun ?type_logger ctxt ~legacy { code ; storage } -> Script.force_decode ctxt code >>=? fun (code, ctxt) -> Script.force_decode ctxt storage >>=? fun (storage, ctxt) -> - Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) -> + Lwt.return @@ parse_toplevel ~legacy code >>=? fun (arg_type, storage_type, code_field, root_name) -> trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) + (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type)) >>=? fun (Ex_ty arg_type, ctxt) -> + begin + if legacy then return () else + Lwt.return (well_formed_entrypoints ~root_name arg_type) + end >>=? fun () -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_storage_ty ctxt storage_type)) + (Lwt.return (parse_storage_ty ctxt ~legacy storage_type)) >>=? fun (Ex_ty storage_type, ctxt) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) ~default:default_param_annot in let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) ~default:default_storage_annot in let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None) in + (storage_type, None, storage_annot), None, + has_big_map arg_type || has_big_map storage_type) in let ret_type_full = - Pair_t ((List_t (Operation_t None, None), None, None), - (storage_type, None, None), None) in + Pair_t ((List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), None, has_big_map storage_type) in trace_eval (fun () -> Lwt.return @@ serialize_ty_for_error ctxt storage_type >>|? fun (storage_type, _ctxt) -> Ill_typed_data (None, storage, storage_type)) - (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) -> + (parse_data ?type_logger ctxt ~legacy storage_type (root storage)) >>=? fun (storage, ctxt) -> trace (Ill_typed_contract (code, [])) - (parse_returning (Toplevel { storage_type ; param_type = arg_type }) - ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> - return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt) + (parse_returning (Toplevel { storage_type ; param_type = arg_type ; root_name ; + legacy_create_contract_literal = false}) + ctxt ~legacy ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> + return (Ex_script { code ; arg_type ; storage ; storage_type ; root_name }, ctxt) let typecheck_code : context -> Script.expr -> (type_map * context) tzresult Lwt.t = fun ctxt code -> - Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) -> + let legacy = false in + Lwt.return @@ parse_toplevel ~legacy code >>=? fun (arg_type, storage_type, code_field, root_name) -> let type_map = ref [] in - (* TODO: annotation checking *) trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) + (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type)) >>=? fun (Ex_ty arg_type, ctxt) -> + begin + if legacy then return () else + Lwt.return (well_formed_entrypoints ~root_name arg_type) + end >>=? fun () -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_storage_ty ctxt storage_type)) + (Lwt.return (parse_storage_ty ctxt ~legacy storage_type)) >>=? fun (Ex_ty storage_type, ctxt) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) ~default:default_param_annot in let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) ~default:default_storage_annot in let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None) in + (storage_type, None, storage_annot), None, + has_big_map arg_type || has_big_map storage_type) in let ret_type_full = - Pair_t ((List_t (Operation_t None, None), None, None), - (storage_type, None, None), None) in + Pair_t ((List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), None, + has_big_map storage_type) in let result = parse_returning - (Toplevel { storage_type ; param_type = arg_type }) - ctxt + (Toplevel { storage_type ; param_type = arg_type ; root_name ; + legacy_create_contract_literal = false }) + ctxt ~legacy ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) (arg_type_full, None) ret_type_full code_field in trace @@ -2954,17 +3537,56 @@ let typecheck_data : ?type_logger: type_logger -> context -> Script.expr * Script.expr -> context tzresult Lwt.t = fun ?type_logger ctxt (data, exp_ty) -> + let legacy = false in trace (Ill_formed_type (None, exp_ty, 0)) - (Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false (root exp_ty)) + (Lwt.return @@ parse_packable_ty ctxt ~legacy (root exp_ty)) >>=? fun (Ex_ty exp_ty, ctxt) -> trace_eval (fun () -> Lwt.return @@ serialize_ty_for_error ctxt exp_ty >>|? fun (exp_ty, _ctxt) -> Ill_typed_data (None, data, exp_ty)) - (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, ctxt) -> + (parse_data ?type_logger ctxt ~legacy exp_ty (root data)) >>=? fun (_, ctxt) -> return ctxt +module Entrypoints_map = Map.Make (String) + +let list_entrypoints (type full) (full : full ty) ctxt ~root_name = + let merge path annot (type t) (ty : t ty) reachable ((unreachables, all) as acc) = + match annot with + | None | Some (`Field_annot "") -> + ok @@ + if reachable then acc else + begin match ty with + | Union_t _ -> acc + | _ -> ( (List.rev path)::unreachables, all ) + end + | Some (`Field_annot name) -> + if Compare.Int.(String.length name > 31) then ok ((List.rev path)::unreachables, all) + else if Entrypoints_map.mem name all then ok ((List.rev path)::unreachables, all) + else unparse_ty_no_lwt ctxt ty >>? fun (unparsed_ty , _) -> + ok (unreachables, Entrypoints_map.add name ((List.rev path),unparsed_ty) all) + in + let rec fold_tree + : type t. t ty -> + prim list -> + bool -> + prim list list * (prim list * Script.node) Entrypoints_map.t -> + (prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult + = fun t path reachable acc -> + match t with + | Union_t ((tl, al), (tr, ar), _, _) -> + merge (D_Left :: path) al tl reachable acc >>? fun acc -> + merge (D_Right :: path) ar tr reachable acc >>? fun acc -> + fold_tree tl (D_Left :: path) (match al with Some _ -> true | None -> reachable) acc >>? fun acc -> + fold_tree tr (D_Right :: path) (match ar with Some _ -> true | None -> reachable) acc + | _ -> ok acc in + unparse_ty_no_lwt ctxt full >>? fun (unparsed_full , _) -> + let init, reachable = match root_name with + | None | Some "" -> Entrypoints_map.empty, false + | Some name -> Entrypoints_map.singleton name ([],unparsed_full), true in + fold_tree full [] reachable ([], init) + (* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) let rec unparse_data @@ -3003,23 +3625,37 @@ let rec unparse_data | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) | Some s -> return (String (-1, s), ctxt) end - | Address_t _, c -> + | Address_t _, (c, entrypoint) -> Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> begin match mode with | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + let entrypoint = match entrypoint with "default" -> "" | name -> name in + let bytes = Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) in return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + | Readable -> + let notation = match entrypoint with + | "default" -> Contract.to_b58check c + | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in + return (String (-1, notation), ctxt) end - | Contract_t _, (_, c) -> + | Contract_t _, (_, (c, entrypoint)) -> Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> begin match mode with | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + let entrypoint = match entrypoint with "default" -> "" | name -> name in + let bytes = Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) in return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + | Readable -> + let notation = match entrypoint with + | "default" -> Contract.to_b58check c + | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in + return (String (-1, notation), ctxt) end | Signature_t _, s -> Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> @@ -3054,31 +3690,35 @@ let rec unparse_data | Readable -> return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) end - | Operation_t _, op -> + | Operation_t _, (op, _big_map_diff) -> let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt) - | Pair_t ((tl, _, _), (tr, _, _), _), (l, r) -> + | Chain_id_t _, chain_id -> + let bytes = Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id in + Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r) -> Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> return (Prim (-1, D_Pair, [ l; r ], []), ctxt) - | Union_t ((tl, _), _, _), L l -> + | Union_t ((tl, _), _, _, _), L l -> Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> return (Prim (-1, D_Left, [ l ], []), ctxt) - | Union_t (_, (tr, _), _), R r -> + | Union_t (_, (tr, _), _, _), R r -> Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> return (Prim (-1, D_Right, [ r ], []), ctxt) - | Option_t ((t, _), _, _), Some v -> + | Option_t (t, _, _), Some v -> Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> unparse_data ctxt mode t v >>=? fun (v, ctxt) -> return (Prim (-1, D_Some, [ v ], []), ctxt) | Option_t _, None -> Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> return (Prim (-1, D_None, [], []), ctxt) - | List_t (t, _), items -> + | List_t (t, _, _), items -> fold_left_s (fun (l, ctxt) element -> Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> @@ -3097,7 +3737,7 @@ let rec unparse_data ([], ctxt) (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt) - | Map_t (kt, vt, _), map -> + | Map_t (kt, vt, _, _), map -> let kt = ty_of_comparable_ty kt in fold_left_s (fun (l, ctxt) (k, v) -> @@ -3108,16 +3748,37 @@ let rec unparse_data ([], ctxt) (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt) - | Big_map_t (_kt, _kv, _), _map -> - return (Micheline.Seq (-1, []), ctxt) + | Big_map_t (kt, vt, _), { id = None ; diff = (module Diff) ; _ } -> + (* this branch is to allow roundtrip of big map literals *) + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_data ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data ctxt mode vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (Diff.OPS.fold + (fun k v acc -> match v with | None -> acc | Some v -> (k, v) :: acc) + (fst Diff.boxed) []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (_kt, _kv, _), { id = Some id ; diff = (module Diff) ; _ } -> + if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then + return (Micheline.Int (-1, id), ctxt) + else + (* this can only be the result of an execution and the map + must have been flushed at this point *) + assert false | Lambda_t _, Lam (_, original_code) -> - unparse_code ctxt mode (root original_code) + unparse_code ctxt mode original_code (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) -and unparse_code ctxt mode = function +and unparse_code ctxt mode = + let legacy = true in + function | Prim (loc, I_PUSH, [ ty ; data ], annot) -> - Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) -> - parse_data ctxt t data >>=? fun (data, ctxt) -> + Lwt.return (parse_packable_ty ctxt ~legacy ty) >>=? fun (Ex_ty t, ctxt) -> + parse_data ctxt ~legacy t data >>=? fun (data, ctxt) -> unparse_data ctxt mode t data >>=? fun (data, ctxt) -> Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) @@ -3140,12 +3801,13 @@ and unparse_code ctxt mode = function | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt) (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) -let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } = +let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type ; root_name } = let Lam (_, original_code) = code in - unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) -> + unparse_code ctxt mode original_code >>=? fun (code, ctxt) -> unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) -> unparse_ty ctxt arg_type >>=? fun (arg_type, ctxt) -> unparse_ty ctxt storage_type >>=? fun (storage_type, ctxt) -> + let arg_type = add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None arg_type in let open Micheline in let code = Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ; @@ -3160,8 +3822,7 @@ let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } = storage = lazy_expr (strip_locations storage) }, ctxt) let pack_data ctxt typ data = - unparse_data ctxt Optimized typ data >>=? fun (data, ctxt) -> - let unparsed = strip_annotations @@ data in + unparse_data ctxt Optimized typ data >>=? fun (unparsed, ctxt) -> let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt -> let bytes = MBytes.concat "" [ MBytes.of_string "\005" ; bytes ] in @@ -3171,29 +3832,34 @@ let pack_data ctxt typ data = let hash_data ctxt typ data = pack_data ctxt typ data >>=? fun (bytes, ctxt) -> Lwt.return @@ Gas.consume ctxt - (Michelson_v1_gas.Cost_of.hash bytes Script_expr_hash.size) >>=? fun ctxt -> + (Michelson_v1_gas.Cost_of.Legacy.hash bytes Script_expr_hash.size) >>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt) (* ---------------- Big map -------------------------------------------------*) -let big_map_mem ctxt contract key { diff ; key_type ; _ } = - match map_get key diff with - | None -> hash_data ctxt key_type key >>=? fun (hash, ctxt) -> - Alpha_context.Contract.Big_map.mem ctxt contract hash >>=? fun (ctxt, res) -> - return (res, ctxt) - | Some None -> return (false, ctxt) - | Some (Some _) -> return (true, ctxt) +let empty_big_map tk tv = + { id = None ; diff = empty_map tk ; key_type = ty_of_comparable_ty tk ; value_type = tv } -let big_map_get ctxt contract key { diff ; key_type ; value_type } = - match map_get key diff with - | Some x -> return (x, ctxt) - | None -> +let big_map_mem ctxt key { id ; diff ; key_type ; _ } = + match map_get key diff, id with + | None, None -> return (false, ctxt) + | None, Some id -> hash_data ctxt key_type key >>=? fun (hash, ctxt) -> + Alpha_context.Big_map.mem ctxt id hash >>=? fun (ctxt, res) -> + return (res, ctxt) + | Some None, _ -> return (false, ctxt) + | Some (Some _), _ -> return (true, ctxt) + +let big_map_get ctxt key { id ; diff ; key_type ; value_type } = + match map_get key diff, id with + | Some x, _ -> return (x, ctxt) + | None, None -> return (None, ctxt) + | None, Some id -> hash_data ctxt key_type key >>=? fun (hash, ctxt) -> - Alpha_context.Contract.Big_map.get_opt - ctxt contract hash >>=? begin function + Alpha_context.Big_map.get_opt + ctxt id hash >>=? begin function | (ctxt, None) -> return (None, ctxt) | (ctxt, Some value) -> - parse_data ctxt value_type + parse_data ctxt ~legacy:true value_type (Micheline.root value) >>=? fun (x, ctxt) -> return (Some x, ctxt) end @@ -3201,8 +3867,37 @@ let big_map_get ctxt contract key { diff ; key_type ; value_type } = let big_map_update key value ({ diff ; _ } as map) = { map with diff = map_set key value diff } -let diff_of_big_map ctxt mode (Ex_bm { key_type ; value_type ; diff }) = - Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.map_to_list diff)) >>=? fun ctxt -> +module Ids = Set.Make (Compare.Z) + +type big_map_ids = Ids.t + +let no_big_map_id = Ids.empty + +let diff_of_big_map ctxt fresh mode ~ids { id ; key_type ; value_type ; diff } = + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff)) >>=? fun ctxt -> + begin match id with + | Some id -> + if Ids.mem id ids then + fresh ctxt >>=? fun (ctxt, duplicate) -> + return (ctxt, [ Contract.Copy (id, duplicate) ], duplicate) + else + (* The first occurence encountered of a big_map reuses the + ID. This way, the payer is only charged for the diff. + For this to work, this diff has to be put at the end of + the global diff, otherwise the duplicates will use the + updated version as a base. This is true because we add + this diff first in the accumulator of + `extract_big_map_updates`, and this accumulator is not + reversed before being flattened. *) + return (ctxt, [], id) + | None -> + fresh ctxt >>=? fun (ctxt, id) -> + unparse_ty ctxt key_type >>=? fun (kt, ctxt) -> + unparse_ty ctxt value_type >>=? fun (kv, ctxt) -> + return (ctxt, [ Contract.Alloc { big_map = id ; + key_type = Micheline.strip_locations kt ; + value_type = Micheline.strip_locations kv } ], id) + end >>=? fun (ctxt, init, big_map) -> let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in fold_left_s (fun (acc, ctxt) (key, value) -> @@ -3219,18 +3914,146 @@ let diff_of_big_map ctxt mode (Ex_bm { key_type ; value_type ; diff }) = return (Some (Micheline.strip_locations node), ctxt) end end >>=? fun (diff_value, ctxt) -> - let diff_item = Contract.{ diff_key ; diff_key_hash ; diff_value } in + let diff_item = Contract.Update { big_map ; diff_key ; diff_key_hash ; diff_value } in return (diff_item :: acc, ctxt)) - ([], ctxt) pairs - -(* Get the big map from a contract's storage if one exists *) -let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x -> - match (ty, x) with - | Pair_t ((Big_map_t (_, _, _), _, _), _, _), (map, _) -> Some (Ex_bm map) - | _, _ -> None - -let big_map_initialization ctxt mode (Ex_script { storage ; storage_type; _ }) = - match extract_big_map storage_type storage with - | None -> return (None, ctxt) - | Some bm -> - diff_of_big_map ctxt mode bm >>=? fun (bm, ctxt) -> return (Some bm, ctxt) + ([], ctxt) pairs >>=? fun (diff, ctxt) -> + return (init @ diff, big_map, ctxt) + +let rec extract_big_map_updates + : type a. context -> (context -> (context * Big_map.id) tzresult Lwt.t) -> + unparsing_mode -> Ids.t -> Contract.big_map_diff list -> a ty -> a -> + (context * a * Ids.t * Contract.big_map_diff list) tzresult Lwt.t + = fun ctxt fresh mode ids acc ty x -> + match (ty, x) with + | Big_map_t (_, _, _), map -> + diff_of_big_map ctxt fresh mode ids map >>=? fun (diff, id, ctxt) -> + let (module Map) = map.diff in + let map = { map with diff = empty_map Map.key_ty ; id = Some id } in + return (ctxt, map, Ids.add id ids, diff :: acc) + | Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc tyl xl >>=? fun (ctxt, xl, ids, acc) -> + extract_big_map_updates ctxt fresh mode ids acc tyr xr >>=? fun (ctxt, xr, ids, acc) -> + return (ctxt, (xl, xr), ids, acc) + | Union_t ((ty, _), (_, _), _, true), L x -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, L x, ids, acc) + | Union_t ((_, _), (ty, _), _, true), R x -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, R x, ids, acc) + | Option_t (ty, _, true), Some x -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, Some x, ids, acc) + | List_t (ty, _, true), l -> + fold_left_s + (fun (ctxt, l, ids, acc) x -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, x :: l, ids, acc)) + (ctxt, [], ids, acc) l >>=? fun (ctxt, l, ids, acc) -> + return (ctxt, List.rev l, ids, acc) + | Map_t (_, ty, _, true), ((module M) as m) -> + Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m)) >>=? fun ctxt -> + fold_left_s + (fun (ctxt, m, ids, acc) (k, x) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, M.OPS.add k x m, ids, acc)) + (ctxt, M.OPS.empty, ids, acc) (M.OPS.bindings (fst M.boxed)) >>=? fun (ctxt, m, ids, acc) -> + let module M = struct + module OPS = M.OPS + type key = M.key + type value = M.value + let key_ty = M.key_ty + let boxed = m, (snd M.boxed) + end in + return (ctxt, (module M : Boxed_map with type key = M.key and type value = M.value), ids, acc) + | Option_t (_, _, true), None -> return (ctxt, None, ids, acc) + | List_t (_, _, false), v -> return (ctxt, v, ids, acc) + | Map_t (_, _, _, false), v -> return (ctxt, v, ids, acc) + | Option_t (_, _, false), None -> return (ctxt, None, ids, acc) + | Pair_t (_, _, _, false), v -> return (ctxt, v, ids, acc) + | Union_t (_, _, _, false), v -> return (ctxt, v, ids, acc) + | Option_t (_, _, false), v -> return (ctxt, v, ids, acc) + | Chain_id_t _, v -> return (ctxt, v, ids, acc) + | Set_t (_, _), v -> return (ctxt, v, ids, acc) + | Unit_t _, v -> return (ctxt, v, ids, acc) + | Int_t _, v -> return (ctxt, v, ids, acc) + | Nat_t _, v -> return (ctxt, v, ids, acc) + | Signature_t _, v -> return (ctxt, v, ids, acc) + | String_t _, v -> return (ctxt, v, ids, acc) + | Bytes_t _, v -> return (ctxt, v, ids, acc) + | Mutez_t _, v -> return (ctxt, v, ids, acc) + | Key_hash_t _, v -> return (ctxt, v, ids, acc) + | Key_t _, v -> return (ctxt, v, ids, acc) + | Timestamp_t _, v -> return (ctxt, v, ids, acc) + | Address_t _, v -> return (ctxt, v, ids, acc) + | Bool_t _, v -> return (ctxt, v, ids, acc) + | Lambda_t (_, _, _), v -> return (ctxt, v, ids, acc) + | Contract_t (_, _), v -> return (ctxt, v, ids, acc) + | Operation_t _, _ -> assert false (* called only on parameters and storage, which cannot contain operations *) + +let collect_big_maps ctxt ty x = + let rec collect + : type a. context -> a ty -> a -> Ids.t -> (Ids.t * context) tzresult + = fun ctxt ty x acc -> + match (ty, x) with + | Big_map_t (_, _, _), { id = Some id } -> + Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + ok (Ids.add id acc, ctxt) + | Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr) -> + collect ctxt tyl xl acc >>? fun (acc, ctxt) -> + collect ctxt tyr xr acc + | Union_t ((ty, _), (_, _), _, true), L x -> + collect ctxt ty x acc + | Union_t ((_, _), (ty, _), _, true), R x -> + collect ctxt ty x acc + | Option_t (ty, _, true), Some x -> + collect ctxt ty x acc + | List_t (ty, _, true), l -> + List.fold_left (fun acc x -> acc >>? fun (acc, ctxt) -> collect ctxt ty x acc) (ok (acc, ctxt)) l + | Map_t (_, ty, _, true), m -> + map_fold (fun _ v acc -> acc >>? fun (acc, ctxt) -> collect ctxt ty v acc) m (ok (acc, ctxt)) + | List_t (_, _, false), _ -> ok (acc, ctxt) + | Map_t (_, _, _, false), _ -> ok (acc, ctxt) + | Big_map_t (_, _, _), { id = None } -> ok (acc, ctxt) + | Option_t (_, _, true), None -> ok (acc, ctxt) + | Option_t (_, _, false), _ -> ok (acc, ctxt) + | Union_t (_, _, _, false), _ -> ok (acc, ctxt) + | Pair_t (_, _, _, false), _ -> ok (acc, ctxt) + | Chain_id_t _, _ -> ok (acc, ctxt) + | Set_t (_, _), _ -> ok (acc, ctxt) + | Unit_t _, _ -> ok (acc, ctxt) + | Int_t _, _ -> ok (acc, ctxt) + | Nat_t _, _ -> ok (acc, ctxt) + | Signature_t _, _ -> ok (acc, ctxt) + | String_t _, _ -> ok (acc, ctxt) + | Bytes_t _, _ -> ok (acc, ctxt) + | Mutez_t _, _ -> ok (acc, ctxt) + | Key_hash_t _, _ -> ok (acc, ctxt) + | Key_t _, _ -> ok (acc, ctxt) + | Timestamp_t _, _ -> ok (acc, ctxt) + | Address_t _, _ -> ok (acc, ctxt) + | Bool_t _, _ -> ok (acc, ctxt) + | Lambda_t (_, _, _), _ -> ok (acc, ctxt) + | Contract_t (_, _), _ -> ok (acc, ctxt) + | Operation_t _, _ -> assert false (* called only on parameters and storage, which cannot contain operations *) in + Lwt.return (collect ctxt ty x no_big_map_id) + +let extract_big_map_diff ctxt mode + ~temporary ~to_duplicate ~to_update + ty v = + let to_duplicate = Ids.diff to_duplicate to_update in + let fresh = if temporary then (fun c -> return (Big_map.fresh_temporary c)) else Big_map.fresh in + extract_big_map_updates ctxt fresh mode to_duplicate [] ty v >>=? fun (ctxt, v, alive, diffs) -> + let diffs = if temporary then diffs else + let dead = Ids.diff to_update alive in + Ids.fold (fun id acc -> Contract.Clear id :: acc) dead [] :: diffs in + match diffs with + | [] -> return (v, None, ctxt) + | diffs -> return (v, Some (List.flatten diffs (* do not reverse *)), ctxt) + +let list_of_big_map_ids ids = Ids.elements ids diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 001bfa1dd5b085402f9400a31e547eb392194864..41843bb3479411390a6fe656f04b475efc184ad3 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -32,6 +32,17 @@ type ex_comparable_ty = Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> e type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script +type tc_context = + | Lambda : tc_context + | Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context + | Toplevel : { storage_type : 'sto Script_typed_ir.ty ; + param_type : 'param Script_typed_ir.ty ; + root_name : string option ; + legacy_create_contract_literal : bool } -> tc_context +type 'bef judgement = + | Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement + | Failed : + { descr : 'aft. 'aft Script_typed_ir.stack_ty -> ('bef, 'aft) Script_typed_ir.descr } -> 'bef judgement type unparsing_mode = Optimized | Readable @@ -59,13 +70,13 @@ val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num +val empty_big_map : 'a Script_typed_ir.comparable_ty -> 'b Script_typed_ir.ty -> ('a, 'b) Script_typed_ir.big_map val big_map_mem : - context -> Contract.t -> 'key -> + context -> 'key -> ('key, 'value) Script_typed_ir.big_map -> (bool * context) tzresult Lwt.t val big_map_get : - context -> - Contract.t -> 'key -> + context -> 'key -> ('key, 'value) Script_typed_ir.big_map -> ('value option * context) tzresult Lwt.t val big_map_update : @@ -77,25 +88,39 @@ val ty_eq : 'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty -> (('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult +val compare_comparable : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> int + val parse_data : ?type_logger: type_logger -> - context -> + context -> legacy: bool -> 'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t val unparse_data : context -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult Lwt.t +val parse_instr : + ?type_logger: type_logger -> + tc_context -> context -> legacy: bool -> + Script.node -> 'bef Script_typed_ir.stack_ty -> ('bef judgement * context) tzresult Lwt.t + val parse_ty : - context -> + context -> legacy: bool -> allow_big_map: bool -> allow_operation: bool -> + allow_contract: bool -> Script.node -> (ex_ty * context) tzresult +val parse_packable_ty : + context -> legacy: bool -> Script.node -> (ex_ty * context) tzresult + val unparse_ty : context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t val parse_toplevel : - Script.expr -> (Script.node * Script.node * Script.node) tzresult + legacy: bool -> Script.expr -> (Script.node * Script.node * Script.node * string option) tzresult + +val add_field_annot : + [ `Field_annot of string ] option -> [ `Var_annot of string ] option -> Script.node -> Script.node val typecheck_code : context -> Script.expr -> (type_map * context) tzresult Lwt.t @@ -106,7 +131,7 @@ val typecheck_data : val parse_script : ?type_logger: type_logger -> - context -> Script.t -> (ex_script * context) tzresult Lwt.t + context -> legacy: bool -> Script.t -> (ex_script * context) tzresult Lwt.t (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) val unparse_script : @@ -114,23 +139,44 @@ val unparse_script : ('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t val parse_contract : - context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + legacy: bool -> context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + entrypoint: string -> (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t val parse_contract_for_script : - context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + legacy: bool -> context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> + entrypoint: string -> (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t +val find_entrypoint : + 't Script_typed_ir.ty -> root_name: string option -> string -> ((Script.node -> Script.node) * ex_ty) tzresult + +module Entrypoints_map : S.MAP with type key = string + +val list_entrypoints : + 't Script_typed_ir.ty -> + context -> + root_name: string option -> + (Michelson_v1_primitives.prim list list * + (Michelson_v1_primitives.prim list * Script.node) Entrypoints_map.t) + tzresult + val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t -val extract_big_map : - 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option +type big_map_ids -val diff_of_big_map : - context -> unparsing_mode -> Script_typed_ir.ex_big_map -> - (Contract.big_map_diff * context) tzresult Lwt.t +val no_big_map_id : big_map_ids -val big_map_initialization : - context -> unparsing_mode -> ex_script -> - (Contract.big_map_diff option * context) tzresult Lwt.t +val collect_big_maps : + context -> 'a Script_typed_ir.ty -> 'a -> (big_map_ids * context) tzresult Lwt.t + +val list_of_big_map_ids : big_map_ids -> Z.t list + +val extract_big_map_diff : + context -> unparsing_mode -> + temporary: bool -> + to_duplicate: big_map_ids -> + to_update: big_map_ids -> + 'a Script_typed_ir.ty -> 'a -> + ('a * Contract.big_map_diff option * context) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/script_repr.ml b/src/proto_alpha/lib_protocol/script_repr.ml index c51cfd8f3e60c60d4a28f1124e3650c4845a53e4..81effec8f0169ffc14cef4bfd96485b2a47558a6 100644 --- a/src/proto_alpha/lib_protocol/script_repr.ml +++ b/src/proto_alpha/lib_protocol/script_repr.ml @@ -62,7 +62,7 @@ let lazy_expr expr = type t = { code : lazy_expr ; - storage : lazy_expr + storage : lazy_expr ; } let encoding = @@ -195,3 +195,25 @@ let minimal_deserialize_cost lexpr = ~fun_bytes:(fun b -> serialized_cost b) ~fun_combine:(fun c_free _ -> c_free) lexpr + +let unit = + Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], [])) + +let unit_parameter = + lazy_expr unit + +let is_unit_parameter = + let unit_bytes = Data_encoding.force_bytes unit_parameter in + Data_encoding.apply_lazy + ~fun_value:(fun v -> match Micheline.root v with Prim (_, Michelson_v1_primitives.D_Unit, [], []) -> true | _ -> false) + ~fun_bytes:(fun b -> MBytes.(=) b unit_bytes) + ~fun_combine:(fun res _ -> res) + +let rec strip_annotations node = + let open Micheline in + match node with + | Int (_, _) | String (_, _) | Bytes (_, _) as leaf -> leaf + | Prim (loc, name, args, _) -> + Prim (loc, name, List.map strip_annotations args, []) + | Seq (loc, args) -> + Seq (loc, List.map strip_annotations args) diff --git a/src/proto_alpha/lib_protocol/script_repr.mli b/src/proto_alpha/lib_protocol/script_repr.mli index 34dc0d90a851354c840f6ad3eb26eccaa6e15ba2..d44e137e4197b530e86eda4a1d63a94de978e05a 100644 --- a/src/proto_alpha/lib_protocol/script_repr.mli +++ b/src/proto_alpha/lib_protocol/script_repr.mli @@ -69,3 +69,9 @@ val force_decode : lazy_expr -> (expr * Gas_limit_repr.cost) tzresult val force_bytes : lazy_expr -> (MBytes.t * Gas_limit_repr.cost) tzresult val minimal_deserialize_cost : lazy_expr -> Gas_limit_repr.cost + +val unit_parameter : lazy_expr + +val is_unit_parameter : lazy_expr -> bool + +val strip_annotations : node -> node diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index e0ec2ff63d6aaea0061864a7bd19decbbfc5d394..3d0e0ea8572c585314bc864a69c1fcfa1db631c6 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -44,6 +44,11 @@ type error += Missing_field of prim type error += Duplicate_field of Script.location * prim type error += Unexpected_big_map of Script.location type error += Unexpected_operation of Script.location +type error += Unexpected_contract of Script.location +type error += No_such_entrypoint of string +type error += Duplicate_entrypoint of string +type error += Unreachable_entrypoint of prim list +type error += Entrypoint_name_too_long of string (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location @@ -67,7 +72,9 @@ type error += Type_too_large : Script.location * int * int -> error (* Value typing errors *) type error += Invalid_constant : Script.location * Script.expr * Script.expr -> error +type error += Invalid_syntactic_constant : Script.location * Script.expr * string -> error type error += Invalid_contract of Script.location * Contract.t +type error += Invalid_big_map of Script.location * Big_map.id type error += Comparable_type_expected : Script.location * Script.expr -> error type error += Inconsistent_types : Script.expr * Script.expr -> error type error += Unordered_map_keys of Script.location * Script.expr @@ -82,3 +89,6 @@ type error += Ill_typed_contract : Script.expr * type_map -> error (* Gas related errors *) type error += Cannot_serialize_error + +(* Deprecation errors *) +type error += Deprecated_instruction of prim diff --git a/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml index 10347b6a7b5ec69a233c3ae9681dd81b84a0fbfb..e8a33c5fe929853008506bece6822fded88fdb26 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors_registration.ml @@ -170,8 +170,9 @@ let () = ~id:"michelson_v1.unexpected_bigmap" ~title: "Big map in unauthorized position (type error)" ~description: - "When parsing script, a big_map type was found somewhere else \ - than in the left component of the toplevel storage pair." + "When parsing script, a big_map type was found in a position \ + where it could end up stored inside a big_map, which is \ + forbidden for now." (obj1 (req "loc" location_encoding)) (function Unexpected_big_map loc -> Some loc | _ -> None) @@ -180,14 +181,70 @@ let () = register_error_kind `Permanent ~id:"michelson_v1.unexpected_operation" - ~title: "Big map in unauthorized position (type error)" + ~title: "Operation in unauthorized position (type error)" ~description: - "When parsing script, a operation type was found \ + "When parsing script, an operation type was found \ in the storage or parameter field." (obj1 (req "loc" location_encoding)) (function Unexpected_operation loc -> Some loc | _ -> None) (fun loc -> Unexpected_operation loc) ; + (* No such entrypoint *) + register_error_kind + `Permanent + ~id:"michelson_v1.no_such_entrypoint" + ~title: "No such entrypoint (type error)" + ~description: + "An entrypoint was not found when calling a contract." + (obj1 + (req "entrypoint" string)) + (function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> No_such_entrypoint entrypoint) ; + (* Unreachable entrypoint *) + register_error_kind + `Permanent + ~id:"michelson_v1.unreachable_entrypoint" + ~title: "Unreachable entrypoint (type error)" + ~description: + "An entrypoint in the contract is not reachable." + (obj1 + (req "path" (list prim_encoding))) + (function Unreachable_entrypoint path -> Some path | _ -> None) + (fun path -> Unreachable_entrypoint path) ; + (* Duplicate entrypoint *) + register_error_kind + `Permanent + ~id:"michelson_v1.duplicate_entrypoint" + ~title: "Duplicate entrypoint (type error)" + ~description: + "Two entrypoints have the same name." + (obj1 + (req "path" string)) + (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> Duplicate_entrypoint entrypoint) ; + (* Entrypoint name too long *) + register_error_kind + `Permanent + ~id:"michelson_v1.entrypoint_name_too_long" + ~title: "Entrypoint name too long (type error)" + ~description: + "An entrypoint name exceeds the maximum length of 31 characters." + (obj1 + (req "name" string)) + (function Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None) + (fun entrypoint -> Entrypoint_name_too_long entrypoint) ; + (* Unexpected contract *) + register_error_kind + `Permanent + ~id:"michelson_v1.unexpected_contract" + ~title: "Contract in unauthorized position (type error)" + ~description: + "When parsing script, a contract type was found \ + in the storage or parameter field." + (obj1 + (req "loc" location_encoding)) + (function Unexpected_contract loc -> Some loc | _ -> None) + (fun loc -> Unexpected_contract loc) ; (* -- Value typing errors ---------------------- *) (* Unordered map keys *) register_error_kind @@ -454,6 +511,22 @@ let () = | _ -> None) (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ; + (* Invalid syntactic constant *) + register_error_kind + `Permanent + ~id:"invalidSyntacticConstantError" + ~title: "Invalid constant (parse error)" + ~description: + "A compile-time constant was invalid for its expected form." + (located (obj2 + (req "expectedForm" Script.expr_encoding) + (req "wrongExpression" Script.expr_encoding))) + (function + | Invalid_constant (loc, expr, ty) -> + Some (loc, (ty, expr)) + | _ -> None) + (fun (loc, (ty, expr)) -> + Invalid_constant (loc, expr, ty)) ; (* Invalid contract *) register_error_kind `Permanent @@ -469,6 +542,21 @@ let () = | _ -> None) (fun (loc, c) -> Invalid_contract (loc, c)) ; + (* Invalid big_map *) + register_error_kind + `Permanent + ~id:"michelson_v1.invalid_big_map" + ~title: "Invalid big_map" + ~description: + "A script or data expression references a big_map that does not \ + exist or assumes a wrong type for an existing big_map." + (located (obj1 (req "big_map" z))) + (function + | Invalid_big_map (loc, c) -> + Some (loc, c) + | _ -> None) + (fun (loc, c) -> + Invalid_big_map (loc, c)) ; (* Comparable type expected *) register_error_kind `Permanent @@ -619,4 +707,14 @@ let () = the provided gas" Data_encoding.empty (function Cannot_serialize_error -> Some () | _ -> None) - (fun () -> Cannot_serialize_error) + (fun () -> Cannot_serialize_error) ; + (* Deprecated instruction *) + register_error_kind + `Permanent + ~id:"michelson_v1.deprecated_instruction" + ~title:"Script is using a deprecated instruction" + ~description: + "A deprecated instruction usage is disallowed in newly created contracts" + (obj1 (req "prim" prim_encoding)) + (function Deprecated_instruction prim -> Some prim | _ -> None) + (fun prim -> Deprecated_instruction prim) ; diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 7656fc44a9881af9b3cd2cf204d9f995e36039a2..d536ecec879805ead02eae37312753e244016e72 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -34,20 +34,35 @@ type field_annot = [ `Field_annot of string ] type annot = [ var_annot | type_annot | field_annot ] -type 'ty comparable_ty = - | Int_key : type_annot option -> (z num) comparable_ty - | Nat_key : type_annot option -> (n num) comparable_ty - | String_key : type_annot option -> string comparable_ty - | Bytes_key : type_annot option -> MBytes.t comparable_ty - | Mutez_key : type_annot option -> Tez.t comparable_ty - | Bool_key : type_annot option -> bool comparable_ty - | Key_hash_key : type_annot option -> public_key_hash comparable_ty - | Timestamp_key : type_annot option -> Script_timestamp.t comparable_ty - | Address_key : type_annot option -> Contract.t comparable_ty +type address = Contract.t * string +type ('a, 'b) pair = 'a * 'b + +type ('a, 'b) union = L of 'a | R of 'b + +type comb = Comb +type leaf = Leaf + +type (_, _) comparable_struct = + | Int_key : type_annot option -> (z num, _) comparable_struct + | Nat_key : type_annot option -> (n num, _) comparable_struct + | String_key : type_annot option -> (string, _) comparable_struct + | Bytes_key : type_annot option -> (MBytes.t, _) comparable_struct + | Mutez_key : type_annot option -> (Tez.t, _) comparable_struct + | Bool_key : type_annot option -> (bool, _) comparable_struct + | Key_hash_key : type_annot option -> (public_key_hash, _) comparable_struct + | Timestamp_key : type_annot option -> (Script_timestamp.t, _) comparable_struct + | Address_key : type_annot option -> (address, _) comparable_struct + | Pair_key : + (('a, leaf) comparable_struct * field_annot option) * + (('b, _) comparable_struct * field_annot option) * + type_annot option -> (('a, 'b) pair, comb) comparable_struct + +type 'a comparable_ty = ('a, comb) comparable_struct module type Boxed_set = sig type elt + val elt_ty : elt comparable_ty module OPS : S.SET with type elt = elt val boxed : OPS.t val size : int @@ -65,23 +80,21 @@ end type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value) +type operation = packed_internal_operation * Contract.big_map_diff option + type ('arg, 'storage) script = - { code : (('arg, 'storage) pair, (packed_internal_operation list, 'storage) pair) lambda ; + { code : (('arg, 'storage) pair, (operation list, 'storage) pair) lambda ; arg_type : 'arg ty ; storage : 'storage ; - storage_type : 'storage ty } - -and ('a, 'b) pair = 'a * 'b - -and ('a, 'b) union = L of 'a | R of 'b + storage_type : 'storage ty ; + root_name : string option } and end_of_stack = unit and ('arg, 'ret) lambda = - Lam of ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.expr + Lam : ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node -> ('arg, 'ret) lambda -and 'arg typed_contract = - 'arg ty * Contract.t +and 'arg typed_contract = 'arg ty * address and 'ty ty = | Unit_t : type_annot option -> unit ty @@ -94,39 +107,48 @@ and 'ty ty = | Key_hash_t : type_annot option -> public_key_hash ty | Key_t : type_annot option -> public_key ty | Timestamp_t : type_annot option -> Script_timestamp.t ty - | Address_t : type_annot option -> Contract.t ty + | Address_t : type_annot option -> address ty | Bool_t : type_annot option -> bool ty | Pair_t : ('a ty * field_annot option * var_annot option) * ('b ty * field_annot option * var_annot option) * - type_annot option -> ('a, 'b) pair ty - | Union_t : ('a ty * field_annot option) * ('b ty * field_annot option) * type_annot option -> ('a, 'b) union ty + type_annot option * + bool -> ('a, 'b) pair ty + | Union_t : + ('a ty * field_annot option) * + ('b ty * field_annot option) * + type_annot option * + bool -> ('a, 'b) union ty | Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty - | Option_t : ('v ty * field_annot option) * field_annot option * type_annot option -> 'v option ty - | List_t : 'v ty * type_annot option -> 'v list ty + | Option_t : 'v ty * type_annot option * bool -> 'v option ty + | List_t : 'v ty * type_annot option * bool -> 'v list ty | Set_t : 'v comparable_ty * type_annot option -> 'v set ty - | Map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) map ty + | Map_t : 'k comparable_ty * 'v ty * type_annot option * bool -> ('k, 'v) map ty | Big_map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) big_map ty | Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty - | Operation_t : type_annot option -> packed_internal_operation ty + | Operation_t : type_annot option -> operation ty + | Chain_id_t : type_annot option -> Chain_id.t ty and 'ty stack_ty = | Item_t : 'ty ty * 'rest stack_ty * var_annot option -> ('ty * 'rest) stack_ty | Empty_t : end_of_stack stack_ty -and ('key, 'value) big_map = { diff : ('key, 'value option) map ; +and ('key, 'value) big_map = { id : Z.t option ; + diff : ('key, 'value option) map ; key_type : 'key ty ; value_type : 'value ty } (* ---- Instructions --------------------------------------------------------*) (* The low-level, typed instructions, as a GADT whose parameters - encode the typing rules. The left parameter is the typed shape of - the stack before the instruction, the right one the shape - after. Any program whose construction is accepted by OCaml's - type-checker is guaranteed to be type-safe. Overloadings of the - concrete syntax are already resolved in this representation, either - by using different constructors or type witness parameters. *) + encode the typing rules. + + The left parameter is the typed shape of the stack before the + instruction, the right one the shape after. Any program whose + construction is accepted by OCaml's type-checker is guaranteed to + be type-safe. Overloadings of the concrete syntax are already + resolved in this representation, either by using different + constructors or type witness parameters. *) and ('bef, 'aft) instr = (* stack ops *) | Drop : @@ -195,6 +217,8 @@ and ('bef, 'aft) instr = ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr (* big maps *) + | Empty_big_map : 'a comparable_ty * 'v ty -> + ('rest, ('a, 'v) big_map * 'rest) instr | Big_map_mem : ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr | Big_map_get : @@ -232,10 +256,7 @@ and ('bef, 'aft) instr = | Diff_timestamps : (Script_timestamp.t * (Script_timestamp.t * 'rest), z num * 'rest) instr - (* currency operations *) - (* TODO: we can either just have conversions to/from integers and - do all operations on integers, or we need more operations on - Tez. Also Sub_tez should return Tez.t option (if negative) and *) + (* tez operations *) | Add_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr | Sub_tez : @@ -323,6 +344,8 @@ and ('bef, 'aft) instr = ('top * 'bef, 'top * 'aft) instr | Exec : ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr + | Apply : 'arg ty -> + ('arg * (('arg * 'remaining, 'ret) lambda * 'rest), ('remaining, 'ret) lambda * 'rest) instr | Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr | Failwith : @@ -345,24 +368,25 @@ and ('bef, 'aft) instr = (z num * 'rest, bool * 'rest) instr | Ge : (z num * 'rest, bool * 'rest) instr - (* protocol *) | Address : - (_ typed_contract * 'rest, Contract.t * 'rest) instr - | Contract : 'p ty -> - (Contract.t * 'rest, 'p typed_contract option * 'rest) instr + (_ typed_contract * 'rest, address * 'rest) instr + | Contract : 'p ty * string -> + (address * 'rest, 'p typed_contract option * 'rest) instr | Transfer_tokens : - ('arg * (Tez.t * ('arg typed_contract * 'rest)), packed_internal_operation * 'rest) instr + ('arg * (Tez.t * ('arg typed_contract * 'rest)), operation * 'rest) instr | Create_account : (public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))), - packed_internal_operation * (Contract.t * 'rest)) instr + operation * (address * 'rest)) instr | Implicit_account : (public_key_hash * 'rest, unit typed_contract * 'rest) instr - | Create_contract : 'g ty * 'p ty * ('p * 'g, packed_internal_operation list * 'g) lambda -> + | Create_contract : 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option -> (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))), - packed_internal_operation * (Contract.t * 'rest)) instr + operation * (address * 'rest)) instr + | Create_contract_2 : 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option -> + (public_key_hash option * (Tez.t * ('g * 'rest)), operation * (address * 'rest)) instr | Set_delegate : - (public_key_hash option * 'rest, packed_internal_operation * 'rest) instr + (public_key_hash option * 'rest, operation * 'rest) instr | Now : ('rest, Script_timestamp.t * 'rest) instr | Balance : @@ -384,13 +408,35 @@ and ('bef, 'aft) instr = | Steps_to_quota : (* TODO: check that it always returns a nat *) ('rest, n num * 'rest) instr | Source : - ('rest, Contract.t * 'rest) instr + ('rest, address * 'rest) instr | Sender : - ('rest, Contract.t * 'rest) instr - | Self : 'p ty -> + ('rest, address * 'rest) instr + | Self : 'p ty * string -> ('rest, 'p typed_contract * 'rest) instr | Amount : ('rest, Tez.t * 'rest) instr + | Dig : int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness -> + ('bef, 'x * 'aft) instr + | Dug : int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness -> + ('x * 'bef, 'aft) instr + | Dipn : int * ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness * ('fbef, 'faft) descr -> + ('bef, 'aft) instr + | Dropn : int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness -> + ('bef, 'rest) instr + | ChainId : + ('rest, Chain_id.t * 'rest) instr + +(* Type witness for operations that work deep in the stack ignoring + (and preserving) a prefix. + + The two right parameters are the shape of the stack with the (same) + prefix before and after the transformation. The two left + parameters are the shape of the stack without the prefix before and + after. The inductive definition makes it so by construction. *) +and ('bef, 'aft, 'bef_suffix, 'aft_suffix) stack_prefix_preservation_witness = + | Prefix : ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + -> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness + | Rest : ('bef, 'aft, 'bef, 'aft) stack_prefix_preservation_witness and ('bef, 'aft) descr = { loc : Script.location ; diff --git a/src/proto_alpha/lib_protocol/seed_repr.mli b/src/proto_alpha/lib_protocol/seed_repr.mli index ae9827c8e32a0240d8cfc7e1d6384bb252cbedb7..d8ed774cebdb8443972a4c11415c195e7d138a17 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.mli +++ b/src/proto_alpha/lib_protocol/seed_repr.mli @@ -33,7 +33,7 @@ seed such that the generated sequence is a given one. *) -(** {2 Random Generation} ****************************************************) +(** {2 Random Generation} *) (** The state of the random number generator *) type t @@ -56,7 +56,7 @@ val take : sequence -> MBytes.t * sequence (** Generates the next random value as a bounded [int32] *) val take_int32 : sequence -> int32 -> int32 * sequence -(** {2 Predefined seeds} *****************************************************) +(** {2 Predefined seeds} *) val empty : seed @@ -68,7 +68,7 @@ val deterministic_seed : seed -> seed concatenated with a constant. *) val initial_seeds : int -> seed list -(** {2 Entropy} **************************************************************) +(** {2 Entropy} *) (** A nonce for adding entropy to the generator *) type nonce @@ -88,12 +88,12 @@ val check_hash : nonce -> Nonce_hash.t -> bool (** For using nonce hashes as keys in the hierarchical database *) val nonce_hash_key_part : Nonce_hash.t -> string list -> string list -(** {2 Predefined nonce} *****************************************************) +(** {2 Predefined nonce} *) val initial_nonce_0 : nonce val initial_nonce_hash_0 : Nonce_hash.t -(** {2 Serializers} **********************************************************) +(** {2 Serializers} *) val nonce_encoding : nonce Data_encoding.t val seed_encoding : seed Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/services_registration.ml b/src/proto_alpha/lib_protocol/services_registration.ml index 120afb9cf1526add5facdb804bb06cfbea7b8faa..3113307f7c13eded1550b9784c433e55527e2134 100644 --- a/src/proto_alpha/lib_protocol/services_registration.ml +++ b/src/proto_alpha/lib_protocol/services_registration.ml @@ -35,7 +35,11 @@ let rpc_init ({ block_hash ; block_header ; context } : Updater.rpc_context) = let level = block_header.level in let timestamp = block_header.timestamp in let fitness = block_header.fitness in - Alpha_context.prepare ~level ~timestamp ~fitness context >>=? fun context -> + Alpha_context.prepare + ~level + ~predecessor_timestamp:timestamp + ~timestamp + ~fitness context >>=? fun context -> return { block_hash ; block_header ; context } let rpc_services = ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t) diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index b2e3fd9198564a5e61b099c6997e7d35fe41c560..5d2ec65c9784f02714e39b9f490c25c5ec9cbf11 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -36,7 +36,7 @@ module Int32 = struct end module Z = struct - type t = Z.t + include Z let encoding = Data_encoding.z end @@ -66,8 +66,15 @@ module Make_index(H : Storage_description.INDEX) } end +module Block_priority = + Make_single_data_storage(Registered) + (Raw_context) + (struct let name = ["block_priority"] end) + (Int) + +(* Only for migration from 004 *) module Last_block_priority = - Make_single_data_storage + Make_single_data_storage(Ghost) (Raw_context) (struct let name = ["last_block_priority"] end) (Int) @@ -77,17 +84,17 @@ module Last_block_priority = module Contract = struct module Raw_context = - Make_subcontext(Raw_context)(struct let name = ["contracts"] end) + Make_subcontext(Registered)(Raw_context)(struct let name = ["contracts"] end) module Global_counter = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["global_counter"] end) (Z) module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Raw_context)(struct let name = ["index"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end)) (Make_index(Contract_repr.Index)) let fold = Indexed_context.fold_keys @@ -100,7 +107,7 @@ module Contract = struct module Frozen_balance_index = Make_indexed_subcontext - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) (struct let name = ["frozen_balance"] end)) (Make_index(Cycle_repr.Index)) @@ -125,12 +132,12 @@ module Contract = struct (struct let name = ["manager"] end) (Manager_repr) - module Spendable = - Indexed_context.Make_set + module Spendable_004 = + Indexed_context.Make_set(Ghost) (struct let name = ["spendable"] end) - module Delegatable = - Indexed_context.Make_set + module Delegatable_004 = + Indexed_context.Make_set(Ghost) (struct let name = ["delegatable"] end) module Delegate = @@ -139,7 +146,7 @@ module Contract = struct (Signature.Public_key_hash) module Inactive_delegate = - Indexed_context.Make_set + Indexed_context.Make_set(Registered) (struct let name = ["inactive_delegate"] end) module Delegate_desactivation = @@ -149,9 +156,17 @@ module Contract = struct module Delegated = Make_data_set_storage - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) (struct let name = ["delegated"] end)) + (Make_index(Contract_repr.Index)) + + (** Only for migration from proto_004 *) + module Delegated_004 = + Make_data_set_storage + (Make_subcontext(Ghost) + (Indexed_context.Raw_context) + (struct let name = ["delegated_004"] end)) (Make_index(Contract_hash)) module Counter = @@ -219,6 +234,14 @@ module Contract = struct let init_set ctxt contract value = consume_serialize_gas ctxt value >>=? fun ctxt -> I.init_set ctxt contract value + + (** Only for used for 005 migration to avoid gas cost. *) + let init_free ctxt contract value = + I.init_free ctxt contract value + + (** Only for used for 005 migration to avoid gas cost. *) + let set_free ctxt contract value = + I.set_free ctxt contract value end module Code = @@ -229,15 +252,146 @@ module Contract = struct Make_carbonated_map_expr (struct let name = ["storage"] end) - type bigmap_key = Raw_context.t * Contract_repr.t + module Paid_storage_space = + Indexed_context.Make_map + (struct let name = ["paid_bytes"] end) + (Z) + + module Used_storage_space = + Indexed_context.Make_map + (struct let name = ["used_bytes"] end) + (Z) + + module Roll_list = + Indexed_context.Make_map + (struct let name = ["roll_list"] end) + (Roll_repr) + + module Change = + Indexed_context.Make_map + (struct let name = ["change"] end) + (Tez_repr) + +end + +(** Big maps handling *) + +module Big_map = struct + module Raw_context = + Make_subcontext(Registered)(Raw_context)(struct let name = ["big_maps"] end) + + module Next = struct + include + Make_single_data_storage(Registered) + (Raw_context) + (struct let name = ["next"] end) + (Z) + let incr ctxt = + get ctxt >>=? fun i -> + set ctxt (Z.succ i) >>=? fun ctxt -> + return (ctxt, i) + let init ctxt = init ctxt Z.zero + end + + module Index = struct + type t = Z.t + + let rpc_arg = + let construct = Z.to_string in + let destruct hash = + match Z.of_string hash with + | exception _ -> Error "Cannot parse big map id" + | id -> Ok id in + RPC_arg.make + ~descr: "A big map identifier" + ~name: "big_map_id" + ~construct + ~destruct + () + + let encoding = + Data_encoding.def "big_map_id" + ~title:"Big map identifier" + ~description: "A big map identifier" + Z.encoding + let compare = Compare.Z.compare + + let path_length = 7 + + let to_path c l = + let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in + let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + String.sub index_key 0 2 :: + String.sub index_key 2 2 :: + String.sub index_key 4 2 :: + String.sub index_key 6 2 :: + String.sub index_key 8 2 :: + String.sub index_key 10 2 :: + Z.to_string c :: + l + + let of_path = function + | [] | [_] | [_;_] | [_;_;_] | [_;_;_;_] | [_;_;_;_;_] | [_;_;_;_;_;_] + | _::_::_::_::_::_::_::_::_ -> + None + | [ index1 ; index2 ; index3 ; index4 ; index5 ; index6 ; key ] -> + let c = Z.of_string key in + let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in + let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + assert Compare.String.(String.sub index_key 0 2 = index1) ; + assert Compare.String.(String.sub index_key 2 2 = index2) ; + assert Compare.String.(String.sub index_key 4 2 = index3) ; + assert Compare.String.(String.sub index_key 6 2 = index4) ; + assert Compare.String.(String.sub index_key 8 2 = index5) ; + assert Compare.String.(String.sub index_key 10 2 = index6) ; + Some c + end + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end)) + (Make_index(Index)) + + let rpc_arg = Index.rpc_arg + + let fold = Indexed_context.fold_keys + let list = Indexed_context.keys + + let remove_rec ctxt n = + Indexed_context.remove_rec ctxt n + + let copy ctxt ~from ~to_ = + Indexed_context.copy ctxt ~from ~to_ + + type key = Raw_context.t * Z.t + + module Total_bytes = + Indexed_context.Make_map + (struct let name = ["total_bytes"] end) + (Z) + + module Key_type = + Indexed_context.Make_map + (struct let name = ["key_type"] end) + (struct + type t = Script_repr.expr + let encoding = Script_repr.expr_encoding + end) + + module Value_type = + Indexed_context.Make_map + (struct let name = ["value_type"] end) + (struct + type t = Script_repr.expr + let encoding = Script_repr.expr_encoding + end) + + module Contents = struct - (* Consume gas for serilization and deserialization of expr in this - module *) - module Big_map = struct module I = Storage_functors.Make_indexed_carbonated_data_storage - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) - (struct let name = ["big_map"] end)) + (struct let name = ["contents"] end)) (Make_index(Script_expr_hash)) (struct type t = Script_repr.expr @@ -274,41 +428,21 @@ module Contract = struct (ctxt, value_opt) end - module Paid_storage_space = - Indexed_context.Make_map - (struct let name = ["paid_bytes"] end) - (Z) - - module Used_storage_space = - Indexed_context.Make_map - (struct let name = ["used_bytes"] end) - (Z) - - module Roll_list = - Indexed_context.Make_map - (struct let name = ["roll_list"] end) - (Roll_repr) - - module Change = - Indexed_context.Make_map - (struct let name = ["change"] end) - (Tez_repr) - end module Delegates = Make_data_set_storage - (Make_subcontext(Raw_context)(struct let name = ["delegates"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["delegates"] end)) (Make_index(Signature.Public_key_hash)) module Active_delegates_with_rolls = Make_data_set_storage - (Make_subcontext(Raw_context)(struct let name = ["active_delegates_with_rolls"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["active_delegates_with_rolls"] end)) (Make_index(Signature.Public_key_hash)) module Delegates_with_frozen_balance_index = Make_indexed_subcontext - (Make_subcontext(Raw_context) + (Make_subcontext(Registered)(Raw_context) (struct let name = ["delegates_with_frozen_balance"] end)) (Make_index(Cycle_repr.Index)) @@ -323,12 +457,12 @@ module Cycle = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Raw_context)(struct let name = ["cycle"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["cycle"] end)) (Make_index(Cycle_repr.Index)) module Last_roll = Make_indexed_data_storage - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) (struct let name = ["last_roll"] end)) (Int_index) @@ -377,7 +511,7 @@ module Cycle = struct module Nonce = Make_indexed_data_storage - (Make_subcontext + (Make_subcontext(Registered) (Indexed_context.Raw_context) (struct let name = ["nonces"] end)) (Make_index(Raw_level_repr.Index)) @@ -399,21 +533,21 @@ end module Roll = struct module Raw_context = - Make_subcontext(Raw_context)(struct let name = ["rolls"] end) + Make_subcontext(Registered)(Raw_context)(struct let name = ["rolls"] end) module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Raw_context)(struct let name = ["index"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end)) (Make_index(Roll_repr.Index)) module Next = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["next"] end) (Roll_repr) module Limbo = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["limbo"] end) (Roll_repr) @@ -469,7 +603,7 @@ module Roll = struct module Owner = Make_indexed_data_snapshotable_storage - (Make_subcontext(Raw_context)(struct let name = ["owner"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["owner"] end)) (Snapshoted_owner_index) (Make_index(Roll_repr.Index)) (Signature.Public_key) @@ -486,10 +620,10 @@ end module Vote = struct module Raw_context = - Make_subcontext(Raw_context)(struct let name = ["votes"] end) + Make_subcontext(Registered)(Raw_context)(struct let name = ["votes"] end) module Current_period_kind = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["current_period_kind"] end) (struct @@ -497,45 +631,51 @@ module Vote = struct let encoding = Voting_period_repr.kind_encoding end) - module Current_quorum = - Make_single_data_storage + module Current_quorum_004 = + Make_single_data_storage(Ghost) (Raw_context) (struct let name = ["current_quorum"] end) (Int32) + module Participation_ema = + Make_single_data_storage(Registered) + (Raw_context) + (struct let name = ["participation_ema"] end) + (Int32) + module Current_proposal = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["current_proposal"] end) (Protocol_hash) module Listings_size = - Make_single_data_storage + Make_single_data_storage(Registered) (Raw_context) (struct let name = ["listings_size"] end) (Int32) module Listings = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["listings"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["listings"] end)) (Make_index(Signature.Public_key_hash)) (Int32) module Proposals = Make_data_set_storage - (Make_subcontext(Raw_context)(struct let name = ["proposals"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["proposals"] end)) (Pair(Make_index(Protocol_hash))(Make_index(Signature.Public_key_hash))) module Proposals_count = Make_indexed_data_storage - (Make_subcontext(Raw_context) + (Make_subcontext(Registered)(Raw_context) (struct let name = ["proposals_count"] end)) (Make_index(Signature.Public_key_hash)) (Int) module Ballots = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["ballots"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["ballots"] end)) (Make_index(Signature.Public_key_hash)) (struct type t = Vote_repr.ballot @@ -580,7 +720,7 @@ end module Commitments = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["commitments"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["commitments"] end)) (Make_index(Blinded_public_key_hash.Index)) (Tez_repr) @@ -590,7 +730,7 @@ module Ramp_up = struct module Rewards = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "rewards"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["ramp_up"; "rewards"] end)) (Make_index(Cycle_repr.Index)) (struct type t = Tez_repr.t * Tez_repr.t @@ -599,7 +739,7 @@ module Ramp_up = struct module Security_deposits = Make_indexed_data_storage - (Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "deposits"] end)) + (Make_subcontext(Registered)(Raw_context)(struct let name = ["ramp_up"; "deposits"] end)) (Make_index(Cycle_repr.Index)) (struct type t = Tez_repr.t * Tez_repr.t diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli index 2e7f0b09472f531954459e9bac35c404362a87c0..1d7c887d5d746e3d3b14318360dbce25d7ca1528 100644 --- a/src/proto_alpha/lib_protocol/storage.mli +++ b/src/proto_alpha/lib_protocol/storage.mli @@ -36,12 +36,17 @@ open Storage_sigs -module Last_block_priority : sig +module Block_priority : sig val get : Raw_context.t -> int tzresult Lwt.t val set : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t val init : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t end +(* Only for migration from 004 *) +module Last_block_priority : sig + val delete : Raw_context.t -> Raw_context.t tzresult Lwt.t +end + module Roll : sig (** Storage from this submodule must only be accessed through the @@ -152,7 +157,13 @@ module Contract : sig and type value = Signature.Public_key_hash.t and type t := Raw_context.t + (** All contracts (implicit and originated) that are delegated, if any *) module Delegated : Data_set_storage + with type elt = Contract_repr.t + and type t = Raw_context.t * Contract_repr.t + + (** Only for migration from proto_004 *) + module Delegated_004 : Data_set_storage with type elt = Contract_hash.t and type t = Raw_context.t * Contract_repr.t @@ -166,11 +177,11 @@ module Contract : sig and type value = Cycle_repr.t and type t := Raw_context.t - module Spendable : Data_set_storage + module Spendable_004 : Data_set_storage with type elt = Contract_repr.t and type t := Raw_context.t - module Delegatable : Data_set_storage + module Delegatable_004 : Data_set_storage with type elt = Contract_repr.t and type t := Raw_context.t @@ -179,15 +190,39 @@ module Contract : sig and type value = Z.t and type t := Raw_context.t - module Code : Non_iterable_indexed_carbonated_data_storage - with type key = Contract_repr.t - and type value = Script_repr.lazy_expr - and type t := Raw_context.t + module Code : sig + include Non_iterable_indexed_carbonated_data_storage + with type key = Contract_repr.t + and type value = Script_repr.lazy_expr + and type t := Raw_context.t + + (** Only used for 005 migration to avoid gas cost. + Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. *) + val init_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t + + (** Only used for 005 migration to avoid gas cost. + Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. *) + val set_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t + end - module Storage : Non_iterable_indexed_carbonated_data_storage - with type key = Contract_repr.t - and type value = Script_repr.lazy_expr - and type t := Raw_context.t + module Storage : sig + include Non_iterable_indexed_carbonated_data_storage + with type key = Contract_repr.t + and type value = Script_repr.lazy_expr + and type t := Raw_context.t + + (** Only used for 005 migration to avoid gas cost. + Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. *) + val init_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t + + (** Only used for 005 migration to avoid gas cost. + Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. *) + val set_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t + end (** Current storage space in bytes. Includes code, global storage and big map elements. *) @@ -202,12 +237,50 @@ module Contract : sig and type value = Z.t and type t := Raw_context.t - type bigmap_key = Raw_context.t * Contract_repr.t +end + +module Big_map : sig - module Big_map : Non_iterable_indexed_carbonated_data_storage + module Next : sig + val incr : Raw_context.t -> (Raw_context.t * Z.t) tzresult Lwt.t + val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + end + + (** The domain of alive big maps *) + val fold : + Raw_context.t -> + init:'a -> f:(Z.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val list : Raw_context.t -> Z.t list Lwt.t + + val remove_rec : Raw_context.t -> Z.t -> Raw_context.t Lwt.t + + val copy : Raw_context.t -> from:Z.t -> to_:Z.t -> Raw_context.t tzresult Lwt.t + + type key = Raw_context.t * Z.t + + val rpc_arg : Z.t RPC_arg.t + + module Index : Storage_description.INDEX with type t = Z.t + + module Contents : Non_iterable_indexed_carbonated_data_storage with type key = Script_expr_hash.t and type value = Script_repr.expr - and type t := bigmap_key + and type t := key + + module Total_bytes : Indexed_data_storage + with type key = Z.t + and type value = Z.t + and type t := Raw_context.t + + module Key_type : Indexed_data_storage + with type key = Z.t + and type value = Script_repr.expr + and type t := Raw_context.t + + module Value_type : Indexed_data_storage + with type key = Z.t + and type value = Script_repr.expr + and type t := Raw_context.t end @@ -234,8 +307,14 @@ module Vote : sig with type value = Voting_period_repr.kind and type t := Raw_context.t - (** Expected quorum, in centile of percentage *) - module Current_quorum : Single_data_storage + (** Only for migration from 004. + Expected quorum, in centile of percentage *) + module Current_quorum_004 : Single_data_storage + with type value = int32 + and type t := Raw_context.t + + (** Participation exponential moving average, in centile of percentage *) + module Participation_ema : Single_data_storage with type value = int32 and type t := Raw_context.t diff --git a/src/proto_alpha/lib_protocol/storage_description.ml b/src/proto_alpha/lib_protocol/storage_description.ml index 96aef4fea4a0eb2f7d5a1e372f9ce098f407366f..7fa1c1dbb981e4e4f2ef6c4878774b80956b304e 100644 --- a/src/proto_alpha/lib_protocol/storage_description.ml +++ b/src/proto_alpha/lib_protocol/storage_description.ml @@ -285,7 +285,7 @@ let build_directory : type key. key t -> key RPC_directory.t = else if Compare.Int.(i = 0) then return_some [] else list k >>=? fun keys -> - map_p + map_s (fun key -> if Compare.Int.(i = 1) then return (key, None) diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index 0fdfbc06b886695db7769734bdf30c420a531464..54c3dbbdb24c7d90bd4a36bbc64e1b0364401843 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -25,10 +25,13 @@ open Storage_sigs +module Registered = struct let ghost = false end +module Ghost = struct let ghost = true end + module Make_encoder (V : VALUE) = struct let of_bytes ~key b = match Data_encoding.Binary.of_bytes V.encoding b with - | None -> Error [Raw_context.Storage_error (Corrupted_data key)] + | None -> error (Raw_context.Storage_error (Corrupted_data key)) | Some v -> Ok v let to_bytes v = match Data_encoding.Binary.to_bytes V.encoding v with @@ -54,7 +57,7 @@ let map_key f = function | `Key k -> `Key (f k) | `Dir k -> `Dir (f k) -module Make_subcontext (C : Raw_context.T) (N : NAME) +module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : Raw_context.T with type t = C.t = struct type t = C.t type context = t @@ -84,10 +87,12 @@ module Make_subcontext (C : Raw_context.T) (N : NAME) let consume_gas = C.consume_gas let check_enough_gas = C.check_enough_gas let description = - Storage_description.register_named_subcontext C.description N.name + let description = if R.ghost then Storage_description.create () + else C.description in + Storage_description.register_named_subcontext description N.name end -module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE) +module Make_single_data_storage (R : REGISTER) (C : Raw_context.T) (N : NAME) (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t = struct type t = C.t @@ -129,9 +134,11 @@ module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE) let () = let open Storage_description in + let description = if R.ghost then Storage_description.create () + else C.description in register_value ~get:get_option - (register_named_subcontext C.description N.name) + (register_named_subcontext description N.name) V.encoding end @@ -329,76 +336,76 @@ module Make_indexed_carbonated_data_storage type key = I.t type value = V.t include Make_encoder(V) - let name i = + let data_key i = I.to_path i [data_name] - let len_name i = + let len_key i = I.to_path i [len_name] let consume_mem_gas c = Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) let existing_size c i = - C.get_option c (len_name i) >>= function - | None -> return 0 - | Some len -> decode_len_value (len_name i) len + C.get_option c (len_key i) >>= function + | None -> return (0, false) + | Some len -> decode_len_value (len_key i) len >>=? fun len -> return (len, true) let consume_read_gas get c i = - get c (len_name i) >>=? fun len -> - decode_len_value (len_name i) len >>=? fun len -> + get c (len_key i) >>=? fun len -> + decode_len_value (len_key i) len >>=? fun len -> Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len))) let consume_serialize_write_gas set c i v = let bytes = to_bytes v in let len = MBytes.length bytes in Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len)) >>=? fun c -> Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len))) >>=? fun c -> - set c (len_name i) (encode_len_value bytes) >>=? fun c -> + set c (len_key i) (encode_len_value bytes) >>=? fun c -> return (c, bytes) let consume_remove_gas del c i = Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) >>=? fun c -> - del c (len_name i) + del c (len_key i) let mem s i = consume_mem_gas s >>=? fun s -> - C.mem s (name i) >>= fun exists -> + C.mem s (data_key i) >>= fun exists -> return (C.project s, exists) let get s i = consume_read_gas C.get s i >>=? fun s -> - C.get s (name i) >>=? fun b -> - let key = C.absolute_key s (name i) in + C.get s (data_key i) >>=? fun b -> + let key = C.absolute_key s (data_key i) in Lwt.return (of_bytes ~key b) >>=? fun v -> return (C.project s, v) let get_option s i = consume_mem_gas s >>=? fun s -> - C.mem s (name i) >>= fun exists -> + C.mem s (data_key i) >>= fun exists -> if exists then get s i >>=? fun (s, v) -> return (s, Some v) else return (C.project s, None) let set s i v = - existing_size s i >>=? fun prev_size -> + existing_size s i >>=? fun (prev_size, _) -> consume_serialize_write_gas C.set s i v >>=? fun (s, bytes) -> - C.set s (name i) bytes >>=? fun t -> + C.set s (data_key i) bytes >>=? fun t -> let size_diff = MBytes.length bytes - prev_size in return (C.project t, size_diff) let init s i v = consume_serialize_write_gas C.init s i v >>=? fun (s, bytes) -> - C.init s (name i) bytes >>=? fun t -> + C.init s (data_key i) bytes >>=? fun t -> let size = MBytes.length bytes in return (C.project t, size) let init_set s i v = let init_set s i v = C.init_set s i v >>= return in - existing_size s i >>=? fun prev_size -> + existing_size s i >>=? fun (prev_size, existed) -> consume_serialize_write_gas init_set s i v >>=? fun (s, bytes) -> - init_set s (name i) bytes >>=? fun t -> + init_set s (data_key i) bytes >>=? fun t -> let size_diff = MBytes.length bytes - prev_size in - return (C.project t, size_diff) + return (C.project t, size_diff, existed) let remove s i = let remove s i = C.remove s i >>= return in - existing_size s i >>=? fun prev_size -> + existing_size s i >>=? fun (prev_size, existed) -> consume_remove_gas remove s i >>=? fun s -> - remove s (name i) >>=? fun t -> - return (C.project t, prev_size) + remove s (data_key i) >>=? fun t -> + return (C.project t, prev_size, existed) let delete s i = - existing_size s i >>=? fun prev_size -> + existing_size s i >>=? fun (prev_size, _) -> consume_remove_gas C.delete s i >>=? fun s -> - C.delete s (name i) >>=? fun t -> + C.delete s (data_key i) >>=? fun t -> return (C.project t, prev_size) let set_option s i v = match v with @@ -407,14 +414,21 @@ module Make_indexed_carbonated_data_storage let fold_keys_unaccounted s ~init ~f = let rec dig i path acc = - if Compare.Int.(i <= 1) then + if Compare.Int.(i <= 0) then C.fold s path ~init:acc ~f:begin fun k acc -> match k with | `Dir _ -> Lwt.return acc | `Key file -> - match I.of_path file with - | None -> assert false - | Some path -> f path acc + match List.rev file with + | last :: _ when Compare.String.(last = len_name) -> + Lwt.return acc + | last :: rest when Compare.String.(last = data_name) -> + let file = List.rev rest in + begin match I.of_path file with + | None -> assert false + | Some path -> f path acc + end + | _ -> assert false end else C.fold s path ~init:acc ~f:begin fun k acc -> @@ -422,7 +436,7 @@ module Make_indexed_carbonated_data_storage | `Dir k -> dig (i-1) k acc | `Key _ -> Lwt.return acc end in - dig I.path_length [data_name] init + dig I.path_length [] init let keys_unaccounted s = fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) @@ -455,8 +469,8 @@ module Make_indexed_data_snapshotable_storage (C : Raw_context.T) let data_name = ["current"] let snapshot_name = ["snapshot"] - module C_data = Make_subcontext(C)(struct let name = data_name end) - module C_snapshot = Make_subcontext(C)(struct let name = snapshot_name end) + module C_data = Make_subcontext(Registered)(C)(struct let name = data_name end) + module C_snapshot = Make_subcontext(Registered)(C)(struct let name = snapshot_name end) include Make_indexed_data_storage(C_data)(I) (V) module Snapshot = Make_indexed_data_storage(C_snapshot)(Pair(Snapshot_index)(I))(V) @@ -510,6 +524,12 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) + let remove_rec t k = + C.remove_rec t (I.to_path k []) + + let copy t ~from ~to_ = + C.copy t ~from:(I.to_path from []) ~to_:(I.to_path to_ []) + let description = Storage_description.register_indexed_subcontext ~list:(fun c -> keys c >>= return) @@ -587,13 +607,13 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) end | [] -> list t prefix >>= fun prefixes -> - Lwt_list.map_p (function + Lwt_list.map_s (function | `Key prefix | `Dir prefix -> loop (i+1) prefix []) prefixes >|= List.flatten | [d] when Compare.Int.(i = I.path_length - 1) -> if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; list t prefix >>= fun prefixes -> - Lwt_list.map_p (function + Lwt_list.map_s (function | `Key prefix | `Dir prefix -> match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with | None -> Lwt.return_nil @@ -602,7 +622,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) >|= List.flatten | "" :: ds -> list t prefix >>= fun prefixes -> - Lwt_list.map_p (function + Lwt_list.map_s (function | `Key prefix | `Dir prefix -> loop (i+1) prefix ds) prefixes >|= List.flatten | d :: ds -> @@ -612,7 +632,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) | false -> Lwt.return_nil in loop 0 [] prefix - module Make_set (N : NAME) = struct + module Make_set (R : REGISTER) (N : NAME) = struct type t = C.t type context = t type elt = I.t @@ -650,13 +670,15 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) let () = let open Storage_description in let unpack = unpack I.args in + let description = if R.ghost then Storage_description.create () + else Raw_context.description in register_value ~get:(fun c -> let (c, k) = unpack c in mem c k >>= function | true -> return_some true | false -> return_none) - (register_named_subcontext Raw_context.description N.name) + (register_named_subcontext description N.name) Data_encoding.bool end @@ -755,8 +777,8 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) let existing_size c = Raw_context.get_option c len_name >>= function - | None -> return 0 - | Some len -> decode_len_value len_name len + | None -> return (0, false) + | Some len -> decode_len_value len_name len >>=? fun len -> return (len, true) let consume_read_gas get c = get c (len_name) >>=? fun len -> decode_len_value len_name len >>=? fun len -> @@ -790,31 +812,46 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) else return (C.project s, None) let set s i v = - existing_size (pack s i) >>=? fun prev_size -> + existing_size (pack s i) >>=? fun (prev_size, _) -> consume_write_gas Raw_context.set (pack s i) v >>=? fun (c, bytes) -> Raw_context.set c data_name bytes >>=? fun c -> let size_diff = MBytes.length bytes - prev_size in return (Raw_context.project c, size_diff) + let set_free s i v = + let c = pack s i in + let bytes = to_bytes v in + existing_size c >>=? fun (prev_size, _) -> + Raw_context.set c len_name (encode_len_value bytes) >>=? fun c -> + Raw_context.set c data_name bytes >>=? fun c -> + let size_diff = MBytes.length bytes - prev_size in + return (Raw_context.project c, size_diff) let init s i v = consume_write_gas Raw_context.init (pack s i) v >>=? fun (c, bytes) -> Raw_context.init c data_name bytes >>=? fun c -> let size = MBytes.length bytes in return (Raw_context.project c, size) + let init_free s i v = + let c = pack s i in + let bytes = to_bytes v in + let size = MBytes.length bytes in + Raw_context.init c len_name (encode_len_value bytes) >>=? fun c -> + Raw_context.init c data_name bytes >>=? fun c -> + return (Raw_context.project c, size) let init_set s i v = let init_set c k v = Raw_context.init_set c k v >>= return in - existing_size (pack s i) >>=? fun prev_size -> + existing_size (pack s i) >>=? fun (prev_size, existed) -> consume_write_gas init_set (pack s i) v >>=? fun (c, bytes) -> init_set c data_name bytes >>=? fun c -> let size_diff = MBytes.length bytes - prev_size in - return (Raw_context.project c, size_diff) + return (Raw_context.project c, size_diff, existed) let remove s i = let remove c k = Raw_context.remove c k >>= return in - existing_size (pack s i) >>=? fun prev_size -> + existing_size (pack s i) >>=? fun (prev_size, existed) -> consume_remove_gas remove (pack s i) >>=? fun c -> remove c data_name >>=? fun c -> - return (Raw_context.project c, prev_size) + return (Raw_context.project c, prev_size, existed) let delete s i = - existing_size (pack s i) >>=? fun prev_size -> + existing_size (pack s i) >>=? fun (prev_size, _) -> consume_remove_gas Raw_context.delete (pack s i) >>=? fun c -> Raw_context.delete c data_name >>=? fun c -> return (Raw_context.project c, prev_size) diff --git a/src/proto_alpha/lib_protocol/storage_functors.mli b/src/proto_alpha/lib_protocol/storage_functors.mli index 83452908c670f796778f1a9d1288424a09c6577b..6217cb9c06821d93a8f23a101ff7bcac5596ae1f 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.mli +++ b/src/proto_alpha/lib_protocol/storage_functors.mli @@ -27,11 +27,14 @@ open Storage_sigs -module Make_subcontext (C : Raw_context.T) (N : NAME) +module Registered : REGISTER +module Ghost : REGISTER + +module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : Raw_context.T with type t = C.t module Make_single_data_storage - (C : Raw_context.T) (N : NAME) (V : VALUE) + (R : REGISTER) (C : Raw_context.T) (N : NAME) (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t diff --git a/src/proto_alpha/lib_protocol/storage_sigs.ml b/src/proto_alpha/lib_protocol/storage_sigs.ml index 2831aaf7165c0b43fdbad2d406244468f0d5fd17..a637af7066c507fe0d570da649e406cd9b9ee6e6 100644 --- a/src/proto_alpha/lib_protocol/storage_sigs.ml +++ b/src/proto_alpha/lib_protocol/storage_sigs.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(** {1 Entity Accessor Signatures} ****************************************) +(** {1 Entity Accessor Signatures} *) (** The generic signature of a single data accessor (a single value bound to a specific key in the hierarchical (key x value) @@ -118,16 +118,18 @@ module type Single_carbonated_data_storage = sig (** Allocates the data and initializes it with a value ; just updates it if the bucket exists. Consumes [Gas_repr.write_bytes_cost ]. - Returns the difference from the old (maybe 0) to the new size. *) - val init_set: context -> value -> (Raw_context.t * int) tzresult Lwt.t + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val init_set: context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t (** When the value is [Some v], allocates the data and initializes it with [v] ; just updates it if the bucket exists. When the valus is [None], delete the storage bucket when the value ; does nothing if the bucket does not exists. Consumes the same gas cost as either {!remove} or {!init_set}. - Returns the difference from the old (maybe 0) to the new size. *) - val set_option: context -> value option -> (Raw_context.t * int) tzresult Lwt.t + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val set_option: context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t (** Delete the storage bucket ; returns a {!Storage_error Missing_key} if the bucket does not exists. @@ -138,8 +140,9 @@ module type Single_carbonated_data_storage = sig (** Removes the storage bucket and its contents ; does nothing if the bucket does not exists. Consumes [Gas_repr.write_bytes_cost Z.zero]. - Returns the freed size. *) - val remove: context -> (Raw_context.t * int) tzresult Lwt.t + Returns the freed size, and a boolean + indicating if a value was already associated to this key. *) + val remove: context -> (Raw_context.t * int * bool) tzresult Lwt.t end @@ -245,8 +248,9 @@ module type Non_iterable_indexed_carbonated_data_storage = sig with a value ; just updates it if the bucket exists. Consumes serialization cost. Consumes [Gas_repr.write_bytes_cost ]. - Returns the difference from the old (maybe 0) to the new size. *) - val init_set: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val init_set: context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t (** When the value is [Some v], allocates the data and initializes it with [v] ; just updates it if the bucket exists. When the @@ -254,8 +258,9 @@ module type Non_iterable_indexed_carbonated_data_storage = sig nothing if the bucket does not exists. Consumes serialization cost. Consumes the same gas cost as either {!remove} or {!init_set}. - Returns the difference from the old (maybe 0) to the new size. *) - val set_option: context -> key -> value option -> (Raw_context.t * int) tzresult Lwt.t + Returns the difference from the old (maybe 0) to the new size, and a boolean + indicating if a value was already associated to this key. *) + val set_option: context -> key -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t (** Delete a storage bucket and its contents ; returns a {!Storage_error Missing_key} if the bucket does not exists. @@ -266,8 +271,9 @@ module type Non_iterable_indexed_carbonated_data_storage = sig (** Removes a storage bucket and its contents ; does nothing if the bucket does not exists. Consumes [Gas_repr.write_bytes_cost Z.zero]. - Returns the freed size. *) - val remove: context -> key -> (Raw_context.t * int) tzresult Lwt.t + Returns the freed size, and a boolean + indicating if a value was already associated to this key. *) + val remove: context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t end @@ -358,6 +364,22 @@ module type VALUE = sig val encoding: t Data_encoding.t end +module type REGISTER = sig val ghost : bool end + +module type Non_iterable_indexed_carbonated_data_storage_with_free = sig + include Non_iterable_indexed_carbonated_data_storage + + (** Only used for 005 migration to avoid gas cost. + Allocates a storage bucket at the given key and initializes it ; + returns a {!Storage_error Existing_key} if the bucket exists. *) + val init_free: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + + (** Only used for 005 migration to avoid gas cost. + Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. *) + val set_free: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t +end + module type Indexed_raw_context = sig type t @@ -373,7 +395,12 @@ module type Indexed_raw_context = sig val resolve: context -> string list -> key list Lwt.t - module Make_set (N : NAME) + val remove_rec: context -> key -> context Lwt.t + + val copy: context -> from:key -> to_:key -> context tzresult Lwt.t + + module Make_set (R : REGISTER) (N : NAME) + : Data_set_storage with type t = t and type elt = key @@ -383,7 +410,7 @@ module type Indexed_raw_context = sig and type value = V.t module Make_carbonated_map (N : NAME) (V : VALUE) - : Non_iterable_indexed_carbonated_data_storage with type t = t + : Non_iterable_indexed_carbonated_data_storage_with_free with type t = t and type key = key and type value = V.t diff --git a/src/proto_alpha/lib_protocol/test/baking.ml b/src/proto_alpha/lib_protocol/test/baking.ml index 1a7ea2519eb7bcac5a09ef7484d2979fb39eb5fc..2e429179dbd4a70bfdaaac12871b54a38815c040 100644 --- a/src/proto_alpha/lib_protocol/test/baking.ml +++ b/src/proto_alpha/lib_protocol/test/baking.ml @@ -24,6 +24,8 @@ (*****************************************************************************) open Protocol +open Alpha_context +open Test_utils (** Tests for [bake_n] and [bake_until_end_cycle]. *) let test_cycle () = @@ -64,4 +66,53 @@ let test_cycle () = (Alpha_context.Raw_level.to_int32 curr_level) (Int32.add (Alpha_context.Raw_level.to_int32 l) 10l) -let tests = [Test.tztest "cycle" `Quick test_cycle] +(** Tests the formula introduced in Emmy+ for block reward: + (16/(p+1)) * (0.8 + 0.2 * e / 32) + where p is the block priority and + e is the number of included endorsements *) +let test_block_reward priority () = + ( match priority with + | 0 -> + Test_tez.Tez.(of_int 128 /? Int64.of_int 10) + >>?= fun min -> return (Test_tez.Tez.of_int 16, min) + | 1 -> + Test_tez.Tez.(of_int 64 /? Int64.of_int 10) + >>?= fun min -> return (Test_tez.Tez.of_int 8, min) + | 3 -> + Test_tez.Tez.(of_int 32 /? Int64.of_int 10) + >>?= fun min -> return (Test_tez.Tez.of_int 4, min) + | _ -> + fail (invalid_arg "prio should be 0, 1, or 3") ) + >>=? fun (expected_reward_max_endo, expected_reward_min_endo) -> + let endorsers_per_block = 32 in + Context.init ~endorsers_per_block 32 + >>=? fun (b, _) -> + Context.get_endorsers (B b) + >>=? fun endorsers -> + fold_left_s + (fun ops (endorser : Alpha_services.Delegate.Endorsing_rights.t) -> + let delegate = endorser.delegate in + Op.endorsement ~delegate (B b) () + >>=? fun op -> return (Operation.pack op :: ops)) + [] + endorsers + >>=? fun ops -> + Block.bake ~policy:(By_priority 0) ~operations:ops b + >>=? fun b -> + (* bake a block at priority 0 and 32 endorsements; + the reward is 16 tez *) + Context.get_baking_reward (B b) ~priority ~endorsing_power:32 + >>=? fun baking_reward -> + Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_max_endo + >>=? fun () -> + (* bake a block at priority 0 and 0 endorsements; + the reward is 12.8 tez *) + Context.get_baking_reward (B b) ~priority ~endorsing_power:0 + >>=? fun baking_reward -> + Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_min_endo + +let tests = + [ Test.tztest "cycle" `Quick test_cycle; + Test.tztest "block_reward for priority 0" `Quick (test_block_reward 0); + Test.tztest "block_reward for priority 1" `Quick (test_block_reward 1); + Test.tztest "block_reward for priority 3" `Quick (test_block_reward 3) ] diff --git a/src/proto_alpha/lib_protocol/test/combined_operations.ml b/src/proto_alpha/lib_protocol/test/combined_operations.ml index 428be0c5bc0bcae314815a547028bd27efc44245..63b4bf20e69c0a50465f2be2ef34f42e43ad1771 100644 --- a/src/proto_alpha/lib_protocol/test/combined_operations.ml +++ b/src/proto_alpha/lib_protocol/test/combined_operations.ml @@ -79,24 +79,24 @@ let multiple_origination_and_delegation () = Context.init 2 >>=? fun (blk, contracts) -> let c1 = List.nth contracts 0 in + let c2 = List.nth contracts 1 in let n = 10 in Context.get_constants (B blk) >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> - Context.Contract.pkh c1 + Context.Contract.pkh c2 >>=? fun delegate_pkh -> - let new_accounts = List.map (fun _ -> Account.new_account ()) (1 -- n) in - mapi_s - (fun i {Account.pk; _} -> + (* Deploy n smart contracts with dummy scripts from c1 *) + map_s + (fun i -> Op.origination ~delegate:delegate_pkh ~counter:(Z.of_int i) ~fee:Tez.zero - ~public_key:pk - ~spendable:true + ~script:Op.dummy_script ~credit:(Tez.of_int 10) (B blk) c1) - new_accounts + (1 -- n) >>=? fun originations -> (* These computed originated contracts are not the ones really created *) (* We will extract them from the tickets *) @@ -141,8 +141,11 @@ let multiple_origination_and_delegation () = >>?= fun origination_burn -> Tez.(origination_burn *? Int64.of_int n) >>?= fun origination_total_cost -> - Tez.(Tez.of_int (10 * n) +? origination_total_cost) - >>?= fun total_cost -> + Lwt.return + ( Tez.( *? ) Op.dummy_script_cost 10L + >>? Tez.( +? ) (Tez.of_int (10 * n)) + >>? Tez.( +? ) origination_total_cost ) + >>=? fun total_cost -> Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost >>=? fun () -> iter_s diff --git a/src/proto_alpha/lib_protocol/test/delegation.ml b/src/proto_alpha/lib_protocol/test/delegation.ml index 1a73958d0f7c9ebdec267986477d27514af31597..f40bc370dc00d8b31f1030c9b80525b04b480ea1 100644 --- a/src/proto_alpha/lib_protocol/test/delegation.ml +++ b/src/proto_alpha/lib_protocol/test/delegation.ml @@ -43,14 +43,7 @@ let expect_error err = function let expect_alpha_error err = expect_error (Environment.Ecoproto_error err) -let expect_non_delegatable_contract = function - | Environment.Ecoproto_error (Delegate_storage.Non_delegatable_contract _) - :: _ -> - return_unit - | _ -> - failwith "Contract is not delegatable and operation should fail." - -let expect_no_deletion_pkh pkh = function +let expect_no_change_registered_delegate_pkh pkh = function | Environment.Ecoproto_error (Delegate_storage.No_deletion pkh0) :: _ when pkh0 = pkh -> return_unit @@ -83,6 +76,7 @@ let bootstrap_delegate_cannot_change ~fee () = >>=? fun balance0 -> Context.Contract.delegate (I i) bootstrap0 >>=? fun delegate0 -> + (* change delegation to bootstrap1 *) Op.delegation ~fee (I i) bootstrap0 (Some manager1.pkh) >>=? fun set_delegate -> if fee > balance0 then @@ -95,7 +89,7 @@ let bootstrap_delegate_cannot_change ~fee () = false) else Incremental.add_operation - ~expect_failure:expect_non_delegatable_contract + ~expect_failure:(expect_no_change_registered_delegate_pkh delegate0) i set_delegate >>=? fun i -> @@ -104,7 +98,7 @@ let bootstrap_delegate_cannot_change ~fee () = (* bootstrap0 still has same delegate *) Context.Contract.delegate (B b) bootstrap0 >>=? fun delegate0_after -> - Assert.equal_pkh ~loc:__LOC__ delegate0 delegate0_after + Assert.equal_pkh ~loc:__LOC__ delegate0_after delegate0 >>=? fun () -> (* fee has been debited *) Assert.balance_was_debited ~loc:__LOC__ (B b) bootstrap0 balance0 fee @@ -122,6 +116,7 @@ let bootstrap_delegate_cannot_be_removed ~fee () = >>=? fun delegate -> Context.Contract.manager (I i) bootstrap >>=? fun manager -> + (* remove delegation *) Op.delegation ~fee (I i) bootstrap None >>=? fun set_delegate -> if fee > balance then @@ -134,7 +129,7 @@ let bootstrap_delegate_cannot_be_removed ~fee () = false) else Incremental.add_operation - ~expect_failure:(expect_no_deletion_pkh manager.pkh) + ~expect_failure:(expect_no_change_registered_delegate_pkh manager.pkh) i set_delegate >>=? fun i -> @@ -146,6 +141,112 @@ let bootstrap_delegate_cannot_be_removed ~fee () = (* fee has been debited *) Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee +(** contracts not registered as delegate can change their delegation *) +let delegate_can_be_changed_from_unregistered_contract ~fee () = + Context.init 2 + >>=? fun (b, bootstrap_contracts) -> + let bootstrap0 = List.hd bootstrap_contracts in + let bootstrap1 = List.nth bootstrap_contracts 1 in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let unregistered = Contract.implicit_contract unregistered_pkh in + Incremental.begin_construction b + >>=? fun i -> + Context.Contract.manager (I i) bootstrap0 + >>=? fun manager0 -> + Context.Contract.manager (I i) bootstrap1 + >>=? fun manager1 -> + let credit = Tez.of_int 10 in + Op.transaction ~fee:Tez.zero (I i) bootstrap0 unregistered credit + >>=? fun credit_contract -> + Context.Contract.balance (I i) bootstrap0 + >>=? fun balance -> + Incremental.add_operation i credit_contract + >>=? fun i -> + (* delegate to bootstrap0 *) + Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager0.pkh) + >>=? fun set_delegate -> + Incremental.add_operation i set_delegate + >>=? fun i -> + Context.Contract.delegate (I i) unregistered + >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate manager0.pkh + >>=? fun () -> + (* change delegation to bootstrap1 *) + Op.delegation ~fee (I i) unregistered (Some manager1.pkh) + >>=? fun change_delegate -> + if fee > balance then + Incremental.add_operation i change_delegate + >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> + true + | _ -> + false) + else + Incremental.add_operation i change_delegate + >>=? fun i -> + (* delegate has changed *) + Context.Contract.delegate (I i) unregistered + >>=? fun delegate_after -> + Assert.equal_pkh ~loc:__LOC__ delegate_after manager1.pkh + >>=? fun () -> + (* fee has been debited *) + Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee + +(** contracts not registered as delegate can delete their delegation *) +let delegate_can_be_removed_from_unregistered_contract ~fee () = + Context.init 1 + >>=? fun (b, bootstrap_contracts) -> + let bootstrap = List.hd bootstrap_contracts in + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let unregistered = Contract.implicit_contract unregistered_pkh in + Incremental.begin_construction b + >>=? fun i -> + Context.Contract.manager (I i) bootstrap + >>=? fun manager -> + let credit = Tez.of_int 10 in + Op.transaction ~fee:Tez.zero (I i) bootstrap unregistered credit + >>=? fun credit_contract -> + Context.Contract.balance (I i) bootstrap + >>=? fun balance -> + Incremental.add_operation i credit_contract + >>=? fun i -> + (* delegate to bootstrap *) + Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager.pkh) + >>=? fun set_delegate -> + Incremental.add_operation i set_delegate + >>=? fun i -> + Context.Contract.delegate (I i) unregistered + >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh + >>=? fun () -> + (* remove delegation *) + Op.delegation ~fee (I i) unregistered None + >>=? fun delete_delegate -> + if fee > balance then + Incremental.add_operation i delete_delegate + >>= fun err -> + Assert.proto_error ~loc:__LOC__ err (function + | Contract_storage.Balance_too_low _ -> + true + | _ -> + false) + else + Incremental.add_operation i delete_delegate + >>=? fun i -> + (* the delegate has been removed *) + Context.Contract.delegate_opt (I i) unregistered + >>=? (function + | None -> + return_unit + | Some _ -> + failwith "Expected delegate to be removed") + >>=? fun () -> + (* fee has been debited *) + Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee + (** bootstrap keys are already registered as delegate keys *) let bootstrap_manager_already_registered_delegate ~fee () = Context.init 1 @@ -195,14 +296,21 @@ let delegate_to_bootstrap_by_origination ~fee () = Context.Contract.balance (I i) bootstrap >>=? fun balance -> (* originate a contract with bootstrap's manager as delegate *) - Op.origination ~fee ~credit:Tez.zero ~delegate:manager.pkh (I i) bootstrap + Op.origination + ~fee + ~credit:Tez.zero + ~delegate:manager.pkh + (I i) + bootstrap + ~script:Op.dummy_script >>=? fun (op, orig_contract) -> Context.get_constants (I i) >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> (* 0.257tz *) Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn -> - Lwt.return (Tez.( +? ) fee origination_burn) + Lwt.return + (Tez.( +? ) fee origination_burn >>? Tez.( +? ) Op.dummy_script_cost) >>=? fun total_fee -> if fee > balance then Incremental.add_operation i op @@ -245,126 +353,47 @@ let delegate_to_bootstrap_by_origination ~fee () = >>=? fun () -> Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance total_fee -(** bootstrap manager can be set as delegate of an originated contract - without initial delegate (through delegation operation) *) -let delegate_to_bootstrap_by_delegation ~fee () = - Context.init 1 - >>=? fun (b, bootstrap_contracts) -> - Incremental.begin_construction b - >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in - Context.Contract.manager (I i) bootstrap - >>=? fun manager -> - (* originate a contract with no delegate *) - Op.origination ~fee:Tez.zero (I i) bootstrap - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op - >>=? fun i -> - Context.Contract.balance (I i) orig_contract - >>=? fun orig_balance -> - (* Format.printf "\nBalance of originated contract: %a\n%!" Tez.pp orig_balance; *) - (* delegate to bootstrap *) - Op.delegation ~fee (I i) orig_contract (Some manager.pkh) - >>=? fun deleg_op -> - if fee > orig_balance then - Incremental.add_operation i deleg_op - >>= fun err -> - Assert.proto_error ~loc:__LOC__ err (function - | Contract_storage.Balance_too_low _ -> - true - | _ -> - false) - else - (* manager is delegate, fee is debited *) - Incremental.add_operation i deleg_op - >>=? fun i -> - Context.Contract.delegate (I i) orig_contract - >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh - >>=? fun () -> - Assert.balance_was_debited - ~loc:__LOC__ - (I i) - orig_contract - orig_balance - fee - -(** bootstrap manager can be set as delegate of an originated contract - with initial delegate (through delegation operation) *) -let delegate_to_bootstrap_by_delegation_switch ~fee () = - Context.init 2 - >>=? fun (b, bootstrap_contracts) -> - Incremental.begin_construction b - >>=? fun i -> - let bootstrap0 = List.hd bootstrap_contracts in - Context.Contract.manager (I i) bootstrap0 - >>=? fun manager0 -> - let bootstrap1 = List.nth bootstrap_contracts 1 in - Context.Contract.manager (I i) bootstrap1 - >>=? fun manager1 -> - (* originate a contract with bootstrap1's manager as delegate *) - Op.origination - ~fee:Tez.zero - ~credit:Tez.one - ~delegate:manager1.pkh - (I i) - bootstrap0 - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op - >>=? fun i -> - Context.Contract.balance (I i) orig_contract - >>=? fun orig_balance -> - Context.Contract.delegate (I i) orig_contract - >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate manager1.pkh - >>=? fun _ -> - (* switch delegate to bootstrap0 *) - Op.delegation ~fee (I i) orig_contract (Some manager0.pkh) - >>=? fun switch_deleg -> - if fee > orig_balance then - Incremental.add_operation i switch_deleg - >>= fun err -> - Assert.proto_error ~loc:__LOC__ err (function - | Contract_storage.Balance_too_low _ -> - true - | _ -> - false) - else - (* manager0 is delegate, fee is debited *) - Incremental.add_operation i switch_deleg - >>=? fun i -> - Context.Contract.delegate (I i) orig_contract - >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate manager0.pkh - >>=? fun () -> - Assert.balance_was_debited - ~loc:__LOC__ - (I i) - orig_contract - orig_balance - fee - let tests_bootstrap_contracts = [ Test.tztest "bootstrap contracts delegate to themselves" `Quick bootstrap_manager_is_bootstrap_delegate; Test.tztest - "bootstrap contracts cannot change their delegate (small fee)" + "bootstrap contracts can change their delegate (small fee)" `Quick (bootstrap_delegate_cannot_change ~fee:Tez.one_mutez); Test.tztest - "bootstrap contracts cannot change their delegate (max fee)" + "bootstrap contracts can change their delegate (max fee)" `Quick (bootstrap_delegate_cannot_change ~fee:Tez.max_tez); Test.tztest - "bootstrap contracts cannot delete their delegation (small fee)" + "bootstrap contracts cannot remove their delegation (small fee)" `Quick (bootstrap_delegate_cannot_be_removed ~fee:Tez.one_mutez); Test.tztest - "bootstrap contracts cannot delete their delegation (max fee)" + "bootstrap contracts cannot remove their delegation (max fee)" `Quick (bootstrap_delegate_cannot_be_removed ~fee:Tez.max_tez); + Test.tztest + "contracts not registered as delegate can remove their delegation \ + (small fee)" + `Quick + (delegate_can_be_changed_from_unregistered_contract ~fee:Tez.one_mutez); + Test.tztest + "contracts not registered as delegate can remove their delegation (max \ + fee)" + `Quick + (delegate_can_be_changed_from_unregistered_contract ~fee:Tez.max_tez); + Test.tztest + "contracts not registered as delegate can remove their delegation \ + (small fee)" + `Quick + (delegate_can_be_removed_from_unregistered_contract ~fee:Tez.one_mutez); + Test.tztest + "contracts not registered as delegate can remove their delegation (max \ + fee)" + `Quick + (delegate_can_be_removed_from_unregistered_contract ~fee:Tez.max_tez); Test.tztest "bootstrap keys are already registered as delegate keys (small fee)" `Quick @@ -377,33 +406,17 @@ let tests_bootstrap_contracts = "bootstrap manager can be delegate (init origination, small fee)" `Quick (delegate_to_bootstrap_by_origination ~fee:Tez.one_mutez); - (* balance enough for fee but not for fee + origination burn *) + (* balance enough for fee but not for fee + origination burn + dummy script storage cost *) Test.tztest "bootstrap manager can be delegate (init origination, edge case)" `Quick (delegate_to_bootstrap_by_origination - ~fee:(Tez.of_mutez_exn 3_999_999_743_000L)); + ~fee:(Tez.of_mutez_exn 3_999_999_705_000L)); (* fee bigger than bootstrap's initial balance*) Test.tztest "bootstrap manager can be delegate (init origination, large fee)" `Quick - (delegate_to_bootstrap_by_origination ~fee:(Tez.of_int 10_000_000)); - Test.tztest - "bootstrap manager can be delegate (init delegation, small fee)" - `Quick - (delegate_to_bootstrap_by_delegation ~fee:Tez.one_mutez); - Test.tztest - "bootstrap manager can be delegate (init delegation, max fee)" - `Quick - (delegate_to_bootstrap_by_delegation ~fee:Tez.max_tez); - Test.tztest - "bootstrap manager can be delegate (switch delegation, small fee)" - `Quick - (delegate_to_bootstrap_by_delegation_switch ~fee:Tez.one_mutez); - Test.tztest - "bootstrap manager can be delegate (switch delegation, max fee)" - `Quick - (delegate_to_bootstrap_by_delegation_switch ~fee:Tez.max_tez) ] + (delegate_to_bootstrap_by_origination ~fee:(Tez.of_int 10_000_000)) ] (**************************************************************************) (* delegate registration *) @@ -422,8 +435,8 @@ let tests_bootstrap_contracts = We consider three scenarios for setting a delegate: - through origination, - - through delegation when the originated contract has no delegate yet, - - through delegation when the originated contract already has a delegate. + - through delegation when the implicit contract has no delegate yet, + - through delegation when the implicit contract already has a delegate. We also test that emptying the implicit contract linked to a registered delegate key does not unregister the delegate key. @@ -448,13 +461,13 @@ Not credited: (* Two main series of tests: without self-delegation, and with a failed attempt at self-delegation 1- no self-delegation a- no credit - - no token transfer - - credit of 1μꜩ and then debit of 1μꜩ + - no token transfer + - credit of 1μꜩ and then debit of 1μꜩ b- with credit of 1μꜩ. - For every scenario, we try three different ways of delegating: + For every scenario, we try three different ways of delegating: - through origination (init origination) - - through delegation when no delegate was assigned at origination (init delegation) - - through delegation when a delegate was assigned at origination (switch delegation). + - through delegation when no delegate was assigned (init delegation) + - through delegation when a delegate was assigned (switch delegation). 2- Self-delegation fails if the contract has no credit. We try the two possibilities of 1a for non-credited contracts. @@ -478,7 +491,12 @@ let unregistered_delegate_key_init_origination ~fee () = let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in (* origination with delegate argument *) - Op.origination ~fee ~delegate:unregistered_pkh (I i) bootstrap + Op.origination + ~fee + ~delegate:unregistered_pkh + (I i) + bootstrap + ~script:Op.dummy_script >>=? fun (op, orig_contract) -> Context.get_constants (I i) >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> @@ -523,16 +541,21 @@ let unregistered_delegate_key_init_delegation ~fee () = let bootstrap = List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in - Context.Contract.balance (I i) bootstrap - >>=? fun _balance -> - (* FIXME unused variable *) - (* origination without delegate argument *) + let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = + Account.(unregistered_delegate_account.pkh) + in + (* initial credit for the delegated contract *) let credit = Tez.of_int 10 in - Op.origination (I i) bootstrap ~credit - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit + >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> - Op.delegation ~fee (I i) orig_contract (Some unregistered_pkh) + Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit + >>=? fun _ -> + (* try to delegate *) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> if fee > credit then Incremental.add_operation i delegate_op @@ -546,13 +569,13 @@ let unregistered_delegate_key_init_delegation ~fee () = (* fee has been debited; no delegate *) Incremental.add_operation i - ~expect_failure:(expect_unregistered_key unregistered_pkh) + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) delegate_op >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) orig_contract credit fee + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee >>=? fun () -> - (* originated contract has no delegate *) - Context.Contract.delegate (I i) orig_contract + (* implicit contract has no delegate *) + Context.Contract.delegate (I i) impl_contract >>= fun err -> Assert.error ~loc:__LOC__ err (function | RPC_context.Not_found _ -> @@ -566,22 +589,35 @@ let unregistered_delegate_key_switch_delegation ~fee () = Incremental.begin_construction b >>=? fun i -> let bootstrap = List.hd bootstrap_contracts in + let bootstrap_pkh = + Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ + in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in - (* origination with delegate setting *) - Context.Contract.manager (I i) bootstrap - >>=? fun manager -> + let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = + Account.(unregistered_delegate_account.pkh) + in + (* initial credit for the delegated contract *) let credit = Tez.of_int 10 in - Op.origination (I i) ~delegate:manager.pkh bootstrap ~credit - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit + >>=? fun init_credit -> + Incremental.add_operation i init_credit >>=? fun i -> - Context.Contract.delegate (I i) orig_contract - >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh + Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit >>=? fun _ -> - (* switch delegate through delegation *) - Op.delegation ~fee (I i) orig_contract (Some unregistered_pkh) + (* set and check the initial delegate *) + Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh) + >>=? fun delegate_op -> + Incremental.add_operation i delegate_op + >>=? fun i -> + Context.Contract.delegate (I i) bootstrap + >>=? fun delegate_pkh -> + Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh + >>=? fun () -> + (* try to delegate *) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> if fee > credit then Incremental.add_operation i delegate_op @@ -595,16 +631,15 @@ let unregistered_delegate_key_switch_delegation ~fee () = (* fee has been debited; no delegate *) Incremental.add_operation i - ~expect_failure:(expect_unregistered_key unregistered_pkh) + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) delegate_op >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) orig_contract credit fee + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee >>=? fun () -> - (* originated contract's delegate has not changed *) - Context.Contract.delegate (I i) orig_contract - >>=? fun delegate -> - Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_pkh - >>=? fun () -> Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh + (* implicit contract delegate has not changed *) + Context.Contract.delegate (I i) bootstrap + >>=? fun delegate_pkh_after -> + Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate_pkh_after (* credit of some amount, no self-delegation *) let unregistered_delegate_key_init_origination_credit ~fee ~amount () = @@ -626,7 +661,12 @@ let unregistered_delegate_key_init_origination_credit ~fee ~amount () = (* origination with delegate argument *) Context.Contract.balance (I i) bootstrap >>=? fun balance -> - Op.origination ~fee ~delegate:unregistered_pkh (I i) bootstrap + Op.origination + ~fee + ~delegate:unregistered_pkh + (I i) + bootstrap + ~script:Op.dummy_script >>=? fun (op, orig_contract) -> if fee > balance then Incremental.add_operation i op @@ -662,6 +702,10 @@ let unregistered_delegate_key_init_delegation_credit ~fee ~amount () = let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = + Account.(unregistered_delegate_account.pkh) + in (* credit + check balance *) Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount >>=? fun create_contract -> @@ -669,13 +713,18 @@ let unregistered_delegate_key_init_delegation_credit ~fee ~amount () = >>=? fun i -> Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> - (* origination without delegate argument *) + (* initial credit for the delegated contract *) let credit = Tez.of_int 10 in - Op.origination ~fee:Tez.zero ~credit (I i) bootstrap - >>=? fun (op, contract) -> - Incremental.add_operation i op + Lwt.return Tez.(credit +? amount) + >>=? fun balance -> + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit + >>=? fun init_credit -> + Incremental.add_operation i init_credit >>=? fun i -> - Op.delegation ~fee (I i) contract (Some unregistered_pkh) + Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance + >>=? fun _ -> + (* try to delegate *) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> if fee > credit then Incremental.add_operation i delegate_op @@ -688,13 +737,13 @@ let unregistered_delegate_key_init_delegation_credit ~fee ~amount () = else (* fee has been taken, no delegate for contract *) Incremental.add_operation - ~expect_failure:(expect_unregistered_key unregistered_pkh) + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) i delegate_op >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) contract credit fee + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee >>=? fun () -> - Context.Contract.delegate (I i) contract + Context.Contract.delegate (I i) impl_contract >>= fun err -> Assert.error ~loc:__LOC__ err (function | RPC_context.Not_found _ -> @@ -708,9 +757,16 @@ let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () = Incremental.begin_construction b >>=? fun i -> let bootstrap = List.hd bootstrap_contracts in + let bootstrap_pkh = + Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ + in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = + Account.(unregistered_delegate_account.pkh) + in (* credit + check balance *) Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount >>=? fun create_contract -> @@ -718,20 +774,27 @@ let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () = >>=? fun i -> Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount >>=? fun _ -> - (* origination without delegate setting *) - Context.Contract.manager (I i) bootstrap - >>=? fun manager -> + (* initial credit for the delegated contract *) let credit = Tez.of_int 10 in - Op.origination (I i) ~fee:Tez.zero ~credit ~delegate:manager.pkh bootstrap - >>=? fun (op, contract) -> - Incremental.add_operation i op + Lwt.return Tez.(credit +? amount) + >>=? fun balance -> + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit + >>=? fun init_credit -> + Incremental.add_operation i init_credit >>=? fun i -> - Context.Contract.delegate (I i) contract - >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh + Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance >>=? fun _ -> + (* set and check the initial delegate *) + Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh) + >>=? fun delegate_op -> + Incremental.add_operation i delegate_op + >>=? fun i -> + Context.Contract.delegate (I i) bootstrap + >>=? fun delegate_pkh -> + Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh + >>=? fun () -> (* switch delegate through delegation *) - Op.delegation ~fee (I i) contract (Some unregistered_pkh) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> if fee > credit then Incremental.add_operation i delegate_op @@ -744,16 +807,16 @@ let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () = else (* fee has been taken, delegate for contract has not changed *) Incremental.add_operation - ~expect_failure:(expect_unregistered_key unregistered_pkh) + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) i delegate_op >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) contract credit fee + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee >>=? fun () -> - Context.Contract.delegate (I i) contract + Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> - Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_pkh - >>=? fun () -> Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh + Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh + >>=? fun () -> Assert.equal_pkh ~loc:__LOC__ delegate bootstrap_pkh (* a credit of some amount followed by a debit of the same amount, no self-delegation *) let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () = @@ -782,7 +845,12 @@ let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () = (* origination with delegate argument *) Context.Contract.balance (I i) bootstrap >>=? fun balance -> - Op.origination ~fee ~delegate:unregistered_pkh (I i) bootstrap + Op.origination + ~fee + ~delegate:unregistered_pkh + (I i) + bootstrap + ~script:Op.dummy_script >>=? fun (op, orig_contract) -> if fee > balance then Incremental.add_operation i op @@ -818,6 +886,10 @@ let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () = let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = + Account.(unregistered_delegate_account.pkh) + in (* credit + check balance *) Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount >>=? fun create_contract -> @@ -832,14 +904,16 @@ let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () = >>=? fun i -> Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> - (* origination without delegate argument *) + (* initial credit for the delegated contract *) let credit = Tez.of_int 10 in - Op.origination ~fee:Tez.zero (I i) ~credit bootstrap - >>=? fun (op, contract) -> - Incremental.add_operation i op + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit + >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> - (* set a delegate with delegation operation *) - Op.delegation ~fee (I i) contract (Some unregistered_pkh) + Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit + >>=? fun _ -> + (* try to delegate *) + Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> if fee > credit then Incremental.add_operation i delegate_op @@ -852,13 +926,13 @@ let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () = else (* fee has been taken, no delegate for contract *) Incremental.add_operation - ~expect_failure:(expect_unregistered_key unregistered_pkh) + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) i delegate_op >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) contract credit fee + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee >>=? fun () -> - Context.Contract.delegate (I i) contract + Context.Contract.delegate (I i) impl_contract >>= fun err -> Assert.error ~loc:__LOC__ err (function | RPC_context.Not_found _ -> @@ -872,9 +946,16 @@ let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () = Incremental.begin_construction b >>=? fun i -> let bootstrap = List.hd bootstrap_contracts in + let bootstrap_pkh = + Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ + in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in + let unregistered_delegate_account = Account.new_account () in + let unregistered_delegate_pkh = + Account.(unregistered_delegate_account.pkh) + in (* credit + check balance *) Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount >>=? fun create_contract -> @@ -889,20 +970,25 @@ let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () = >>=? fun i -> Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> - (* origination with delegate setting *) - Context.Contract.manager (I i) bootstrap - >>=? fun manager -> + (* delegation - initial credit for the delegated contract *) let credit = Tez.of_int 10 in - Op.origination (I i) ~fee:Tez.zero ~credit ~delegate:manager.pkh bootstrap - >>=? fun (op, contract) -> - Incremental.add_operation i op + Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit + >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> - Context.Contract.delegate (I i) contract - >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh + Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit >>=? fun _ -> + (* set and check the initial delegate *) + Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh) + >>=? fun delegate_op -> + Incremental.add_operation i delegate_op + >>=? fun i -> + Context.Contract.delegate (I i) bootstrap + >>=? fun delegate_pkh -> + Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh + >>=? fun () -> (* switch delegate through delegation *) - Op.delegation (I i) ~fee contract (Some unregistered_pkh) + Op.delegation (I i) ~fee impl_contract (Some unregistered_delegate_pkh) >>=? fun delegate_op -> if fee > credit then Incremental.add_operation i delegate_op @@ -915,16 +1001,15 @@ let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () = else (* fee has been taken, delegate for contract has not changed *) Incremental.add_operation - ~expect_failure:(expect_unregistered_key unregistered_pkh) + ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh) i delegate_op >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) contract credit fee + Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee >>=? fun () -> - Context.Contract.delegate (I i) contract + Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> - Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_pkh - >>=? fun () -> Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh + Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh (* A2- self-delegation to an empty contract fails *) let failed_self_delegation_no_transaction () = @@ -990,42 +1075,7 @@ let failed_self_delegation_emptied_implicit_contract amount () = - credit implicit contract with some ꜩ + verification of balance - self delegation + verification - empty contract + verification of balance + verification of not being erased / self-delegation - - originate contract w implicit contract as delegate + verification of delegation *) -let valid_delegate_registration_init_origination_credit amount () = - (* create an implicit contract *) - Context.init 1 - >>=? fun (b, bootstrap_contracts) -> - Incremental.begin_construction b - >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in - let delegate_account = Account.new_account () in - let delegate_pkh = Account.(delegate_account.pkh) in - let impl_contract = Contract.implicit_contract delegate_pkh in - (* credit > 0ꜩ + check balance *) - Op.transaction (I i) bootstrap impl_contract amount - >>=? fun create_contract -> - Incremental.add_operation i create_contract - >>=? fun i -> - Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount - >>=? fun _ -> - (* self delegation + verification *) - Op.delegation (I i) impl_contract (Some delegate_pkh) - >>=? fun self_delegation -> - Incremental.add_operation i self_delegation - >>=? fun i -> - Context.Contract.delegate (I i) impl_contract - >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh - >>=? fun _ -> - (* originating a contract with the newly registered delegate account as delegate *) - Op.origination ~delegate:delegate_account.pkh (I i) bootstrap - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op - >>=? fun i -> - Context.Contract.delegate (I i) orig_contract - >>=? fun orig_delegate -> - Assert.equal_pkh ~loc:__LOC__ orig_delegate delegate_pkh - + - create delegator implicit contract w first implicit contract as delegate + verification of delegation *) let valid_delegate_registration_init_delegation_credit amount () = (* create an implicit contract *) Context.init 1 @@ -1052,13 +1102,16 @@ let valid_delegate_registration_init_delegation_credit amount () = >>=? fun delegate -> Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh >>=? fun _ -> - (* originating a contract with no delegate *) - Op.origination (I i) bootstrap - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op + (* create an implicit contract with no delegate *) + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let delegator = Contract.implicit_contract unregistered_pkh in + Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one + >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> - (* check no delegate for orig contract *) - Context.Contract.delegate (I i) orig_contract + (* check no delegate for delegator contract *) + Context.Contract.delegate (I i) delegator >>= fun err -> Assert.error ~loc:__LOC__ err (function | RPC_context.Not_found _ -> @@ -1067,14 +1120,14 @@ let valid_delegate_registration_init_delegation_credit amount () = false) >>=? fun _ -> (* delegation to the newly registered key *) - Op.delegation (I i) orig_contract (Some delegate_account.pkh) + Op.delegation (I i) delegator (Some delegate_account.pkh) >>=? fun delegation -> Incremental.add_operation i delegation >>=? fun i -> (* check delegation *) - Context.Contract.delegate (I i) orig_contract - >>=? fun orig_delegate -> - Assert.equal_pkh ~loc:__LOC__ orig_delegate delegate_pkh + Context.Contract.delegate (I i) delegator + >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh let valid_delegate_registration_switch_delegation_credit amount () = (* create an implicit contract *) @@ -1102,76 +1155,33 @@ let valid_delegate_registration_switch_delegation_credit amount () = >>=? fun delegate -> Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh >>=? fun _ -> - (* originating a contract with bootstrap's account as delegate *) + (* create an implicit contract with bootstrap's account as delegate *) + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let delegator = Contract.implicit_contract unregistered_pkh in + Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one + >>=? fun credit_contract -> + Incremental.add_operation i credit_contract + >>=? fun i -> Context.Contract.manager (I i) bootstrap >>=? fun bootstrap_manager -> - Op.origination (I i) ~delegate:bootstrap_manager.pkh bootstrap - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op + Op.delegation (I i) delegator (Some bootstrap_manager.pkh) + >>=? fun delegation -> + Incremental.add_operation i delegation >>=? fun i -> (* test delegate of new contract is bootstrap *) - Context.Contract.delegate (I i) orig_contract - >>=? fun orig_delegate -> - Assert.equal_pkh ~loc:__LOC__ orig_delegate bootstrap_manager.pkh + Context.Contract.delegate (I i) delegator + >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh >>=? fun _ -> (* delegation with newly registered key *) - Op.delegation (I i) orig_contract (Some delegate_account.pkh) + Op.delegation (I i) delegator (Some delegate_account.pkh) >>=? fun delegation -> Incremental.add_operation i delegation >>=? fun i -> - Context.Contract.delegate (I i) orig_contract - >>=? fun orig_delegate -> - Assert.equal_pkh ~loc:__LOC__ orig_delegate delegate_pkh - -let valid_delegate_registration_init_origination_credit_debit amount () = - (* create an implicit contract *) - Context.init 1 - >>=? fun (b, bootstrap_contracts) -> - Incremental.begin_construction b - >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in - let delegate_account = Account.new_account () in - let delegate_pkh = Account.(delegate_account.pkh) in - let impl_contract = Contract.implicit_contract delegate_pkh in - (* credit > 0ꜩ+ check balance *) - Op.transaction (I i) bootstrap impl_contract amount - >>=? fun create_contract -> - Incremental.add_operation i create_contract - >>=? fun i -> - Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount - >>=? fun _ -> - (* self delegation + verification *) - Op.delegation (I i) impl_contract (Some delegate_pkh) - >>=? fun self_delegation -> - Incremental.add_operation i self_delegation - >>=? fun i -> - Context.Contract.delegate (I i) impl_contract - >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate - >>=? fun _ -> - (* empty implicit contracts are usually deleted but they are kept if - they were registered as delegates. we empty the contract in - order to verify this. *) - Op.transaction (I i) impl_contract bootstrap amount - >>=? fun empty_contract -> - Incremental.add_operation i empty_contract - >>=? fun i -> - (* impl_contract is empty *) - Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero - >>=? fun _ -> - (* verify self-delegation after contract is emptied *) - Context.Contract.delegate (I i) impl_contract - >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate - >>=? fun _ -> - (* originating a contract with the newly registered delegate account as delegate *) - Op.origination ~delegate:delegate_account.pkh (I i) bootstrap - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op - >>=? fun i -> - Context.Contract.delegate (I i) orig_contract - >>=? fun orig_delegate -> - Assert.equal_pkh ~loc:__LOC__ orig_delegate delegate_pkh + Context.Contract.delegate (I i) delegator + >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh let valid_delegate_registration_init_delegation_credit_debit amount () = (* create an implicit contract *) @@ -1214,13 +1224,16 @@ let valid_delegate_registration_init_delegation_credit_debit amount () = >>=? fun delegate -> Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate >>=? fun _ -> - (* originating a contract with no delegate *) - Op.origination (I i) bootstrap - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op + (* create an implicit contract with no delegate *) + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let delegator = Contract.implicit_contract unregistered_pkh in + Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one + >>=? fun credit_contract -> + Incremental.add_operation i credit_contract >>=? fun i -> - (* check no delegate for orig contract *) - Context.Contract.delegate (I i) orig_contract + (* check no delegate for delegator contract *) + Context.Contract.delegate (I i) delegator >>= fun err -> Assert.error ~loc:__LOC__ err (function | RPC_context.Not_found _ -> @@ -1229,14 +1242,14 @@ let valid_delegate_registration_init_delegation_credit_debit amount () = false) >>=? fun _ -> (* delegation to the newly registered key *) - Op.delegation (I i) orig_contract (Some delegate_account.pkh) + Op.delegation (I i) delegator (Some delegate_account.pkh) >>=? fun delegation -> Incremental.add_operation i delegation >>=? fun i -> (* check delegation *) - Context.Contract.delegate (I i) orig_contract - >>=? fun orig_delegate -> - Assert.equal_pkh ~loc:__LOC__ orig_delegate delegate_pkh + Context.Contract.delegate (I i) delegator + >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh let valid_delegate_registration_switch_delegation_credit_debit amount () = (* create an implicit contract *) @@ -1274,26 +1287,33 @@ let valid_delegate_registration_switch_delegation_credit_debit amount () = (* impl_contract is empty *) Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero >>=? fun _ -> - (* originating a contract with bootstrap's account as delegate *) + (* create an implicit contract with bootstrap's account as delegate *) + let unregistered_account = Account.new_account () in + let unregistered_pkh = Account.(unregistered_account.pkh) in + let delegator = Contract.implicit_contract unregistered_pkh in + Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one + >>=? fun credit_contract -> + Incremental.add_operation i credit_contract + >>=? fun i -> Context.Contract.manager (I i) bootstrap >>=? fun bootstrap_manager -> - Op.origination (I i) ~delegate:bootstrap_manager.pkh bootstrap - >>=? fun (op, orig_contract) -> - Incremental.add_operation i op + Op.delegation (I i) delegator (Some bootstrap_manager.pkh) + >>=? fun delegation -> + Incremental.add_operation i delegation >>=? fun i -> (* test delegate of new contract is bootstrap *) - Context.Contract.delegate (I i) orig_contract - >>=? fun orig_delegate -> - Assert.equal_pkh ~loc:__LOC__ orig_delegate bootstrap_manager.pkh + Context.Contract.delegate (I i) delegator + >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh >>=? fun _ -> (* delegation with newly registered key *) - Op.delegation (I i) orig_contract (Some delegate_account.pkh) + Op.delegation (I i) delegator (Some delegate_account.pkh) >>=? fun delegation -> Incremental.add_operation i delegation >>=? fun i -> - Context.Contract.delegate (I i) orig_contract - >>=? fun orig_delegate -> - Assert.equal_pkh ~loc:__LOC__ orig_delegate delegate_pkh + Context.Contract.delegate (I i) delegator + >>=? fun delegator_delegate -> + Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh (* with implicit contract with some credit *) @@ -1417,22 +1437,22 @@ let double_registration_when_recredited () = | _ -> false) -(* originate and self-delegation on unrevealed contract *) -let unregistered_and_unrevealed_self_delegate_key_init_origination ~fee () = +(* self-delegation on unrevealed contract *) +let unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> let bootstrap = List.hd bootstrap_contracts in let {Account.pkh; _} = Account.new_account () in + let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in Op.transaction (I i) bootstrap contract (Tez.of_int 10) >>=? fun op -> Incremental.add_operation i op >>=? fun i -> - (* origination with delegate argument *) - Op.origination ~fee ~delegate:pkh (I i) contract - >>=? fun (op, orig_contract) -> + Op.delegation ~fee (I i) contract (Some delegate_pkh) + >>=? fun op -> Context.Contract.balance (I i) contract >>=? fun balance -> if fee > balance then @@ -1446,29 +1466,21 @@ let unregistered_and_unrevealed_self_delegate_key_init_origination ~fee () = else (* origination did not proceed; fee has been debited *) Incremental.add_operation - ~expect_failure:(expect_unregistered_key pkh) + ~expect_failure:(expect_unregistered_key delegate_pkh) i op >>=? fun i -> Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee - >>=? fun () -> - (* originated contract has not been created *) - Context.Contract.balance (I i) orig_contract - >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | RPC_context.Not_found _ -> - true - | _ -> - false) -(* originate and self-delegation on revelead but not registered contract *) -let unregistered_and_revealed_self_delegate_key_init_origination ~fee () = +(* self-delegation on revelead but not registered contract *) +let unregistered_and_revealed_self_delegate_key_init_delegation ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> let bootstrap = List.hd bootstrap_contracts in let {Account.pkh; pk; _} = Account.new_account () in + let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in Op.transaction (I i) bootstrap contract (Tez.of_int 10) >>=? fun op -> @@ -1478,9 +1490,8 @@ let unregistered_and_revealed_self_delegate_key_init_origination ~fee () = >>=? fun op -> Incremental.add_operation i op >>=? fun i -> - (* origination with delegate argument *) - Op.origination ~fee ~delegate:pkh (I i) contract - >>=? fun (op, orig_contract) -> + Op.delegation ~fee (I i) contract (Some delegate_pkh) + >>=? fun op -> Context.Contract.balance (I i) contract >>=? fun balance -> if fee > balance then @@ -1494,58 +1505,50 @@ let unregistered_and_revealed_self_delegate_key_init_origination ~fee () = else (* origination did not proceed; fee has been debited *) Incremental.add_operation - ~expect_failure:(expect_unregistered_key pkh) + ~expect_failure:(expect_unregistered_key delegate_pkh) i op >>=? fun i -> Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee - >>=? fun () -> - (* originated contract has not been created *) - Context.Contract.balance (I i) orig_contract - >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | RPC_context.Not_found _ -> - true - | _ -> - false) -(* originate and self-delegation on revealed and registered contract *) -let registered_self_delegate_key_init_origination () = +(* self-delegation on revealed and registered contract *) +let registered_self_delegate_key_init_delegation () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> let bootstrap = List.hd bootstrap_contracts in - let {Account.pkh; pk; _} = Account.new_account () in + let {Account.pkh; _} = Account.new_account () in + let {Account.pkh = delegate_pkh; pk = delegate_pk; _} = + Account.new_account () + in let contract = Alpha_context.Contract.implicit_contract pkh in + let delegate_contract = + Alpha_context.Contract.implicit_contract delegate_pkh + in Op.transaction (I i) bootstrap contract (Tez.of_int 10) >>=? fun op -> Incremental.add_operation i op >>=? fun i -> - Op.revelation (I i) pk + Op.transaction (I i) bootstrap delegate_contract (Tez.of_int 1) >>=? fun op -> Incremental.add_operation i op >>=? fun i -> - Op.delegation (I i) contract (Some pkh) + Op.revelation (I i) delegate_pk >>=? fun op -> Incremental.add_operation i op >>=? fun i -> - Context.Contract.balance (I i) contract - >>=? fun balance -> - Context.get_constants (I i) - >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> - Tez.(cost_per_byte *? Int64.of_int origination_size) - >>?= fun origination_burn -> - (* origination with delegate argument *) - Op.origination ~delegate:pkh ~credit:Tez.one (I i) contract - >>=? fun (op, orig_contract) -> - Tez.(origination_burn +? Tez.one) - >>?= fun total_cost -> + Op.delegation (I i) delegate_contract (Some delegate_pkh) + >>=? fun op -> Incremental.add_operation i op >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance total_cost - >>=? fun () -> - Assert.balance_is ~loc:__LOC__ (I i) orig_contract Tez.one + Op.delegation (I i) contract (Some delegate_pkh) + >>=? fun op -> + Incremental.add_operation i op + >>=? fun i -> + Context.Contract.delegate (I i) contract + >>=? fun delegate -> + Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh >>=? fun () -> return_unit let tests_delegate_registration = @@ -1667,33 +1670,33 @@ let tests_delegate_registration = (unregistered_delegate_key_switch_delegation_credit ~amount:Tez.one_mutez ~fee:Tez.max_tez); - (* origination with self_delegation on unrevealed and unregistered contract *) + (* self delegation on unrevealed and unregistered contract *) Test.tztest - "unregistered and unrevealed self-delegation (origination, small fee)" + "unregistered and unrevealed self-delegation (small fee)" `Quick - (unregistered_and_unrevealed_self_delegate_key_init_origination + (unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee:Tez.one_mutez); Test.tztest - "unregistered and unrevealed self-delegation (origination, large fee)" + "unregistered and unrevealed self-delegation (large fee)" `Quick - (unregistered_and_unrevealed_self_delegate_key_init_origination + (unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee:Tez.max_tez); - (* origination with self_delegation on unregistered contract *) + (* self delegation on unregistered contract *) Test.tztest - "unregistered and revealed self-delegation (origination, small fee)" + "unregistered and revealed self-delegation (small fee)" `Quick - (unregistered_and_revealed_self_delegate_key_init_origination + (unregistered_and_revealed_self_delegate_key_init_delegation ~fee:Tez.one_mutez); Test.tztest - "unregistered and revealed self-delegation (origination, large fee)" + "unregistered and revealed self-delegation large fee)" `Quick - (unregistered_and_revealed_self_delegate_key_init_origination + (unregistered_and_revealed_self_delegate_key_init_delegation ~fee:Tez.max_tez); - (* origination with self_delegation on registered contract *) + (* self delegation on registered contract *) Test.tztest - "registered and revelead self-delegation (origination)" + "registered and revelead self-delegation" `Quick - registered_self_delegate_key_init_origination; + registered_self_delegate_key_init_delegation; (*** unregistered delegate key: failed self-delegation ***) (* no token transfer, self-delegation *) Test.tztest @@ -1707,11 +1710,6 @@ let tests_delegate_registration = (failed_self_delegation_emptied_implicit_contract Tez.one_mutez); (*** valid registration ***) (* valid registration: credit 1 μꜩ, self delegation *) - Test.tztest - "valid delegate registration: credit 1μꜩ, self delegation \ - (origination)" - `Quick - (valid_delegate_registration_init_origination_credit Tez.one_mutez); Test.tztest "valid delegate registration: credit 1μꜩ, self delegation (init with \ delegation)" @@ -1723,11 +1721,6 @@ let tests_delegate_registration = `Quick (valid_delegate_registration_switch_delegation_credit Tez.one_mutez); (* valid registration: credit 1 μꜩ, self delegation, debit 1μꜩ *) - Test.tztest - "valid delegate registration: credit 1μꜩ, self delegation, debit \ - 1μꜩ (origination)" - `Quick - (valid_delegate_registration_init_origination_credit_debit Tez.one_mutez); Test.tztest "valid delegate registration: credit 1μꜩ, self delegation, debit \ 1μꜩ (init with delegation)" diff --git a/src/proto_alpha/lib_protocol/test/double_endorsement.ml b/src/proto_alpha/lib_protocol/test/double_endorsement.ml index 982cec9b488b509f11aaf304d8ffd224de5e32df..accc3c0ded72d7f22965479cbfff5f4a69214b74 100644 --- a/src/proto_alpha/lib_protocol/test/double_endorsement.ml +++ b/src/proto_alpha/lib_protocol/test/double_endorsement.ml @@ -131,7 +131,7 @@ let too_early_double_endorsement_evidence () = block_fork b >>=? fun (blk_a, blk_b) -> Context.get_endorser (B blk_a) - >>=? fun (delegate, _) -> + >>=? fun (delegate, _slots) -> Op.endorsement ~delegate (B blk_a) () >>=? fun endorsement_a -> Op.endorsement ~delegate (B blk_b) () @@ -222,11 +222,11 @@ let wrong_delegate () = block_fork b >>=? fun (blk_a, blk_b) -> Context.get_endorser (B blk_a) - >>=? fun (endorser_a, _) -> + >>=? fun (endorser_a, _a_slots) -> Op.endorsement ~delegate:endorser_a (B blk_a) () >>=? fun endorsement_a -> Context.get_endorser (B blk_b) - >>=? fun (endorser_b, _) -> + >>=? fun (endorser_b, _b_slots) -> let delegate = if Signature.Public_key_hash.equal pkh1 endorser_b then pkh2 else pkh1 in diff --git a/src/proto_alpha/lib_protocol/test/endorsement.ml b/src/proto_alpha/lib_protocol/test/endorsement.ml index e4e511211f013c55a83e27b6f39aeeaf923466b4..ecf3a06670207978ff859c6f9d6bc5da609fbfff 100644 --- a/src/proto_alpha/lib_protocol/test/endorsement.ml +++ b/src/proto_alpha/lib_protocol/test/endorsement.ml @@ -25,10 +25,10 @@ (** Endorsing a block adds an extra layer of confidence to the Tezos's PoS algorithm. The block endorsing operation must be included in - the following block. Each endorser possess a slot corresponding to - their priority. After [preserved_cycles], a reward is given to the - endorser. This reward depends on the priority of the endorsed - block. *) + the following block. Each endorser possess a number of slots + corresponding to their priority. After [preserved_cycles], a reward + is given to the endorser. This reward depends on the priority of + the block that contains the endorsements. *) open Protocol open Alpha_context @@ -39,20 +39,16 @@ open Test_tez (* Utility functions *) (****************************************************************) -let get_expected_reward ?(priority = 0) ~nb_baking ~nb_endorsement ctxt = - Context.get_constants ctxt - >>=? fun Constants.{parametric = {endorsement_reward; block_reward; _}; _} -> - let open Environment in - let open Tez in - (endorsement_reward /? Int64.(succ (of_int priority))) - >>?= fun endorsement_reward -> - endorsement_reward *? Int64.of_int nb_endorsement - >>?= fun endorsement_reward -> - block_reward *? Int64.of_int nb_baking - >>?= fun baking_reward -> - endorsement_reward +? baking_reward >>?= fun reward -> return reward +let get_expected_reward ctxt ~priority ~baker ~endorsing_power = + ( if baker then Context.get_baking_reward ctxt ~priority ~endorsing_power + else return (Test_tez.Tez.of_int 0) ) + >>=? fun baking_reward -> + Context.get_endorsing_reward ctxt ~priority ~endorsing_power + >>=? fun endorsing_reward -> + Test_tez.Tez.(endorsing_reward +? baking_reward) + >>?= fun reward -> return reward -let get_expected_deposit ctxt ~nb_baking ~nb_endorsement = +let get_expected_deposit ctxt ~baker ~endorsing_power = Context.get_constants ctxt >>=? fun Constants. { parametric = @@ -60,18 +56,19 @@ let get_expected_deposit ctxt ~nb_baking ~nb_endorsement = _ } -> let open Environment in let open Tez in - endorsement_security_deposit *? Int64.of_int nb_endorsement + let baking_deposit = if baker then block_security_deposit else of_int 0 in + endorsement_security_deposit *? Int64.of_int endorsing_power >>?= fun endorsement_deposit -> - block_security_deposit *? Int64.of_int nb_baking - >>?= fun baking_deposit -> endorsement_deposit +? baking_deposit >>?= fun deposit -> return deposit -let assert_endorser_balance_consistency ~loc ?(priority = 0) ?(nb_baking = 0) - ~nb_endorsement ctxt pkh initial_balance = +(* [baker] is true if the [pkh] has also baked the current block, in + which case correspoding deposit and reward should be ajusted *) +let assert_endorser_balance_consistency ~loc ?(priority = 0) ?(baker = false) + ~endorsing_power ctxt pkh initial_balance = let contract = Contract.implicit_contract pkh in - get_expected_reward ~priority ~nb_baking ~nb_endorsement ctxt + get_expected_reward ctxt ~priority ~baker ~endorsing_power >>=? fun reward -> - get_expected_deposit ctxt ~nb_baking ~nb_endorsement + get_expected_deposit ctxt ~baker ~endorsing_power >>=? fun deposit -> Assert.balance_was_debited ~loc ctxt contract initial_balance deposit >>=? fun () -> @@ -82,6 +79,19 @@ let assert_endorser_balance_consistency ~loc ?(priority = 0) ?(nb_baking = 0) Context.Contract.balance ~kind:Deposit ctxt contract >>=? fun deposit_balance -> Assert.equal_tez ~loc deposit_balance deposit +let delegates_with_slots endorsers = + List.map + (fun (endorser : Delegate_services.Endorsing_rights.t) -> + endorser.delegate) + endorsers + +let endorsing_power endorsers = + List.fold_left + (fun sum (endorser : Delegate_services.Endorsing_rights.t) -> + sum + List.length endorser.slots) + 0 + endorsers + (****************************************************************) (* Tests *) (****************************************************************) @@ -96,17 +106,21 @@ let simple_endorsement () = >>=? fun op -> Context.Contract.balance (B b) (Contract.implicit_contract delegate) >>=? fun initial_balance -> - Block.bake ~policy:(Excluding [delegate]) ~operations:[Operation.pack op] b + let policy = Block.Excluding [delegate] in + Block.get_next_baker ~policy b + >>=? fun (_, priority, _) -> + Block.bake ~policy ~operations:[Operation.pack op] b >>=? fun b2 -> assert_endorser_balance_consistency ~loc:__LOC__ (B b2) - ~nb_endorsement:(List.length slots) + ~priority + ~endorsing_power:(List.length slots) delegate initial_balance -(** Apply a maximum number of endorsement. A endorser can be selected - twice. *) +(** Apply a maximum number of endorsements. An endorser can be + selected twice. *) let max_endorsement () = let endorsers_per_block = 16 in Context.init ~endorsers_per_block 32 @@ -142,92 +156,75 @@ let max_endorsement () = (* One account can endorse more than one time per level, we must check that the bonds are summed up *) iter_s - (fun (endorser_account, (nb_endorsement, previous_balance)) -> + (fun (endorser_account, (endorsing_power, previous_balance)) -> assert_endorser_balance_consistency ~loc:__LOC__ (B b) - ~nb_endorsement + ~endorsing_power endorser_account previous_balance) (List.combine delegates previous_balances) -(** Check that an endorser balance is consistent with a different priority *) -let consistent_priority () = - Context.init 32 - >>=? fun (b, _) -> - Block.get_next_baker ~policy:(By_priority 15) b - >>=? fun (baker_account, _, _) -> - Block.bake ~policy:(By_priority 15) b - >>=? fun b -> - (* Grab an endorser that didn't bake the previous block *) - Context.get_endorsers (B b) - >>=? fun endorsers -> - let endorser = - List.find - (fun e -> e.Delegate_services.Endorsing_rights.delegate <> baker_account) - endorsers - in - Context.Contract.balance (B b) (Contract.implicit_contract endorser.delegate) - >>=? fun balance -> - Op.endorsement ~delegate:endorser.delegate (B b) () - >>=? fun operation -> - let operation = Operation.pack operation in - Block.bake ~policy:(Excluding [endorser.delegate]) ~operation b - >>=? fun b -> - assert_endorser_balance_consistency - ~loc:__LOC__ - ~priority:15 - (B b) - ~nb_endorsement:(List.length endorser.slots) - endorser.delegate - balance - -(** Check every 32 endorser's balances are consistent with a different priority *) +(** Check every that endorsers' balances are consistent with different priorities *) let consistent_priorities () = - let priorities = 15 -- 31 in + let priorities = 0 -- 64 in Context.init 64 >>=? fun (b, _) -> - iter_s - (fun priority -> - (* Bake with a specific priority *) - Block.get_next_baker ~policy:(By_priority priority) b - >>=? fun (baker_account, _, _) -> - Block.bake ~policy:(By_priority priority) b - >>=? fun b -> - (* Grab an endorser that didn't bake the previous block *) + fold_left_s + (fun (b, used_pkhes) priority -> + (* Choose an endorser that has not baked nor endorsed before *) Context.get_endorsers (B b) >>=? fun endorsers -> let endorser = - List.find - (fun e -> - e.Delegate_services.Endorsing_rights.delegate <> baker_account) + List.find_opt + (fun (e : Delegate_services.Endorsing_rights.t) -> + not (Signature.Public_key_hash.Set.mem e.delegate used_pkhes)) endorsers in - Context.Contract.balance - (B b) - (Contract.implicit_contract endorser.delegate) - >>=? fun balance -> - Op.endorsement ~delegate:endorser.delegate (B b) () - >>=? fun operation -> - let operation = Operation.pack operation in - Block.bake ~policy:(Excluding [endorser.delegate]) ~operation b - >>=? fun b -> - assert_endorser_balance_consistency - ~loc:__LOC__ - ~priority - (B b) - ~nb_endorsement:(List.length endorser.slots) - endorser.delegate - balance) + match endorser with + | None -> + return (b, used_pkhes) (* not enough fresh endorsers; we "stop" *) + | Some endorser -> + Context.Contract.balance + (B b) + (Contract.implicit_contract endorser.delegate) + >>=? fun balance -> + Op.endorsement ~delegate:endorser.delegate (B b) () + >>=? fun operation -> + let operation = Operation.pack operation in + Block.get_next_baker ~policy:(By_priority priority) b + >>=? fun (baker, _, _) -> + let used_pkhes = + Signature.Public_key_hash.Set.add baker used_pkhes + in + let used_pkhes = + Signature.Public_key_hash.Set.add endorser.delegate used_pkhes + in + (* Bake with a specific priority *) + Block.bake ~policy:(By_priority priority) ~operation b + >>=? fun b -> + let is_baker = + Signature.Public_key_hash.(baker = endorser.delegate) + in + assert_endorser_balance_consistency + ~loc:__LOC__ + ~priority + ~baker:is_baker + (B b) + ~endorsing_power:(List.length endorser.slots) + endorser.delegate + balance + >>=? fun () -> return (b, used_pkhes)) + (b, Signature.Public_key_hash.Set.empty) priorities + >>=? fun _b -> return_unit (** Check that after [preserved_cycles] cycles the endorser gets his reward *) let reward_retrieval () = Context.init 5 >>=? fun (b, _) -> Context.get_constants (B b) - >>=? fun Constants.{parametric = {preserved_cycles; endorsement_reward; _}; _} - -> + >>=? fun Constants.{parametric = {preserved_cycles; _}; _} -> Context.get_endorser (B b) >>=? fun (endorser, slots) -> Context.Contract.balance (B b) (Contract.implicit_contract endorser) @@ -235,7 +232,10 @@ let reward_retrieval () = Op.endorsement ~delegate:endorser (B b) () >>=? fun operation -> let operation = Operation.pack operation in - Block.bake ~policy:(Excluding [endorser]) ~operation b + let policy = Block.Excluding [endorser] in + Block.get_next_baker ~policy b + >>=? fun (_, priority, _) -> + Block.bake ~policy ~operation b >>=? fun b -> (* Bake (preserved_cycles + 1) cycles *) fold_left_s @@ -243,7 +243,11 @@ let reward_retrieval () = b (0 -- preserved_cycles) >>=? fun b -> - Lwt.return Tez.(endorsement_reward *? Int64.of_int (List.length slots)) + get_expected_reward + (B b) + ~priority + ~baker:false + ~endorsing_power:(List.length slots) >>=? fun reward -> Assert.balance_was_credited ~loc:__LOC__ @@ -270,7 +274,6 @@ let reward_retrieval_two_endorsers () = >>=? fun endorsers -> let endorser1 = List.hd endorsers in let endorser2 = List.hd (List.tl endorsers) in - let policy = Block.Excluding [endorser1.delegate; endorser2.delegate] in Context.Contract.balance (B b) (Contract.implicit_contract endorser1.delegate) @@ -284,12 +287,17 @@ let reward_retrieval_two_endorsers () = endorsement_security_deposit *? Int64.of_int (List.length endorser1.slots)) >>=? fun security_deposit1 -> - Lwt.return - Tez.(endorsement_reward *? Int64.of_int (List.length endorser1.slots)) - >>=? fun reward1 -> (* endorser1 endorses the genesis block in cycle 0 *) Op.endorsement ~delegate:endorser1.delegate (B b) () >>=? fun operation1 -> + let policy = Block.Excluding [endorser1.delegate; endorser2.delegate] in + Block.get_next_baker ~policy b + >>=? fun (_, priority, _) -> + Tez.(endorsement_reward /? Int64.(succ (of_int priority))) + >>?= fun reward_per_slot -> + Lwt.return + Tez.(reward_per_slot *? Int64.of_int (List.length endorser1.slots)) + >>=? fun reward1 -> (* bake next block, include endorsement of endorser1 *) Block.bake ~policy ~operation:(Operation.pack operation1) b >>=? fun b -> @@ -326,10 +334,8 @@ let reward_retrieval_two_endorsers () = Context.get_endorsers (B b) >>=? fun endorsers -> let same_endorser2 endorser = - Signature.Public_key_hash.compare - endorser.Delegate_services.Endorsing_rights.delegate - endorser2.delegate - = 0 + Signature.Public_key_hash.( + endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate) in let endorser2 = List.find same_endorser2 endorsers in (* No exception raised: in sandboxed mode endorsers do not change between blocks *) @@ -341,15 +347,15 @@ let reward_retrieval_two_endorsers () = (* endorser2 endorses the last block in cycle 0 *) Op.endorsement ~delegate:endorser2.delegate (B b) () >>=? fun operation2 -> + (* bake first block in cycle 1, include endorsement of endorser2 *) + Block.bake ~policy ~operation:(Operation.pack operation2) b + >>=? fun b -> let priority = b.header.protocol_data.contents.priority in Tez.(endorsement_reward /? Int64.(succ (of_int priority))) >>?= fun reward_per_slot -> Lwt.return Tez.(reward_per_slot *? Int64.of_int (List.length endorser2.slots)) >>=? fun reward2 -> - (* bake first block in cycle 1, include endorsement of endorser2 *) - Block.bake ~policy ~operation:(Operation.pack operation2) b - >>=? fun b -> Assert.balance_was_debited ~loc:__LOC__ (B b) @@ -482,15 +488,19 @@ let duplicate_endorsement () = false) (** Apply a single endorsement from the slot 0 endorser *) -let no_enough_for_deposit () = +let not_enough_for_deposit () = Context.init 5 ~endorsers_per_block:1 - >>=? fun (b, contracts) -> + >>=? fun (b_init, contracts) -> Error_monad.map_s - (fun c -> Context.Contract.manager (B b) c >>=? fun m -> return (m, c)) + (fun c -> + Context.Contract.manager (B b_init) c >>=? fun m -> return (m, c)) contracts >>=? fun managers -> + Block.bake b_init + >>=? fun b -> + (* retrieve the level 2's endorser *) Context.get_endorser (B b) - >>=? fun (endorser, _) -> + >>=? fun (endorser, _slots) -> let (_, contract_other_than_endorser) = List.find (fun (c, _) -> @@ -502,19 +512,23 @@ let no_enough_for_deposit () = (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser) managers in - Op.endorsement ~delegate:endorser (B b) () - >>=? fun op_endo -> Context.Contract.balance (B b) (Contract.implicit_contract endorser) >>=? fun initial_balance -> + (* Empty the future endorser account *) Op.transaction - (B b) + (B b_init) contract_of_endorser contract_other_than_endorser initial_balance >>=? fun op_trans -> + Block.bake ~operation:op_trans b_init + >>=? fun b -> + (* Endorse with a zero balance *) + Op.endorsement ~delegate:endorser (B b) () + >>=? fun op_endo -> Block.bake ~policy:(Excluding [endorser]) - ~operations:[Operation.pack op_endo; op_trans] + ~operation:(Operation.pack op_endo) b >>= fun res -> Assert.proto_error ~loc:__LOC__ res (function @@ -523,16 +537,104 @@ let no_enough_for_deposit () = | _ -> false) +(* check that a block with not enough endorsement cannot be baked *) +let endorsement_threshold () = + let initial_endorsers = 28 in + let num_accounts = 100 in + Context.init ~initial_endorsers num_accounts + >>=? fun (b, _) -> + Context.get_endorsers (B b) + >>=? fun endorsers -> + let num_endorsers = List.length endorsers in + (* we try to bake with more and more endorsers, but at each + iteration with a timestamp smaller than required *) + iter_s + (fun i -> + (* the priority is chosen rather arbitrarily *) + let priority = num_endorsers - i in + let crt_endorsers = List.take_n i endorsers in + let endorsing_power = endorsing_power crt_endorsers in + let delegates = delegates_with_slots crt_endorsers in + map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates + >>=? fun ops -> + Context.get_minimal_valid_time (B b) ~priority ~endorsing_power + >>=? fun timestamp -> + (* decrease the timestamp by one second *) + let seconds = + Int64.(sub (of_string (Timestamp.to_seconds_string timestamp)) 1L) + in + match Timestamp.of_seconds (Int64.to_string seconds) with + | None -> + failwith "timestamp to/from string manipulation failed" + | Some timestamp -> + Block.bake + ~timestamp + ~policy:(By_priority priority) + ~operations:(List.map Operation.pack ops) + b + >>= fun b2 -> + Assert.proto_error ~loc:__LOC__ b2 (function + | Baking.Timestamp_too_early _ + | Apply.Not_enough_endorsements_for_priority _ -> + true + | _ -> + false)) + (0 -- (num_endorsers - 1)) + >>=? fun () -> + (* we bake with all endorsers endorsing, at the right time *) + let priority = 0 in + let endorsing_power = endorsing_power endorsers in + let delegates = delegates_with_slots endorsers in + map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates + >>=? fun ops -> + Context.get_minimal_valid_time (B b) ~priority ~endorsing_power + >>=? fun timestamp -> + Block.bake + ~policy:(By_priority priority) + ~timestamp + ~operations:(List.map Operation.pack ops) + b + >>= fun _ -> return_unit + +let test_fitness_gap () = + let num_accounts = 5 in + Context.init num_accounts + >>=? fun (b, _) -> + ( match Fitness_repr.to_int64 b.header.shell.fitness with + | Ok fitness -> + return (Int64.to_int fitness) + | Error _ -> + assert false ) + >>=? fun fitness -> + Context.get_endorser (B b) + >>=? fun (delegate, _slots) -> + Op.endorsement ~delegate (B b) () + >>=? fun op -> + (* bake at priority 0 succeed thanks to enough endorsements *) + Block.bake ~policy:(By_priority 0) ~operations:[Operation.pack op] b + >>=? fun b -> + ( match Fitness_repr.to_int64 b.header.shell.fitness with + | Ok new_fitness -> + return (Int64.to_int new_fitness - fitness) + | Error _ -> + assert false ) + >>=? fun res -> + (* in Emmy+, the fitness increases by 1, so the difference between + the fitness at level 1 and at level 0 is 1, independently if the + number fo endorements (here 1) *) + Assert.equal_int ~loc:__LOC__ res 1 >>=? fun () -> return_unit + let tests = [ Test.tztest "Simple endorsement" `Quick simple_endorsement; Test.tztest "Maximum endorsement" `Quick max_endorsement; - Test.tztest "Consistent priority" `Quick consistent_priority; Test.tztest "Consistent priorities" `Quick consistent_priorities; Test.tztest "Reward retrieval" `Quick reward_retrieval; Test.tztest "Reward retrieval two endorsers" `Quick reward_retrieval_two_endorsers; + Test.tztest "Endorsement threshold" `Quick endorsement_threshold; + Test.tztest "Fitness gap" `Quick test_fitness_gap; (* Fail scenarios *) Test.tztest "Wrong endorsement predecessor" @@ -540,4 +642,4 @@ let tests = wrong_endorsement_predecessor; Test.tztest "Invalid endorsement level" `Quick invalid_endorsement_level; Test.tztest "Duplicate endorsement" `Quick duplicate_endorsement; - Test.tztest "Not enough for deposit" `Quick no_enough_for_deposit ] + Test.tztest "Not enough for deposit" `Quick not_enough_for_deposit ] diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 6a9b12ad3a583bf89234def63c90cf0e479ae8c3..03b87d3895560721da3921f815f3009352d77693 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -113,6 +113,23 @@ let dispatch_policy = function let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy +let get_endorsing_power b = + fold_left_s + (fun acc (op : Operation.packed) -> + let (Operation_data data) = op.protocol_data in + match data.contents with + | Single (Endorsement _) -> + Alpha_services.Delegate.Endorsing_power.get + rpc_ctxt + b + op + Chain_id.zero + >>=? fun endorsement_power -> return (acc + endorsement_power) + | _ -> + return acc) + 0 + b.operations + module Forge = struct type header = { baker : public_key_hash; @@ -163,9 +180,13 @@ module Forge = struct in Block_header.{shell; protocol_data = {contents; signature}} |> return - let forge_header ?(policy = By_priority 0) ?(operations = []) pred = + let forge_header ?(policy = By_priority 0) ?timestamp ?(operations = []) pred + = dispatch_policy policy pred - >>=? fun (pkh, priority, timestamp) -> + >>=? fun (pkh, priority, _timestamp) -> + Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt pred priority 0 + >>=? fun expected_timestamp -> + let timestamp = Option.unopt ~default:expected_timestamp timestamp in let level = Int32.succ pred.header.shell.level in ( match Fitness_repr.to_int64 pred.header.shell.fitness with | Ok old_fitness -> @@ -288,8 +309,8 @@ let genesis_with_parameters parameters = (* if no parameter file is passed we check in the current directory where the test is run *) -let genesis ?with_commitments ?endorsers_per_block - (initial_accounts : (Account.t * Tez_repr.t) list) = +let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers + ?min_proposal_quorum (initial_accounts : (Account.t * Tez_repr.t) list) = if initial_accounts = [] then Pervasives.failwith "Must have one account with a roll to bake" ; let open Tezos_protocol_alpha_parameters in @@ -297,7 +318,20 @@ let genesis ?with_commitments ?endorsers_per_block let endorsers_per_block = Option.unopt ~default:constants.endorsers_per_block endorsers_per_block in - let constants = {constants with endorsers_per_block} in + let initial_endorsers = + Option.unopt ~default:constants.initial_endorsers initial_endorsers + in + let min_proposal_quorum = + Option.unopt ~default:constants.min_proposal_quorum min_proposal_quorum + in + let constants = + { + constants with + endorsers_per_block; + initial_endorsers; + min_proposal_quorum; + } + in (* Check there is at least one roll *) ( try let open Test_utils in @@ -363,7 +397,7 @@ let apply header ?(operations = []) pred = let hash = Block_header.hash header in {hash; header; operations; context} -let bake ?policy ?operation ?operations pred = +let bake ?policy ?timestamp ?operation ?operations pred = let operations = match (operation, operations) with | (Some op, Some ops) -> @@ -375,7 +409,7 @@ let bake ?policy ?operation ?operations pred = | (None, None) -> None in - Forge.forge_header ?policy ?operations pred + Forge.forge_header ?timestamp ?policy ?operations pred >>=? fun header -> Forge.sign_header header >>=? fun header -> apply header ?operations pred diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.mli b/src/proto_alpha/lib_protocol/test/helpers/block.mli index 23b560363085d0ebd35a10170693c9f86e1e7ae8..b1d4ad5bc28eed68fae1ef5bb926ea214b5d8462 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/block.mli @@ -54,6 +54,8 @@ val get_next_baker : t -> (public_key_hash * int * Time.Protocol.t) tzresult Lwt.t +val get_endorsing_power : block -> int tzresult Lwt.t + module Forge : sig val contents : ?proof_of_work_nonce:MBytes.t -> @@ -68,6 +70,7 @@ module Forge : sig The header can then be modified and applied with [apply]. *) val forge_header : ?policy:baker_policy -> + ?timestamp:Timestamp.time -> ?operations:Operation.packed list -> t -> header tzresult Lwt.t @@ -90,6 +93,8 @@ end val genesis : ?with_commitments:bool -> ?endorsers_per_block:int -> + ?initial_endorsers:int -> + ?min_proposal_quorum:int32 -> (Account.t * Tez_repr.tez) list -> block tzresult Lwt.t @@ -113,6 +118,7 @@ val apply : *) val bake : ?policy:baker_policy -> + ?timestamp:Timestamp.time -> ?operation:Operation.packed -> ?operations:Operation.packed list -> t -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index 4cb8647c283b146c08a1304ce38fd56036627583..b1164be156f0f63e7ced8b71acdde308c6f09fe2 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -134,6 +134,38 @@ let get_seed ctxt = Alpha_services.Seed.get rpc_ctxt ctxt let get_constants ctxt = Alpha_services.Constants.all rpc_ctxt ctxt +let get_minimal_valid_time ctxt ~priority ~endorsing_power = + Alpha_services.Delegate.Minimal_valid_time.get + rpc_ctxt + ctxt + priority + endorsing_power + +let get_baking_reward ctxt ~priority ~endorsing_power = + get_constants ctxt + >>=? fun Constants.{parametric = {block_reward; endorsers_per_block; _}; _} -> + let prio_factor_denominator = Int64.(succ (of_int priority)) in + let endo_factor_numerator = + Int64.of_int (8 + (2 * endorsing_power / endorsers_per_block)) + in + let endo_factor_denominator = 10L in + Lwt.return + Test_tez.Tez.( + block_reward *? endo_factor_numerator + >>? fun val1 -> + val1 /? endo_factor_denominator + >>? fun val2 -> val2 /? prio_factor_denominator) + +let get_endorsing_reward ctxt ~priority ~endorsing_power = + get_constants ctxt + >>=? fun Constants.{parametric = {endorsement_reward; _}; _} -> + let open Test_utils in + Test_tez.Tez.( + (endorsement_reward /? Int64.(succ (of_int priority))) + >>?= fun reward_per_slot -> + reward_per_slot *? Int64.of_int endorsing_power + >>?= fun reward -> return reward) + (* Voting *) module Vote = struct @@ -169,6 +201,17 @@ module Vote = struct assert false | Some p -> Lwt.return (Protocol_hash.of_bytes_exn p) + + let get_participation_ema (b : Block.t) = + Environment.Context.get b.context ["votes"; "participation_ema"] + >>= function + | None -> assert false | Some bytes -> return (MBytes.get_int32 bytes 0) + + let set_participation_ema (b : Block.t) ema = + let bytes = MBytes.create 4 in + MBytes.set_int32 bytes 0 ema ; + Environment.Context.set b.context ["votes"; "participation_ema"] bytes + >>= fun context -> Lwt.return {b with context} end module Contract = struct @@ -211,15 +254,26 @@ module Contract = struct (Ok Tez.zero) ) let counter ctxt contract = - Alpha_services.Contract.counter rpc_ctxt ctxt contract + match Contract.is_implicit contract with + | None -> + invalid_arg "Helpers.Context.counter" + | Some mgr -> + Alpha_services.Contract.counter rpc_ctxt ctxt mgr - let manager ctxt contract = - Alpha_services.Contract.manager rpc_ctxt ctxt contract - >>=? fun pkh -> Account.find pkh + let manager _ contract = + match Contract.is_implicit contract with + | None -> + invalid_arg "Helpers.Context.manager" + | Some pkh -> + Account.find pkh let is_manager_key_revealed ctxt contract = - Alpha_services.Contract.manager_key rpc_ctxt ctxt contract - >>=? fun (_, res) -> return (res <> None) + match Contract.is_implicit contract with + | None -> + invalid_arg "Helpers.Context.is_manager_key_revealed" + | Some mgr -> + Alpha_services.Contract.manager_key rpc_ctxt ctxt mgr + >>=? fun res -> return (res <> None) let delegate ctxt contract = Alpha_services.Contract.delegate rpc_ctxt ctxt contract @@ -234,7 +288,7 @@ module Delegate = struct frozen_balance : Tez.t; frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t; staking_balance : Tez.t; - delegated_contracts : Contract_hash.t list; + delegated_contracts : Contract_repr.t list; delegated_balance : Tez.t; deactivated : bool; grace_period : Cycle.t; @@ -243,12 +297,18 @@ module Delegate = struct let info ctxt pkh = Alpha_services.Delegate.info rpc_ctxt ctxt pkh end -let init ?endorsers_per_block ?with_commitments ?(initial_balances = []) n = +let init ?endorsers_per_block ?with_commitments ?(initial_balances = []) + ?initial_endorsers ?min_proposal_quorum n = let accounts = Account.generate_accounts ~initial_balances n in let contracts = List.map (fun (a, _) -> Alpha_context.Contract.implicit_contract Account.(a.pkh)) accounts in - Block.genesis ?endorsers_per_block ?with_commitments accounts + Block.genesis + ?endorsers_per_block + ?with_commitments + ?initial_endorsers + ?min_proposal_quorum + accounts >>=? fun blk -> return (blk, contracts) diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.mli b/src/proto_alpha/lib_protocol/test/helpers/context.mli index 008cb18060a4ed3b787ec2e4530c8fcbca3340c4..c21301efa7e30863bc2129881cbd8408f0605479 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/context.mli @@ -48,6 +48,15 @@ val get_seed : t -> Seed.seed tzresult Lwt.t (** Returns all the constants of the protocol *) val get_constants : t -> Constants.t tzresult Lwt.t +val get_minimal_valid_time : + t -> priority:int -> endorsing_power:int -> Time.t tzresult Lwt.t + +val get_baking_reward : + t -> priority:int -> endorsing_power:int -> Tez.t tzresult Lwt.t + +val get_endorsing_reward : + t -> priority:int -> endorsing_power:int -> Tez.t tzresult Lwt.t + module Vote : sig val get_ballots : t -> Vote.ballots tzresult Lwt.t @@ -62,6 +71,8 @@ module Vote : sig val get_current_quorum : t -> Int32.t tzresult Lwt.t + val get_participation_ema : Block.t -> Int32.t tzresult Lwt.t + val get_listings : t -> (Signature.Public_key_hash.t * int32) list tzresult Lwt.t @@ -70,6 +81,8 @@ module Vote : sig val get_current_proposal : t -> Protocol_hash.t option tzresult Lwt.t val get_protocol : Block.t -> Protocol_hash.t Lwt.t + + val set_participation_ema : Block.t -> int32 -> Block.t Lwt.t end module Contract : sig @@ -81,7 +94,7 @@ module Contract : sig (** Returns the balance of a contract, by default the main balance. If the contract is implicit the frozen balances are available too: - deposit, fees ot rewards. *) + deposit, fees or rewards. *) val balance : ?kind:balance_kind -> t -> Contract.t -> Tez.t tzresult Lwt.t val counter : t -> Contract.t -> Z.t tzresult Lwt.t @@ -101,7 +114,7 @@ module Delegate : sig frozen_balance : Tez.t; frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t; staking_balance : Tez.t; - delegated_contracts : Contract_hash.t list; + delegated_contracts : Contract_repr.t list; delegated_balance : Tez.t; deactivated : bool; grace_period : Cycle.t; @@ -116,5 +129,7 @@ val init : ?endorsers_per_block:int -> ?with_commitments:bool -> ?initial_balances:int64 list -> + ?initial_endorsers:int -> + ?min_proposal_quorum:int32 -> int -> (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/helpers/dune b/src/proto_alpha/lib_protocol/test/helpers/dune index 01eeff6a6af940fa2095c81a22e5e0d6e245c5cc..f4b8af06694910370c8b36090ebf3799bcc6251f 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/dune +++ b/src/proto_alpha/lib_protocol/test/helpers/dune @@ -8,6 +8,7 @@ tezos-protocol-alpha tezos-protocol-alpha-parameters) (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_micheline -open Tezos_stdlib_unix -open Tezos_protocol_alpha -open Tezos_shell_services))) diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index b9eca52a6651841788c2f910d32bad3702e2e870..7529e8975b835ac1d22e11158835fde61e6ce2f3 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -59,7 +59,13 @@ let rpc_ctxt = let begin_construction ?(priority = 0) ?timestamp ?seed_nonce_hash ?(policy = Block.By_priority priority) (predecessor : Block.t) = Block.get_next_baker ~policy predecessor - >>=? fun (delegate, priority, real_timestamp) -> + >>=? fun (delegate, priority, _timestamp) -> + Alpha_services.Delegate.Minimal_valid_time.get + Block.rpc_ctxt + predecessor + priority + 0 + >>=? fun real_timestamp -> Account.find delegate >>=? fun delegate -> let timestamp = Option.unopt ~default:real_timestamp timestamp in diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index 60fdf0ffbd0ad3ea81a651271f647cca5856be98..03a7a9d7e1caf705e6bed05ef1ade091e08ce2b5 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -104,7 +104,7 @@ let combine_operations ?public_key ?counter ~source ctxt let reveal_op = Manager_operation { - source; + source = Signature.Public_key.hash public_key; fee = Tez.zero; counter; operation = Reveal public_key; @@ -159,14 +159,21 @@ let manager_operation ?counter ?(fee = Tez.zero) ?gas_limit ?storage_limit | true -> let op = Manager_operation - {source; fee; counter; operation; gas_limit; storage_limit} + { + source = Signature.Public_key.hash public_key; + fee; + counter; + operation; + gas_limit; + storage_limit; + } in return (Contents_list (Single op)) | false -> let op_reveal = Manager_operation { - source; + source = Signature.Public_key.hash public_key; fee = Tez.zero; counter; operation = Reveal public_key; @@ -177,7 +184,7 @@ let manager_operation ?counter ?(fee = Tez.zero) ?gas_limit ?storage_limit let op = Manager_operation { - source; + source = Signature.Public_key.hash public_key; fee; counter = Z.succ counter; operation; @@ -200,7 +207,7 @@ let revelation ctxt public_key = (Single (Manager_operation { - source; + source = Signature.Public_key.hash public_key; fee = Tez.zero; counter; operation = Reveal public_key; @@ -216,27 +223,14 @@ let originated_contract op = exception Impossible -let origination ?counter ?delegate ?script ?(spendable = true) - ?(delegatable = true) ?(preorigination = None) ?public_key ?manager ?credit - ?fee ?gas_limit ?storage_limit ctxt source = +let origination ?counter ?delegate ~script ?(preorigination = None) ?public_key + ?credit ?fee ?gas_limit ?storage_limit ctxt source = Context.Contract.manager ctxt source >>=? fun account -> - let manager = Option.unopt ~default:account.pkh manager in let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in let default_credit = Option.unopt_exn Impossible default_credit in let credit = Option.unopt ~default:default_credit credit in - let operation = - Origination - { - manager; - delegate; - script; - spendable; - delegatable; - credit; - preorigination; - } - in + let operation = Origination {delegate; script; credit; preorigination} in manager_operation ?counter ?public_key @@ -262,9 +256,10 @@ let miss_signed_endorsement ?level ctxt = let delegate = Account.find_alternate real_delegate_pkh in endorsement ~delegate:delegate.pkh ~level ctxt () -let transaction ?fee ?gas_limit ?storage_limit ?parameters ctxt +let transaction ?fee ?gas_limit ?storage_limit + ?(parameters = Script.unit_parameter) ?(entrypoint = "default") ctxt (src : Contract.t) (dst : Contract.t) (amount : Tez.t) = - let top = Transaction {amount; parameters; destination = dst} in + let top = Transaction {amount; parameters; destination = dst; entrypoint} in manager_operation ?fee ?gas_limit ?storage_limit ~source:src ctxt top >>=? fun sop -> Context.Contract.manager ctxt src @@ -343,3 +338,32 @@ let ballot ctxt (pkh : Contract.t) proposal ballot = let op = Ballot {source; period; proposal; ballot} in Account.find source >>=? fun account -> return (sign account.sk ctxt (Contents_list (Single op))) + +let dummy_script = + let open Micheline in + Script. + { + code = + lazy_expr + (strip_locations + (Seq + ( 0, + [ Prim (0, K_parameter, [Prim (0, T_unit, [], [])], []); + Prim (0, K_storage, [Prim (0, T_unit, [], [])], []); + Prim + ( 0, + K_code, + [ Seq + ( 0, + [ Prim (0, I_CDR, [], []); + Prim + ( 0, + I_NIL, + [Prim (0, T_operation, [], [])], + [] ); + Prim (0, I_PAIR, [], []) ] ) ], + [] ) ] ))); + storage = lazy_expr (strip_locations (Prim (0, D_Unit, [], []))); + } + +let dummy_script_cost = Test_tez.Tez.of_mutez_exn 38_000L diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index 429e32380563eb1d0dc0a4d2ec4989b247f8df49..7c6becf445237d11e10fa2005053c330b1e34371 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -44,6 +44,7 @@ val transaction : ?gas_limit:Z.t -> ?storage_limit:Z.t -> ?parameters:Script.lazy_expr -> + ?entrypoint:string -> Context.t -> Contract.t -> Contract.t -> @@ -62,12 +63,9 @@ val revelation : Context.t -> public_key -> Operation.packed tzresult Lwt.t val origination : ?counter:Z.t -> ?delegate:public_key_hash -> - ?script:Script.t -> - ?spendable:bool -> - ?delegatable:bool -> + script:Script.t -> ?preorigination:Contract.contract option -> ?public_key:public_key -> - ?manager:public_key_hash -> ?credit:Tez.tez -> ?fee:Tez.tez -> ?gas_limit:Z.t -> @@ -122,3 +120,7 @@ val ballot : Protocol_hash.t -> Vote.ballot -> Operation.packed tzresult Lwt.t + +val dummy_script : Script.t + +val dummy_script_cost : Test_tez.Tez.t diff --git a/src/proto_alpha/lib_protocol/test/origination.ml b/src/proto_alpha/lib_protocol/test/origination.ml index 57b24c993c6936d8d32640be52a3fb5eda601acd..0fca2df85eee2a98bc04d51e2ddb41837baece12 100644 --- a/src/proto_alpha/lib_protocol/test/origination.ml +++ b/src/proto_alpha/lib_protocol/test/origination.ml @@ -35,14 +35,13 @@ let ten_tez = Tez.of_int 10 send to this originated contract; spendable default is set to true meaning that this contract is spendable; delegatable default is set to true meaning that this contract is able to delegate. *) -let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) ?spendable - ?delegatable () = +let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) () = Context.init 1 >>=? fun (b, contracts) -> let source = List.hd contracts in Context.Contract.balance (B b) source >>=? fun source_balance -> - Op.origination (B b) source ~fee ~credit ?spendable ?delegatable + Op.origination (B b) source ~fee ~credit ~script:Op.dummy_script >>=? fun (operation, originated) -> Block.bake ~operation b >>=? fun b -> @@ -56,7 +55,8 @@ let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) ?spendable Lwt.return ( Tez.( +? ) credit block_security_deposit >>? Tez.( +? ) fee - >>? Tez.( +? ) origination_burn ) + >>? Tez.( +? ) origination_burn + >>? Tez.( +? ) Op.dummy_script_cost ) >>=? fun total_fee -> Assert.balance_was_debited ~loc:__LOC__ (B b) source source_balance total_fee >>=? fun () -> @@ -79,14 +79,14 @@ let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) ?spendable originated operation valid. - the source contract has payed all the fees - the originated has been credited correctly *) -let test_origination_balances ~loc ?(fee = Tez.zero) ?(credit = Tez.zero) - ?delegatable () = +let test_origination_balances ~loc:_ ?(fee = Tez.zero) ?(credit = Tez.zero) () + = Context.init 1 >>=? fun (b, contracts) -> let contract = List.hd contracts in Context.Contract.balance (B b) contract >>=? fun balance -> - Op.origination (B b) contract ~fee ~credit ?delegatable + Op.origination (B b) contract ~fee ~credit ~script:Op.dummy_script >>=? fun (operation, new_contract) -> (* The possible fees are: a given credit, an origination burn fee (constants_repr.default.origination_burn = 257 mtez), @@ -104,29 +104,17 @@ let test_origination_balances ~loc ?(fee = Tez.zero) ?(credit = Tez.zero) Lwt.return ( Tez.( +? ) credit block_security_deposit >>? Tez.( +? ) fee - >>? Tez.( +? ) origination_burn ) + >>? Tez.( +? ) origination_burn + >>? Tez.( +? ) Op.dummy_script_cost ) >>=? fun total_fee -> Block.bake ~operation b >>=? fun b -> (* check that after the block has been baked the source contract was debited all the fees *) - Assert.balance_was_debited ~loc (B b) contract balance total_fee + Assert.balance_was_debited ~loc:__LOC__ (B b) contract balance total_fee >>=? fun _ -> (* check the balance of the originate contract is equal to credit *) - Assert.balance_is ~loc (B b) new_contract credit - -(** [transfer_and_check_balances b source dest amount] takes a block, - a source contract, a destination and the amount that one wants to send - (with no fee) and check the source and destination balances. *) -let transfer_and_check_balances b source dest amount = - Context.Contract.balance (B b) source - >>=? fun balance -> - Op.transaction (B b) source dest amount - >>=? fun operation -> - Block.bake ~operation b - >>=? fun b -> - Assert.balance_was_debited ~loc:__LOC__ (B b) source balance amount - >>=? fun _ -> return b + Assert.balance_is ~loc:__LOC__ (B b) new_contract credit (******************************************************) (** Tests *) @@ -154,26 +142,7 @@ let balances_credit () = let balances_credit_fee () = test_origination_balances ~loc:__LOC__ ~credit:(Tez.of_int 2) ~fee:ten_tez () -let balances_undelegatable () = - test_origination_balances ~loc:__LOC__ ~delegatable:false () - -(*******************) -(** create an originate contract with a credit, then use this contract to - transfer some tez back into the source contract, change the delegate - contract to the endorser account *) - -(*******************) - -let regular () = - register_origination ~credit:ten_tez () - >>=? fun (b, contract, new_contract) -> - transfer_and_check_balances b new_contract contract Tez.one_cent - >>=? fun _ -> - (* Delegatable *) - Context.get_endorser (B b) - >>=? fun (account, _slots) -> - Op.delegation (B b) new_contract (Some account) - >>=? fun operation -> Block.bake ~operation b >>=? fun _ -> return_unit +let balances_undelegatable () = test_origination_balances ~loc:__LOC__ () (*******************) (** ask source contract to pay a fee when originating a contract *) @@ -182,9 +151,7 @@ let regular () = let pay_fee () = register_origination ~credit:(Tez.of_int 2) ~fee:ten_tez () - >>=? fun (b, contract, new_contract) -> - transfer_and_check_balances b new_contract contract (Tez.of_int 2) - >>=? fun _ -> return_unit + >>=? fun (_b, _contract, _new_contract) -> return_unit (******************************************************) (** Errors *) @@ -192,184 +159,8 @@ let pay_fee () = (******************************************************) (*******************) -(** Originating an unspendable contract w/o code reises an error. *) - -(*******************) - -let unspendable () = - Context.init 1 - >>=? fun (b, contracts) -> - Incremental.begin_construction b - >>=? fun i -> - let source = List.hd contracts in - Op.origination (I i) source ~fee:Tez.zero ~credit:Tez.one ~spendable:false - >>=? fun (operation, _contract) -> - Incremental.add_operation i operation - >>= fun res -> - let cannot_originate = function - | Apply.Cannot_originate_non_spendable_account -> - true - | _ -> - false - in - Assert.proto_error ~loc:__LOC__ res cannot_originate - -(*******************) -(** The originate contract is marked as undelegatable. Then do the delegation - for this contract, it will raise an error *) - -(*******************) - -let undelegatable fee () = - register_origination ~delegatable:false () - >>=? fun (b, _, new_contract) -> - Context.get_endorser (B b) - >>=? fun (account, _slots) -> - Incremental.begin_construction b - >>=? fun i -> - Context.Contract.balance (I i) new_contract - >>=? fun balance -> - Context.Contract.delegate_opt (I i) new_contract - >>=? fun delegate_opt -> - assert (delegate_opt = None) ; - Op.delegation ~fee (I i) new_contract (Some account) - >>=? fun operation -> - if fee > balance then - (* fees cannot be paid *) - Incremental.add_operation i operation - >>= fun res -> - let not_enough_money = function - | Contract_storage.Balance_too_low _ -> - true - | _ -> - false - in - Assert.proto_error ~loc:__LOC__ res not_enough_money - else - (* delegation is processed ; but delegate does not change *) - let expect_failure = function - | Environment.Ecoproto_error - (Delegate_storage.Non_delegatable_contract _) - :: _ -> - return_unit - | _ -> - failwith "The contract is not delegatable, it fails!" - in - Incremental.add_operation ~expect_failure i operation - >>=? fun i -> - (* still no delegate *) - Context.Contract.delegate_opt (I i) new_contract - >>=? fun new_delegate_opt -> - assert (new_delegate_opt = None) ; - (* new contract loses the fee *) - Assert.balance_was_debited ~loc:__LOC__ (I i) new_contract balance fee - -(*******************) -(** the credit is zero tez *) - -(*******************) - -let credit fee () = - register_origination ~credit:Tez.zero () - >>=? fun (b, contract, new_contract) -> - Incremental.begin_construction b - >>=? fun i -> - Context.Contract.balance (I i) contract - >>=? fun balance -> - Context.Contract.balance (I i) new_contract - >>=? fun new_balance -> - (* the source contract does not have enough tez to transfer *) - Op.transaction ~fee (I i) new_contract contract Tez.one_cent - >>=? fun operation -> - if fee > new_balance then - Incremental.add_operation i operation - >>= fun res -> - let not_enough_money = function - | Contract_storage.Balance_too_low _ -> - true - | _ -> - false - in - Assert.proto_error ~loc:__LOC__ res not_enough_money - else - let not_enough_money = function - | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ -> - return_unit - | _ -> - failwith "The contract does not have enough money, it fails!" - in - Incremental.add_operation ~expect_failure:not_enough_money i operation - >>=? fun i -> - (* new contract loses the fee *) - Assert.balance_was_debited ~loc:__LOC__ (I i) new_contract new_balance fee - >>=? fun () -> - (* contract is not credited *) - Assert.balance_was_credited ~loc:__LOC__ (I i) contract balance Tez.zero - -(*******************) -(** same as register_origination but for an incremental *) - -(*******************) - -let register_origination_inc ~credit () = - Context.init 1 - >>=? fun (b, contracts) -> - let source_contract = List.hd contracts in - Incremental.begin_construction b - >>=? fun inc -> - Context.get_constants (B b) - >>=? fun {parametric = {origination_size; _}; _} -> - Op.origination - (I inc) - ~storage_limit:(Z.of_int origination_size) - ~credit - source_contract - >>=? fun (operation, new_contract) -> - Incremental.add_operation inc operation - >>=? fun inc -> return (inc, source_contract, new_contract) - -(*******************) -(** Using the originate contract to create another - originate contract *) - -(*******************) - (** create an originate contract where the contract does not have enough tez to pay for the fee *) -let origination_contract_from_origination_contract_not_enough_fund fee () = - let amount = Tez.one in - register_origination_inc ~credit:amount () - >>=? fun (inc, _, contract) -> - (* contract's balance is not enough to afford origination burn *) - Op.origination ~fee (I inc) ~credit:amount contract - >>=? fun (operation, orig_contract) -> - let expect_failure = function - | Environment.Ecoproto_error Alpha_context.Fees.Cannot_pay_storage_fee :: _ - -> - return_unit - | e -> - failwith - "The contract has not enough funds, it fails! %a" - Error_monad.pp_print_error - e - in - Incremental.add_operation ~expect_failure inc operation - >>=? fun inc -> - Context.Contract.balance (I inc) contract - >>=? fun balance_aft -> - (* contract was debited of [fee] but not of origination burn *) - Assert.balance_was_debited ~loc:__LOC__ (I inc) contract balance_aft fee - >>=? fun () -> - (* orig_contract does not exist *) - Context.Contract.balance (I inc) orig_contract - >>= fun res -> - Assert.error ~loc:__LOC__ res (function - | RPC_context.Not_found _ -> - true - | _ -> - false) - -(*******************) (*******************) @@ -393,7 +184,12 @@ let not_tez_in_contract_to_pay_fee () = >>=? fun _ -> (* use this source contract to create an originate contract where it requires to pay a fee and add an amount of credit into this new contract *) - Op.origination (I inc) ~fee:ten_tez ~credit:Tez.one contract_1 + Op.origination + (I inc) + ~fee:ten_tez + ~credit:Tez.one + contract_1 + ~script:Op.dummy_script >>=? fun (op, _) -> Incremental.add_operation inc op >>= fun inc -> @@ -418,43 +214,16 @@ let register_contract_get_endorser () = >>=? fun (account_endorser, _slots) -> return (inc, contract, account_endorser) -let set_manager () = - register_contract_get_endorser () - >>=? fun (inc, contract, account_endorser) -> - Op.origination ~manager:account_endorser (I inc) ~credit:Tez.one contract - >>=? fun (op, orig_contract) -> - Incremental.add_operation inc op - >>=? fun inc -> - Incremental.finalize_block inc - >>=? fun b -> - (* the manager is indeed the endorser *) - Context.Contract.manager (B b) orig_contract - >>=? fun manager -> - Assert.equal_pkh ~loc:__LOC__ manager.pkh account_endorser - -let set_delegate () = - register_contract_get_endorser () - >>=? fun (inc, contract, account_endorser) -> - Op.origination ~delegate:account_endorser (I inc) ~credit:Tez.one contract - >>=? fun (op, orig_contract) -> - Incremental.add_operation inc op - >>=? fun inc -> - Incremental.finalize_block inc - >>=? fun b -> - (* the delegate is indeed the endorser *) - Context.Contract.delegate (B b) orig_contract - >>=? fun delegate -> Assert.equal_pkh ~loc:__LOC__ delegate account_endorser - (*******************) (** create multiple originated contracts and ask contract to pay the fee *) (*******************) -let n_originations n ?credit ?fee ?spendable ?delegatable () = +let n_originations n ?credit ?fee () = fold_left_s (fun new_contracts _ -> - register_origination ?fee ?credit ?spendable ?delegatable () + register_origination ?fee ?credit () >>=? fun (_b, _source, new_contract) -> let contracts = new_contract :: new_contracts in return contracts) @@ -477,9 +246,9 @@ let counter () = let contract = List.hd contracts in Incremental.begin_construction b >>=? fun inc -> - Op.origination (I inc) ~credit:Tez.one contract + Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script >>=? fun (op1, _) -> - Op.origination (I inc) ~credit:Tez.one contract + Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script >>=? fun (op2, _) -> Incremental.add_operation inc op1 >>=? fun inc -> @@ -491,25 +260,6 @@ let counter () = | _ -> false) -(*******************) -(* create an originate contract from an originate contract *) -(*******************) - -let origination_contract_from_origination_contract () = - register_origination_inc ~credit:ten_tez () - >>=? fun (inc, _source_contract, new_contract) -> - let credit = Tez.one in - Op.origination (I inc) ~credit new_contract - >>=? fun (op2, orig_contract) -> - Incremental.add_operation inc op2 - >>=? fun inc -> - Incremental.finalize_block inc - >>=? fun b -> - (* operation has been processed: - originated contract exists and has been credited with the right amount *) - Context.Contract.balance (B b) orig_contract - >>=? fun credit0 -> Assert.equal_tez ~loc:__LOC__ credit0 credit - (******************************************************) let tests = @@ -517,25 +267,10 @@ let tests = Test.tztest "balances_credit" `Quick balances_credit; Test.tztest "balances_credit_fee" `Quick balances_credit_fee; Test.tztest "balances_undelegatable" `Quick balances_undelegatable; - Test.tztest "regular" `Quick regular; Test.tztest "pay_fee" `Quick pay_fee; - Test.tztest "unspendable" `Quick unspendable; - Test.tztest "undelegatable (no fee)" `Quick (undelegatable Tez.zero); - Test.tztest "undelegatable (with fee)" `Quick (undelegatable Tez.one); - Test.tztest "credit" `Quick (credit Tez.one); - Test.tztest - "create origination from origination not enough fund" - `Quick - (origination_contract_from_origination_contract_not_enough_fund Tez.zero); Test.tztest "not enough tez in contract to pay fee" `Quick not_tez_in_contract_to_pay_fee; - Test.tztest "set manager" `Quick set_manager; - Test.tztest "set delegate" `Quick set_delegate; Test.tztest "multiple originations" `Quick multiple_originations; - Test.tztest "counter" `Quick counter; - Test.tztest - "create origination from origination" - `Quick - origination_contract_from_origination_contract ] + Test.tztest "counter" `Quick counter ] diff --git a/src/proto_alpha/lib_protocol/test/qty.ml b/src/proto_alpha/lib_protocol/test/qty.ml index 6fe42741ad8f9b42ce7be8d9b0512ca5c613c57c..429b18652c74df5ae009c1d9ea4574c5fa389b3d 100644 --- a/src/proto_alpha/lib_protocol/test/qty.ml +++ b/src/proto_alpha/lib_protocol/test/qty.ml @@ -25,7 +25,7 @@ open Protocol -let known_ok_tez_litterals = +let known_ok_tez_literals = [ (0L, "0"); (10L, "0.00001"); (100L, "0.0001"); @@ -48,7 +48,7 @@ let known_ok_tez_litterals = (123_123_123_123_123_123L, "123123123123.123123"); (999_999_999_999_999_999L, "999999999999.999999") ] -let known_bad_tez_litterals = +let known_bad_tez_literals = [ "10000."; "100,."; "100,"; @@ -80,7 +80,7 @@ let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg let is_some ?(msg = "") x = if x = None then fail "Some _" "None" msg -let test_known_tez_litterals () = +let test_known_tez_literals () = List.iter (fun (v, s) -> let vv = Tez_repr.of_mutez v in @@ -108,15 +108,15 @@ let test_known_tez_litterals () = equal ~prn:Tez_repr.to_string vv vs ; equal ~prn:Tez_repr.to_string vv vs' ; equal ~prn:(fun s -> s) (Tez_repr.to_string vv) s) - known_ok_tez_litterals ; + known_ok_tez_literals ; List.iter (fun s -> let vs = Tez_repr.of_string s in is_none ~msg:("Unexpected successful parsing of " ^ s) vs) - known_bad_tez_litterals ; + known_bad_tez_literals ; return_unit -let test_random_tez_litterals () = +let test_random_tez_literals () = for _ = 0 to 100_000 do let v = Random.int64 12L in let vv = Tez_repr.of_mutez v in @@ -145,8 +145,8 @@ let test_random_tez_litterals () = return_unit let tests = - [ ("tez-litterals", fun _ -> test_known_tez_litterals ()); - ("rnd-tez-litterals", fun _ -> test_random_tez_litterals ()) ] + [ ("tez-literals", fun _ -> test_known_tez_literals ()); + ("rnd-tez-literals", fun _ -> test_random_tez_literals ()) ] let wrap (n, f) = Alcotest_lwt.test_case n `Quick (fun _ () -> diff --git a/src/proto_alpha/lib_protocol/test/rolls.ml b/src/proto_alpha/lib_protocol/test/rolls.ml index 3fbac6f9163f37c955fb6b63b66bf14418f6323b..78d73c561a9b6bb29b45987558708fc193647682 100644 --- a/src/proto_alpha/lib_protocol/test/rolls.ml +++ b/src/proto_alpha/lib_protocol/test/rolls.ml @@ -59,6 +59,7 @@ let check_rolls b (account : Account.t) = Raw_context.prepare b.context ~level:b.header.shell.level + ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness >>= wrap @@ -74,6 +75,7 @@ let check_no_rolls (b : Block.t) (account : Account.t) = Raw_context.prepare b.context ~level:b.header.shell.level + ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness >>= wrap diff --git a/src/proto_alpha/lib_protocol/test/seed.ml b/src/proto_alpha/lib_protocol/test/seed.ml index b528ccdf91832b125f86520b10f62d2e04198361..66248269347b04785a460b6dbaca2dda88687617 100644 --- a/src/proto_alpha/lib_protocol/test/seed.ml +++ b/src/proto_alpha/lib_protocol/test/seed.ml @@ -57,6 +57,12 @@ let no_commitment () = | _ -> false) +let baking_reward ctxt (b : Block.t) = + let priority = b.header.protocol_data.contents.priority in + Block.get_endorsing_power b + >>=? fun endorsing_power -> + Context.get_baking_reward ctxt ~priority ~endorsing_power + (** Choose a baker, denote it by id. In the first cycle, make id bake only once. Test that: - after id bakes with a commitment the bond is frozen and the reward allocated @@ -74,7 +80,6 @@ let revelation_early_wrong_right_twice () = Context.get_constants (B b) >>=? fun csts -> let bond = csts.parametric.block_security_deposit in - let reward = csts.parametric.block_reward in let tip = csts.parametric.seed_nonce_revelation_tip in let blocks_per_commitment = Int32.to_int csts.parametric.blocks_per_commitment @@ -101,6 +106,8 @@ let revelation_early_wrong_right_twice () = >>=? fun level_commitment -> Context.get_seed_nonce_hash (B b) >>=? fun committed_hash -> + baking_reward (B b) b + >>=? fun reward -> (* test that the bond was frozen and the reward allocated *) balance_was_debited ~loc:__LOC__ (B b) id bal_main bond >>=? fun () -> @@ -151,6 +158,8 @@ let revelation_early_wrong_right_twice () = (* bake the operation in a block *) Block.bake ~policy ~operation b >>=? fun b -> + baking_reward (B b) b + >>=? fun baker_reward -> (* test that the baker gets the tip reward *) balance_was_debited ~loc:__LOC__ (B b) baker ~kind:Main baker_bal_main bond >>=? fun () -> @@ -162,7 +171,7 @@ let revelation_early_wrong_right_twice () = baker_bal_deposit bond >>=? fun () -> - Lwt.return @@ Tez.( +? ) reward tip + Lwt.return @@ Tez.( +? ) baker_reward tip >>=? fun expected_rewards -> balance_was_credited ~loc:__LOC__ @@ -209,7 +218,8 @@ let revelation_missing_and_late () = >>=? fun (b, _) -> get_constants (B b) >>=? fun csts -> - let reward = csts.parametric.block_reward in + baking_reward (B b) b + >>=? fun reward -> let blocks_per_commitment = Int32.to_int csts.parametric.blocks_per_commitment in diff --git a/src/proto_alpha/lib_protocol/test/transfer.ml b/src/proto_alpha/lib_protocol/test/transfer.ml index 5d90ba5615213e57f9b93ff08d51010a72066a80..4ade36bc8135b777f9eb1ea7f741ebb9f1a7c538 100644 --- a/src/proto_alpha/lib_protocol/test/transfer.ml +++ b/src/proto_alpha/lib_protocol/test/transfer.ml @@ -183,40 +183,10 @@ let transfer_zero_tez () = Tez.zero (********************) -(** Transfer zero tez from an originated/implicit contract *) +(** Transfer zero tez from an implicit contract *) (********************) -let transfer_zero_originated () = - register_two_contracts () - >>=? fun (b, contract_1, contract_2) -> - Incremental.begin_construction b - >>=? fun i -> - (* originated the first contract *) - Op.origination (I i) contract_1 - >>=? fun (operation, orig_contract_1) -> - Incremental.add_operation i operation - >>=? fun i -> - Context.Contract.balance (I i) orig_contract_1 - >>=? fun balance_1 -> - (* transfer all the tez inside the originated contract *) - transfer_and_check_balances - ~loc:__LOC__ - i - orig_contract_1 - contract_2 - balance_1 - >>=? fun (i, _) -> - Op.transaction (I i) orig_contract_1 contract_2 Tez.zero - >>=? fun op -> - Incremental.add_operation i op - >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Contract_storage.Empty_transaction _ -> - true - | _ -> - false) - let transfer_zero_implicit () = Context.init 1 >>=? fun (b, contracts) -> @@ -249,7 +219,7 @@ let transfer_to_originate_with_fee () = two_nth_of_balance b contract 10L >>=? fun fee -> (* originated contract, paying a fee to originated this contract *) - Op.origination (I b) ~fee:ten_tez contract + Op.origination (I b) ~fee:ten_tez contract ~script:Op.dummy_script >>=? fun (operation, new_contract) -> Incremental.add_operation b operation >>=? fun b -> @@ -395,7 +365,7 @@ let transfer_from_implicit_to_originated_contract () = amount1 >>=? fun (b, _) -> (* originated contract *) - Op.origination (I b) contract + Op.origination (I b) contract ~script:Op.dummy_script >>=? fun (operation, new_contract) -> Incremental.add_operation b operation >>=? fun b -> @@ -405,57 +375,6 @@ let transfer_from_implicit_to_originated_contract () = transfer_and_check_balances ~loc:__LOC__ b src new_contract amount2 >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit -(** Originted to originted *) - -let transfer_from_originated_to_originated () = - register_two_contracts () - >>=? fun (b, contract_1, contract_2) -> - Incremental.begin_construction b - >>=? fun b -> - (* originated contract 1 *) - Op.origination (I b) contract_1 - >>=? fun (operation, orig_contract_1) -> - Incremental.add_operation b operation - >>=? fun b -> - (* originated contract 2 *) - Op.origination (I b) contract_2 - >>=? fun (operation, orig_contract_2) -> - Incremental.add_operation b operation - >>=? fun b -> - (* transfer from originated contract 1 to originated contract 2 *) - transfer_and_check_balances - ~loc:__LOC__ - b - orig_contract_1 - orig_contract_2 - Alpha_context.Tez.one - >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit - -(** Originted to impicit *) - -let transfer_from_originated_to_implicit () = - Context.init 1 - >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let account = Account.new_account () in - let src = Contract.implicit_contract account.pkh in - Incremental.begin_construction b - >>=? fun b -> - (* originated contract 1*) - Op.origination (I b) contract_1 - >>=? fun (operation, new_contract) -> - Incremental.add_operation b operation - >>=? fun b -> - (* transfer from originated contract to implicit contract *) - transfer_and_check_balances - ~with_burn:true - ~loc:__LOC__ - b - new_contract - src - Alpha_context.Tez.one_mutez - >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit - (********************) (** Slow tests case *) @@ -768,10 +687,6 @@ let tests = block_with_a_single_transfer_with_fee; (* transfer zero tez *) Test.tztest "single transfer zero tez" `Quick transfer_zero_tez; - Test.tztest - "transfer zero tez from originated contract" - `Quick - transfer_zero_originated; Test.tztest "transfer zero tez from implicit contract" `Quick @@ -799,14 +714,6 @@ let tests = "transfer from an implicit to an originated contract" `Quick transfer_from_implicit_to_originated_contract; - Test.tztest - "transfer from an originated to an originated contract" - `Quick - transfer_from_originated_to_originated; - Test.tztest - "transfer from an originated to an implicit contract" - `Quick - transfer_from_originated_to_implicit; (* Slow tests *) Test.tztest "block with multiple transfers" diff --git a/src/proto_alpha/lib_protocol/test/voting.ml b/src/proto_alpha/lib_protocol/test/voting.ml index 13557b5f12b13870c556413130d3e3ce765845ac..d6f881b0e9847fa742ba539909d7f07ef8fe06bf 100644 --- a/src/proto_alpha/lib_protocol/test/voting.ml +++ b/src/proto_alpha/lib_protocol/test/voting.ml @@ -41,27 +41,40 @@ let ballots_pp ppf v = v.nay v.pass) -(* constantans and ratios used in voting: +(* constants and ratios used in voting: percent_mul denotes the percent multiplier - initial_qr is 8000 that is, 8/10 * percent_mul - the quorum ratio qr_num / den = 8 / 10 - the participation ration pr_num / den = 2 / 10 - note: we use the same denominator for both quorum and participation rate. + initial_participation is 7000 that is, 7/10 * percent_mul + the participation EMA ratio pr_ema_weight / den = 7 / 10 + the participation ratio pr_num / den = 2 / 10 + note: we use the same denominator for both participation EMA and participation rate. supermajority rate is s_num / s_den = 8 / 10 *) let percent_mul = 100_00 -let initial_qr = 8 * percent_mul / 10 +let initial_participation_num = 7 -let qr_num = 8 +let initial_participation = initial_participation_num * percent_mul / 10 + +let pr_ema_weight = 8 let den = 10 -let pr_num = den - qr_num +let pr_num = den - pr_ema_weight let s_num = 8 let s_den = 10 +let qr_min_num = 2 + +let qr_max_num = 7 + +let expected_qr_num = + Float.( + of_int qr_min_num + +. of_int initial_participation_num + *. (of_int qr_max_num -. of_int qr_min_num) + /. of_int den) + (* Protocol_hash.zero is "PrihK96nBAFSxVL1GLJTVhu9YnzkMFiBeuJRPA8NwuZVZCE1L6i" *) let protos = Array.map @@ -113,7 +126,8 @@ let get_rolls b delegates loc = delegates let test_successful_vote num_delegates () = - Context.init num_delegates + let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b, _) -> Context.get_constants (B b) >>=? fun {parametric = {blocks_per_voting_period; _}; _} -> @@ -155,10 +169,10 @@ let test_successful_vote num_delegates () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - (* quorum starts at initial_qr *) - Context.Vote.get_current_quorum (B b) + (* participation EMA starts at initial_participation *) + Context.Vote.get_participation_ema b >>=? fun v -> - Assert.equal_int ~loc:__LOC__ initial_qr (Int32.to_int v) + Assert.equal_int ~loc:__LOC__ initial_participation (Int32.to_int v) >>=? fun () -> (* listings must be populated in proposal period *) Context.Vote.get_listings (B b) @@ -475,7 +489,7 @@ let test_successful_vote num_delegates () = (* given a list of active delegates, return the first k active delegates with which one can have quorum, that is: - their roll sum divided by the total roll sum is bigger than qr_num/qr_den *) + their roll sum divided by the total roll sum is bigger than pr_ema_weight/den *) let get_smallest_prefix_voters_for_quorum active_delegates active_rolls = fold_left_s (fun v acc -> return Int32.(add v acc)) 0l active_rolls >>=? fun active_rolls_sum -> @@ -484,7 +498,10 @@ let get_smallest_prefix_voters_for_quorum active_delegates active_rolls = | ([], []) -> selected | (del :: delegates, del_rolls :: rolls) -> - if den * sum < qr_num * Int32.to_int active_rolls_sum then + if + den * sum + < Float.to_int (expected_qr_num *. Int32.to_float active_rolls_sum) + then loop delegates rolls (sum + Int32.to_int del_rolls) (del :: selected) else selected | (_, _) -> @@ -492,12 +509,12 @@ let get_smallest_prefix_voters_for_quorum active_delegates active_rolls = in return (loop active_delegates active_rolls 0 []) -let get_expected_quorum ?(min_participation = 0) rolls voter_rolls old_quorum = - (* formula to compute the updated quorum as in the whitepaper *) - let get_updated_quorum old_quorum participation = - (* if not enough participation, don't update the quorum *) - if participation < min_participation then Int32.to_int old_quorum - else ((qr_num * Int32.to_int old_quorum) + (pr_num * participation)) / den +let get_expected_participation_ema rolls voter_rolls old_participation_ema = + (* formula to compute the updated participation_ema *) + let get_updated_participation_ema old_participation_ema participation = + ( (pr_ema_weight * Int32.to_int old_participation_ema) + + (pr_num * participation) ) + / den in fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls >>=? fun rolls_sum -> @@ -506,12 +523,13 @@ let get_expected_quorum ?(min_participation = 0) rolls voter_rolls old_quorum = let participation = Int32.to_int voter_rolls_sum * percent_mul / Int32.to_int rolls_sum in - return (get_updated_quorum old_quorum participation) + return (get_updated_participation_ema old_participation_ema participation) -(* if not enough quorum -- get_updated_quorum < qr_num/qr_den -- in testing vote, +(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in testing vote, go back to proposal period *) let test_not_enough_quorum_in_testing_vote num_delegates () = - Context.init num_delegates + let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b, delegates) -> Context.get_constants (B b) >>=? fun {parametric = {blocks_per_voting_period; _}; _} -> @@ -541,15 +559,15 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - Context.Vote.get_current_quorum (B b) - >>=? fun initial_quorum -> + Context.Vote.get_participation_ema b + >>=? fun initial_participation_ema -> (* beginning of testing_vote period, denoted by _p2; take a snapshot of the active delegates and their rolls from listings *) get_delegates_and_rolls_from_listings b >>=? fun (delegates_p2, rolls_p2) -> get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2 >>=? fun voters -> - (* take the first voter out so there cannot be quorum *) + (* take the first two voters out so there cannot be quorum *) let voters_without_quorum = List.tl voters in get_rolls b voters_without_quorum __LOC__ >>=? fun voters_rolls_in_testing_vote -> @@ -572,19 +590,26 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - (* check quorum update *) - get_expected_quorum rolls_p2 voters_rolls_in_testing_vote initial_quorum - >>=? fun expected_quorum -> - Context.Vote.get_current_quorum (B b) - >>=? fun new_quorum -> - (* assert the formula to calculate quorum is correct *) - Assert.equal_int ~loc:__LOC__ expected_quorum (Int32.to_int new_quorum) + (* check participation_ema update *) + get_expected_participation_ema + rolls_p2 + voters_rolls_in_testing_vote + initial_participation_ema + >>=? fun expected_participation_ema -> + Context.Vote.get_participation_ema b + >>=? fun new_participation_ema -> + (* assert the formula to calculate participation_ema is correct *) + Assert.equal_int + ~loc:__LOC__ + expected_participation_ema + (Int32.to_int new_participation_ema) >>=? fun () -> return_unit -(* if not enough quorum -- get_updated_quorum < qr_num/qr_den -- in promotion vote, +(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in promotion vote, go back to proposal period *) let test_not_enough_quorum_in_promotion_vote num_delegates () = - Context.init num_delegates + let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b, delegates) -> Context.get_constants (B b) >>=? fun {parametric = {blocks_per_voting_period; _}; _} -> @@ -646,8 +671,8 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - Context.Vote.get_current_quorum (B b) - >>=? fun initial_quorum -> + Context.Vote.get_participation_ema b + >>=? fun initial_participation_ema -> (* beginning of promotion period, denoted by _p4; take a snapshot of the active delegates and their rolls from listings *) get_delegates_and_rolls_from_listings b @@ -669,12 +694,15 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = (* skip to end of promotion_vote period *) Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b >>=? fun b -> - get_expected_quorum rolls_p4 voter_rolls initial_quorum - >>=? fun expected_quorum -> - Context.Vote.get_current_quorum (B b) - >>=? fun new_quorum -> - (* assert the formula to calculate quorum is correct *) - Assert.equal_int ~loc:__LOC__ expected_quorum (Int32.to_int new_quorum) + get_expected_participation_ema rolls_p4 voter_rolls initial_participation_ema + >>=? fun expected_participation_ema -> + Context.Vote.get_participation_ema b + >>=? fun new_participation_ema -> + (* assert the formula to calculate participation_ema is correct *) + Assert.equal_int + ~loc:__LOC__ + expected_participation_ema + (Int32.to_int new_participation_ema) >>=? fun () -> (* we move back to the proposal period because not enough quorum *) Context.Vote.get_current_period_kind (B b) @@ -731,7 +759,8 @@ let test_multiple_identical_proposals_count_as_one () = (* assumes the initial balance of allocated by Context.init is at least 4 time the value of the tokens_per_roll constant *) let test_supermajority_in_proposal there_is_a_winner () = - Context.init ~initial_balances:[1L; 1L; 1L] 10 + let min_proposal_quorum = 0l in + Context.init ~min_proposal_quorum ~initial_balances:[1L; 1L; 1L] 10 >>=? fun (b, delegates) -> Context.get_constants (B b) >>=? fun { parametric = @@ -801,8 +830,80 @@ let test_supermajority_in_proposal there_is_a_winner () = failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> return_unit +let test_quorum_in_proposal has_quorum () = + let total_tokens = 32_000_000_000_000L in + let half_tokens = Int64.div total_tokens 2L in + Context.init ~initial_balances:[1L; half_tokens; half_tokens] 3 + >>=? fun (b, delegates) -> + Context.get_constants (B b) + >>=? fun { parametric = + { blocks_per_cycle; + blocks_per_voting_period; + min_proposal_quorum; + _ }; + _ } -> + let del1 = List.nth delegates 0 in + let del2 = List.nth delegates 1 in + map_s (fun del -> Context.Contract.pkh del) [del1; del2] + >>=? fun pkhs -> + let policy = Block.Excluding pkhs in + let quorum = + if has_quorum then Int64.of_int32 min_proposal_quorum + else Int64.(sub (of_int32 min_proposal_quorum) 10L) + in + let bal = + Int64.(div (mul total_tokens quorum) 100_00L) |> Test_tez.Tez.of_mutez_exn + in + Op.transaction (B b) del2 del1 bal + >>=? fun op2 -> + Block.bake ~policy ~operations:[op2] b + >>=? fun b -> + (* we let one voting period pass; we make sure that: + - the two selected delegates remain active by re-registering as delegates + - their number of rolls do not change *) + fold_left_s + (fun b _ -> + Error_monad.map_s + (fun del -> + Context.Contract.pkh del + >>=? fun pkh -> Op.delegation (B b) del (Some pkh)) + [del1; del2] + >>=? fun ops -> + Block.bake ~policy ~operations:ops b + >>=? fun b -> Block.bake_until_cycle_end ~policy b) + b + (1 -- Int32.to_int (Int32.div blocks_per_voting_period blocks_per_cycle)) + >>=? fun b -> + (* make the proposal *) + Op.proposals (B b) del1 [protos.(0)] + >>=? fun ops -> + Block.bake ~policy ~operations:[ops] b + >>=? fun b -> + Block.bake_n ~policy (Int32.to_int blocks_per_voting_period - 1) b + >>=? fun b -> + (* we remain in the proposal period when there is no quorum, + otherwise we move to the testing vote period *) + Context.Vote.get_current_period_kind (B b) + >>=? (function + | Testing_vote -> + if has_quorum then return_unit + else + failwith + "%s - Expected period kind Proposal, obtained Testing_vote" + __LOC__ + | Proposal -> + if not has_quorum then return_unit + else + failwith + "%s - Expected period kind Testing_vote, obtained Proposal" + __LOC__ + | _ -> + failwith "%s - Unexpected period kind" __LOC__) + >>=? fun () -> return_unit + let test_supermajority_in_testing_vote supermajority () = - Context.init 100 + let min_proposal_quorum = Int32.(of_int @@ (100_00 / 100)) in + Context.init ~min_proposal_quorum 100 >>=? fun (b, delegates) -> Context.get_constants (B b) >>=? fun {parametric = {blocks_per_voting_period; _}; _} -> @@ -875,7 +976,8 @@ let test_supermajority_in_testing_vote supermajority () = (* test also how the selection scales: all delegates propose max proposals *) let test_no_winning_proposal num_delegates () = - Context.init num_delegates + let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in + Context.init ~min_proposal_quorum num_delegates >>=? fun (b, _) -> Context.get_constants (B b) >>=? fun {parametric = {blocks_per_voting_period; _}; _} -> @@ -905,6 +1007,134 @@ let test_no_winning_proposal num_delegates () = failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> return_unit +(** Test that for the vote to pass with maximum possible participation_ema + (100%), it is sufficient for the vote quorum to be equal or greater than + the maximum quorum cap. *) +let test_quorum_capped_maximum num_delegates () = + let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in + Context.init ~min_proposal_quorum num_delegates + >>=? fun (b, delegates) -> + (* set the participation EMA to 100% *) + Context.Vote.set_participation_ema b 100_00l + >>= fun b -> + Context.get_constants (B b) + >>=? fun {parametric = {blocks_per_voting_period; quorum_max; _}; _} -> + (* proposal period *) + let open Alpha_context in + Context.Vote.get_current_period_kind (B b) + >>=? (function + | Proposal -> + return_unit + | _ -> + failwith "%s - Unexpected period kind" __LOC__) + >>=? fun () -> + (* propose a new protocol *) + let protocol = Protocol_hash.zero in + let proposer = List.nth delegates 0 in + Op.proposals (B b) proposer [protocol] + >>=? fun ops -> + Block.bake ~operations:[ops] b + >>=? fun b -> + (* skip to vote_testing period + -1 because we already baked one block with the proposal *) + Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b + >>=? fun b -> + (* we moved to a testing_vote period with one proposal *) + Context.Vote.get_current_period_kind (B b) + >>=? (function + | Testing_vote -> + return_unit + | _ -> + failwith "%s - Unexpected period kind" __LOC__) + >>=? fun () -> + (* take percentage of the delegates equal or greater than quorum_max *) + let minimum_to_pass = + Float.of_int (List.length delegates) + *. Int32.(to_float quorum_max) + /. 100_00. + |> Float.ceil |> Float.to_int + in + let voters = List.take_n minimum_to_pass delegates in + (* all voters vote for yays; no nays, so supermajority is satisfied *) + map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + >>=? fun operations -> + Block.bake ~operations b + >>=? fun b -> + (* skip to next period *) + Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b + >>=? fun b -> + (* expect to move to testing because we have supermajority and enough quorum *) + Context.Vote.get_current_period_kind (B b) + >>=? function + | Testing -> + return_unit + | _ -> + failwith "%s - Unexpected period kind" __LOC__ + +(** Test that for the vote to pass with minimum possible participation_ema + (0%), it is sufficient for the vote quorum to be equal or greater than + the minimum quorum cap. *) +let test_quorum_capped_minimum num_delegates () = + let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in + Context.init ~min_proposal_quorum num_delegates + >>=? fun (b, delegates) -> + (* set the participation EMA to 0% *) + Context.Vote.set_participation_ema b 0l + >>= fun b -> + Context.get_constants (B b) + >>=? fun {parametric = {blocks_per_voting_period; quorum_min; _}; _} -> + (* proposal period *) + let open Alpha_context in + Context.Vote.get_current_period_kind (B b) + >>=? (function + | Proposal -> + return_unit + | _ -> + failwith "%s - Unexpected period kind" __LOC__) + >>=? fun () -> + (* propose a new protocol *) + let protocol = Protocol_hash.zero in + let proposer = List.nth delegates 0 in + Op.proposals (B b) proposer [protocol] + >>=? fun ops -> + Block.bake ~operations:[ops] b + >>=? fun b -> + (* skip to vote_testing period + -1 because we already baked one block with the proposal *) + Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b + >>=? fun b -> + (* we moved to a testing_vote period with one proposal *) + Context.Vote.get_current_period_kind (B b) + >>=? (function + | Testing_vote -> + return_unit + | _ -> + failwith "%s - Unexpected period kind" __LOC__) + >>=? fun () -> + (* take percentage of the delegates equal or greater than quorum_min *) + let minimum_to_pass = + Float.of_int (List.length delegates) + *. Int32.(to_float quorum_min) + /. 100_00. + |> Float.ceil |> Float.to_int + in + let voters = List.take_n minimum_to_pass delegates in + (* all voters vote for yays; no nays, so supermajority is satisfied *) + map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + >>=? fun operations -> + Block.bake ~operations b + >>=? fun b -> + (* skip to next period *) + Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b + >>=? fun b -> + (* expect to move to testing because we have supermajority and enough quorum *) + Context.Vote.get_current_period_kind (B b) + >>=? function + | Testing -> + return_unit + | _ -> + failwith "%s - Unexpected period kind" __LOC__ + let tests = [ Test.tztest "voting successful_vote" `Quick (test_successful_vote 137); Test.tztest @@ -927,6 +1157,14 @@ let tests = "voting proposal, without supermajority" `Quick (test_supermajority_in_proposal false); + Test.tztest + "voting proposal, with quorum" + `Quick + (test_quorum_in_proposal true); + Test.tztest + "voting proposal, without quorum" + `Quick + (test_quorum_in_proposal false); Test.tztest "voting testing vote, with supermajority" `Quick @@ -938,4 +1176,12 @@ let tests = Test.tztest "voting proposal, no winning proposal" `Quick - (test_no_winning_proposal 400) ] + (test_no_winning_proposal 400); + Test.tztest + "voting quorum, quorum capped maximum" + `Quick + (test_quorum_capped_maximum 400); + Test.tztest + "voting quorum, quorum capped minimum" + `Quick + (test_quorum_capped_minimum 401) ] diff --git a/src/proto_alpha/lib_protocol/time_repr.ml b/src/proto_alpha/lib_protocol/time_repr.ml index cf81a00193c8becd45e09a0267fb9a39a03d41e3..1709ca35812780255f4d7e7cf0b9ce8d30665af5 100644 --- a/src/proto_alpha/lib_protocol/time_repr.ml +++ b/src/proto_alpha/lib_protocol/time_repr.ml @@ -27,6 +27,7 @@ include Time type time = t type error += Timestamp_add (* `Permanent *) +type error += Timestamp_sub (* `Permanent *) let () = register_error_kind @@ -38,7 +39,17 @@ let () = Format.fprintf ppf "Overflow when adding timestamps.") Data_encoding.empty (function Timestamp_add -> Some () | _ -> None) - (fun () -> Timestamp_add) + (fun () -> Timestamp_add); + register_error_kind + `Permanent + ~id:"timestamp_sub" + ~title:"Timestamp sub" + ~description:"Substracting timestamps resulted in negative period." + ~pp:(fun ppf () -> + Format.fprintf ppf "Substracting timestamps resulted in negative period.") + Data_encoding.empty + (function Timestamp_sub -> Some () | _ -> None) + (fun () -> Timestamp_sub) let of_seconds s = try Some (of_seconds (Int64.of_string s)) @@ -49,6 +60,9 @@ let to_seconds_string s = Int64.to_string (to_seconds s) let pp = pp_hum let (+?) x y = - (* TODO check overflow *) try ok (add x (Period_repr.to_seconds y)) - with _exn -> Error [ Timestamp_add ] + with _exn -> error Timestamp_add + +let (-?) x y = + record_trace Timestamp_sub + (Period_repr.of_seconds (diff x y)) diff --git a/src/proto_alpha/lib_protocol/time_repr.mli b/src/proto_alpha/lib_protocol/time_repr.mli index 4269fe68cc7a4efc9203145d8a4a8dc4ffca4bad..3cb96922f9f93278e4755c237aee54daabd619e5 100644 --- a/src/proto_alpha/lib_protocol/time_repr.mli +++ b/src/proto_alpha/lib_protocol/time_repr.mli @@ -31,4 +31,5 @@ val of_seconds: string -> time option val to_seconds_string: time -> string val (+?) : time -> Period_repr.t -> time tzresult +val (-?) : time -> time -> Period_repr.t tzresult diff --git a/src/proto_alpha/lib_protocol/vote_storage.ml b/src/proto_alpha/lib_protocol/vote_storage.ml index 3a2a7b452526b7f6558c19464e0784aa7d82f37c..d5e9013219efcac6d044f7482c5f975eefada3b9 100644 --- a/src/proto_alpha/lib_protocol/vote_storage.ml +++ b/src/proto_alpha/lib_protocol/vote_storage.ml @@ -124,15 +124,24 @@ let clear_listings ctxt = let get_current_period_kind = Storage.Vote.Current_period_kind.get let set_current_period_kind = Storage.Vote.Current_period_kind.set -let get_current_quorum = Storage.Vote.Current_quorum.get -let set_current_quorum = Storage.Vote.Current_quorum.set +let get_current_quorum ctxt = + Storage.Vote.Participation_ema.get ctxt >>=? fun participation_ema -> + let quorum_min = Constants_storage.quorum_min ctxt in + let quorum_max = Constants_storage.quorum_max ctxt in + let quorum_diff = Int32.sub quorum_max quorum_min in + return Int32.(add quorum_min + (div (mul participation_ema quorum_diff) 100_00l)) + +let get_participation_ema = Storage.Vote.Participation_ema.get +let set_participation_ema = Storage.Vote.Participation_ema.set let get_current_proposal = Storage.Vote.Current_proposal.get let init_current_proposal = Storage.Vote.Current_proposal.init let clear_current_proposal = Storage.Vote.Current_proposal.delete let init ctxt = - (* quorum is in centile of a percentage *) - Storage.Vote.Current_quorum.init ctxt 80_00l >>=? fun ctxt -> + (* participation EMA is in centile of a percentage *) + let participation_ema = Constants_storage.quorum_max ctxt in + Storage.Vote.Participation_ema.init ctxt participation_ema >>=? fun ctxt -> Storage.Vote.Current_period_kind.init ctxt Proposal >>=? fun ctxt -> return ctxt diff --git a/src/proto_alpha/lib_protocol/vote_storage.mli b/src/proto_alpha/lib_protocol/vote_storage.mli index 3853f5e8f3206def0378cd5c40440ade829a18f3..6606bbb8355d6854e6492fdcc188536ad14477cd 100644 --- a/src/proto_alpha/lib_protocol/vote_storage.mli +++ b/src/proto_alpha/lib_protocol/vote_storage.mli @@ -79,7 +79,9 @@ val in_listings: val get_listings : Raw_context.t -> (Signature.Public_key_hash.t * int32) list Lwt.t val get_current_quorum: Raw_context.t -> int32 tzresult Lwt.t -val set_current_quorum: Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t + +val get_participation_ema: Raw_context.t -> int32 tzresult Lwt.t +val set_participation_ema: Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t val get_current_period_kind: Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/voting_services.ml b/src/proto_alpha/lib_protocol/voting_services.ml index 80a42a4cdd249a8d344fccfd3b8928afed30cef4..37220bdc82db8d01a828abf689877fbb3c0aa7d6 100644 --- a/src/proto_alpha/lib_protocol/voting_services.ml +++ b/src/proto_alpha/lib_protocol/voting_services.ml @@ -112,8 +112,8 @@ let register () = (* this would be better implemented using get_option in get_current_proposal *) Vote.get_current_proposal ctxt >>= function | Ok p -> return_some p - | Error [Raw_context.Storage_error (Missing_key _)] -> return_none - | (Error _ as e) -> Lwt.return e + | Error (Raw_context.Storage_error (Missing_key _) :: _) -> return_none + | Error _ as e -> Lwt.return e end let ballots ctxt block = diff --git a/tests_python/client/client.py b/tests_python/client/client.py index 269a38c0ddc3a1290c76d6084a647681bbe6e0e2..246ea907ad69259b6fa02a7aebf6fc2772c7c5ec 100644 --- a/tests_python/client/client.py +++ b/tests_python/client/client.py @@ -5,6 +5,7 @@ import os import subprocess import tempfile import json +import sys from . import client_output @@ -113,6 +114,7 @@ class Client: print(format_command(cmd)) + stderr = "" stdout = "" new_env = os.environ.copy() if self._disable_disclaimer: @@ -120,6 +122,7 @@ class Client: # in python3.7, cleaner to use capture_output=true, text=True with subprocess.Popen(cmd, stdout=subprocess.PIPE, + stderr=subprocess.PIPE, bufsize=1, universal_newlines=True, env=new_env) as process: @@ -127,9 +130,14 @@ class Client: print(line, end='') stdout += line + for line in process.stderr: + print(line, end='', file=sys.stderr) + stderr += line if check and process.returncode: raise subprocess.CalledProcessError(process.returncode, - process.args) + process.args, + stdout, + stderr) return stdout @@ -159,16 +167,20 @@ class Client: compl_pr = self.run(params) return client_output.extract_rpc_answer(compl_pr) - def typecheck(self, contract: str) -> str: - assert os.path.isfile(contract), f'{contract} is not a file' + def typecheck(self, contract: str, file : bool = False) -> str: + assert not file or os.path.isfile(contract), f'{contract} is not a file' return self.run(['typecheck', 'script', contract]) + def typecheck_data(self, data: str, typ: str) -> str: + return self.run(['typecheck', 'data', data, 'against', 'type', typ]) + def run_script(self, contract: str, storage: str, inp: str, - amount: float = None) -> client_output.RunScriptResult: - assert os.path.isfile(contract), f'{contract} is not a file' + amount: float = None, + file = True) -> client_output.RunScriptResult: + assert not file or os.path.isfile(contract), f'{contract} is not a file' cmd = ['run', 'script', contract, 'on', 'storage', storage, 'and', 'input', inp] if amount is not None: @@ -245,19 +257,28 @@ class Client: def originate(self, contract_name: str, - manager: str, amount: float, sender: str, contract: str, args: List[str] = None) -> client_output.OriginationResult: - cmd = ['originate', 'contract', contract_name, 'for', manager, - 'transferring', str(amount), 'from', sender, 'running', - contract] + cmd = ['originate', 'contract', contract_name, 'transferring', + str(amount), 'from', sender, 'running', contract] if args is None: args = [] cmd += args return client_output.OriginationResult(self.run(cmd)) + def hash(self, data: str, typ: str) -> client_output.HashResult: + cmd = ['hash', 'data', data, 'of', 'type', typ] + return client_output.HashResult(self.run(cmd)) + + def pack(self, data: str, typ: str) -> str: + return self.hash(data, typ).packed + + def sign(self, data: str, identity: str) -> str: + cmd = ['sign', 'bytes', data, 'for', identity] + return client_output.SignatureResult(self.run(cmd)).sig + def transfer(self, amount: float, account1: str, @@ -277,6 +298,28 @@ class Client: res = self.run(['get', 'balance', 'for', account]) return client_output.extract_balance(res) + def get_script_storage(self, contract: str) -> str: + res = self.run(['get', 'script', 'storage', 'for', contract]) + return res[:-1] + + def get_timestamp(self) -> str: + res = self.run(['get', 'timestamp']) + return res[:-1] + + def get_now(self) -> str: + """Returns the timestamp of next-to-last block, offset by time_between_blocks""" + rfc3399_format = "%Y-%m-%dT%H:%M:%SZ" + timestamp = self.rpc('get', f'/chains/main/blocks/head~1/header')['timestamp'] + timestamp_date = datetime.datetime.strptime(timestamp, rfc3399_format) + timestamp_date = timestamp_date.replace(tzinfo=datetime.timezone.utc) + + constants = self.rpc('get', f'/chains/main/blocks/head/context/constants') + delta = datetime.timedelta(seconds=int(constants['time_between_blocks'][0])) + + now_date = timestamp_date + delta + + return now_date.strftime(rfc3399_format) + def get_receipt(self, operation: str, args: List[str] = None) -> client_output.GetReceiptResult: @@ -286,6 +329,15 @@ class Client: cmd += args return client_output.GetReceiptResult(self.run(cmd)) + def get_storage(self, contract: str) -> str: + cmd = ['get', 'script', 'storage', 'for', contract] + res = self.run(cmd) + return res.rstrip() + + def get_delegate(self, contract: str) -> client_output.GetDelegateResult: + cmd = ['get', 'delegate', 'for', contract] + return client_output.GetDelegateResult(self.run(cmd)) + def get_prevalidator(self) -> dict: return self.rpc('get', '/workers/prevalidators') @@ -303,6 +355,12 @@ class Client: def get_head(self) -> dict: return self.rpc('get', '/chains/main/blocks/head') + def get_hash_data(self, + data: str, + typ: str) -> client_output.HashResult: + cmd = ['hash', 'data', data, 'of', 'type', typ] + return client_output.HashResult(self.run(cmd)) + def get_block(self, block_hash) -> dict: return self.rpc('get', f'/chains/main/blocks/{block_hash}') @@ -312,6 +370,12 @@ class Client: def get_ballots(self) -> dict: return self.rpc('get', '/chains/main/blocks/head/votes/ballots') + def get_contract_address(self, contract) -> str: + return self.run(['show', 'known', 'contract', contract]).strip() + + def get_known_addresses(self) -> str: + return client_output.GetAddressesResult(self.run(['list', 'known', 'addresses'])) + def get_current_period_kind(self) -> dict: return self.rpc('get', 'chains/main/blocks/head/votes/current_period_kind') @@ -349,7 +413,7 @@ class Client: branch: str = None, args=None) -> client_output.WaitForResult: cmd = ['wait', 'for', operation_hash, 'to', 'be', 'included'] - cmd += ['--check-previous', '5'] + cmd += ['--check-previous', '2'] if branch is not None: cmd += ['--branch', branch] if args is None: diff --git a/tests_python/client/client_output.py b/tests_python/client/client_output.py index 37a7388f43ed049ef11f336ab22e2728bba63da6..ba6bb2e4ec9787384cbed3ece64dc2ab840f67d9 100644 --- a/tests_python/client/client_output.py +++ b/tests_python/client/client_output.py @@ -29,6 +29,7 @@ class TransferResult: """Result of a 'transfer' operation.""" def __init__(self, client_output: str): + self.client_output = client_output pattern = r"Operation hash is '?(\w*)" match = re.search(pattern, client_output) if match is None: @@ -58,16 +59,51 @@ class GetReceiptResult: self.block_hash = match.groups()[0] +class GetDelegateResult: + """Result of 'get delegate for' command. + self.delegate is set to None if the contract has no delegate. + """ + + def __init__(self, client_output: str): + if client_output == 'none\n': + self.delegate = None + else: + pattern = r'(\w*) ' + match = re.search(pattern, client_output) + if match is None: + raise InvalidClientOutput(client_output) + self.delegate = match.groups()[0] + +class GetAddressesResult: + """Result of 'list known addresses' operation. + + """ + + def __init__(self, client_output: str): + + pattern = re.compile(r"^(\w+):\s*(\w+).*$", re.MULTILINE) + self.wallet = dict(re.findall(pattern, client_output)) + class RunScriptResult: """Result of a 'get script' operation.""" def __init__(self, client_output: str): - pattern = r"^storage\n\s*(.*)" + # read storage output + pattern = r"(?s)storage\n\s*(.*)\nemitted operations\n" match = re.search(pattern, client_output) if match is None: raise InvalidClientOutput(client_output) self.storage = match.groups()[0] + # read map diff output + self.big_map_diff = [] + pattern = r"big_map diff\n" + match = re.search(pattern, client_output) + if match is not None: + pattern = re.compile(r" ([^ ].*?)\n") + for match_diff in pattern.finditer(client_output, match.end(0)): + self.big_map_diff.append([match_diff.group(1)]) + class OriginationResult: """Result of an 'originate contract' operation.""" @@ -129,6 +165,52 @@ class WaitForResult: self.block_hash = match.groups()[0] +class HashResult: + """Result of a 'hash data' command.""" + + def __init__(self, client_output: str): + + pattern = r'''Raw packed data: ?(0x[0-9a-f]*) +Script-expression-ID-Hash: ?(\w*) +Raw Script-expression-ID-Hash: ?(\w*) +Ledger Blake2b hash: ?(\w*) +Raw Sha256 hash: ?(\w*) +Raw Sha512 hash: ?(\w*) +Gas remaining: ?(\w*)''' + match = re.search(pattern, client_output) + if match is None: + raise InvalidClientOutput(client_output) + self.packed = match.groups()[0] + self.hash = match.groups()[1] + self.raw_hash = match.groups()[2] + self.blake2b = match.groups()[3] + self.sha256 = match.groups()[4] + self.sha512 = match.groups()[5] + + +class SignatureResult: + """Result of a 'sign bytes' command.""" + + def __init__(self, client_output: str): + + pattern = r'Signature: ?(\w*)\n' + match = re.search(pattern, client_output) + if match is None: + raise InvalidClientOutput(client_output) + self.sig = match.groups()[0] + + +class HashDataResult: + """Result of a 'hash data' command.""" + + def __init__(self, client_output: str): + pattern = r"Raw Script-expression-ID-Hash: ?(\w*)" + match = re.search(pattern, client_output) + if match is None: + raise InvalidClientOutput(client_output) + self.raw_script_expression_id_hash = match.groups()[0] + + def extract_rpc_answer(client_output: str) -> dict: """Convert json client output to a dict representation. @@ -143,7 +225,11 @@ def extract_rpc_answer(client_output: str) -> dict: def extract_balance(client_output: str) -> float: """Extract float balance from the output of 'get_balance' operation.""" try: - return float(client_output[:-3]) + pattern = r"([\w.]*) ꜩ" + match = re.search(pattern, client_output) + if match is None: + raise InvalidClientOutput(client_output) + return float(match.groups()[0]) except Exception: raise InvalidClientOutput(client_output) diff --git a/tests_python/examples/test_example.py b/tests_python/examples/test_example.py index 87bd9ee714d958f5ed0ec98f54b42feb2ca73ab6..aafa91cc01fd00e90167044c71d51f06f312b148 100644 --- a/tests_python/examples/test_example.py +++ b/tests_python/examples/test_example.py @@ -39,4 +39,6 @@ class TestExample: # @pytest.mark.timeout(5, method='thread') def test_inclusion(self, sandbox, session): operation_hash = session['operation_hash'] + # FIXME retrieve the block hash where the operation was + # injected and pass it to `wait_for_inclusion` sandbox.client(0).wait_for_inclusion(operation_hash) diff --git a/tests_python/tests/test_contract.py b/tests_python/tests/test_contract.py index 17513e4239fba456baf2024be0680b603dadbc30..ae1dbc6b73c4f1d8e0b37697de108406c1957535 100644 --- a/tests_python/tests/test_contract.py +++ b/tests_python/tests/test_contract.py @@ -1,45 +1,86 @@ import os -import subprocess +import re import pytest from tools import paths - +from tools import utils +from tools.constants import IDENTITIES CONTRACT_PATH = f'{paths.TEZOS_HOME}/src/bin_client/test/contracts' +ILLTYPED_CONTRACT_PATH = f'{CONTRACT_PATH}/ill_typed' +DEPRECATED_CONTRACT_PATH = f'{CONTRACT_PATH}/deprecated' + +BAKE_ARGS = ['--minimal-timestamp'] + + +def file_basename(path): + return os.path.splitext(os.path.basename(path))[0] + + +# Generic piece of code to originate a contract +def originate(client, + session, + contract, + init_storage, + amount, + contract_name=None, + sender='bootstrap1', + baker='bootstrap5'): + if contract_name is None: + contract_name = file_basename(contract) + args = ['--init', init_storage, '--burn-cap', '10.0'] + origination = client.originate(contract_name, amount, + sender, contract, args) + session['contract'] = origination.contract + print(origination.contract) + client.bake(baker, BAKE_ARGS) + assert utils.check_block_contains_operations(client, + [origination.operation_hash]) def all_contracts(): - directories = ['attic', 'opcodes'] + directories = ['attic', 'opcodes', + 'macros', 'mini_scenarios', 'non_regression'] contracts = [] for directory in directories: for contract in os.listdir(f'{CONTRACT_PATH}/{directory}'): contracts.append(f'{directory}/{contract}') return contracts +def all_deprecated_contract(): + contracts = [] + for contract in os.listdir(f'{DEPRECATED_CONTRACT_PATH}'): + contracts.append(f'{DEPRECATED_CONTRACT_PATH}/{contract}') + return contracts + @pytest.mark.slow @pytest.mark.contract class TestContracts: """Test type checking and execution of a bunch of contracts""" - def test_gen_keys(self, client): - client.gen_key('foo') - client.gen_key('bar') - @pytest.mark.parametrize("contract", all_contracts()) def test_typecheck(self, client, contract): if contract.endswith('.tz'): client.typecheck(f'{CONTRACT_PATH}/{contract}') - # TODO add more tests here - @pytest.mark.parametrize("contract,param,storage,expected", - [('opcodes/ret_int.tz', 'None', 'Unit', - '(Some 300)')]) - def test_run(self, client, contract, param, storage, expected): - if contract.endswith('.tz'): - contract = f'{CONTRACT_PATH}/{contract}' - run_script_res = client.run_script(contract, param, storage) - assert run_script_res.storage == expected + @pytest.mark.parametrize("contract,error_pattern", [ + # operations cannot be PACKed + ("pack_operation.tz", r'operation type forbidden in parameter, storage and constants'), + # big_maps cannot be PACKed + ("pack_big_map.tz", r'big_map type not allowed inside another big_map') + ]) + def test_ill_typecheck(self, client, contract, error_pattern): + def cmd(): + client.typecheck(f'{ILLTYPED_CONTRACT_PATH}/{contract}') + assert utils.check_run_failure(cmd, error_pattern) + + @pytest.mark.parametrize("contract", all_deprecated_contract()) + def test_deprected_typecheck(self, client, contract): + def cmd(): + client.typecheck(contract) + + assert utils.check_run_failure(cmd, r'Use of deprecated instruction') FIRST_EXPLOSION = ''' { parameter unit; @@ -52,7 +93,28 @@ FIRST_EXPLOSION = ''' DUP ; PAIR ; DUP ; PAIR ; DUP ; PAIR ; - DUP ; PAIR } } + DUP ; PAIR ; + DROP ; UNIT ; NIL operation ; PAIR} } +''' + + +# FIRST_EXPLOSION costs a large amount of gas just for typechecking. +# FIRST_EXPLOSION_BIGTYPE type size exceeds the protocol set bound. +FIRST_EXPLOSION_BIGTYPE = ''' +{ parameter unit; + storage unit; + code{ DROP; PUSH nat 0 ; + DUP ; PAIR ; + DUP ; PAIR ; + DUP ; PAIR ; + DUP ; PAIR ; + DUP ; PAIR ; + DUP ; PAIR ; + DUP ; PAIR ; + DUP ; PAIR ; + DUP ; PAIR ; + DUP ; PAIR ; + DROP ; UNIT ; NIL operation ; PAIR} } ''' @@ -72,6 +134,7 @@ class TestGasBound: def test_write_contract(self, tmpdir, session): items = {'first_explosion.tz': FIRST_EXPLOSION, + 'first_explosion_bigtype.tz': FIRST_EXPLOSION_BIGTYPE, 'second_explosion.tz': SECOND_EXPLOSION}.items() for name, script in items: contract = f'{tmpdir}/{name}' @@ -82,12 +145,25 @@ class TestGasBound: def test_originate_first_explosion(self, client, session): name = 'first_explosion.tz' contract = session[name] - # TODO client.typecheck(contract) -> type error not what we expect? + client.typecheck(contract) args = ['-G', '8000', '--burn-cap', '10'] - with pytest.raises(subprocess.CalledProcessError) as _exc: - client.originate(f'{name}', 'bootstrap1', 0, + + def client_cmd(): + client.originate(f'{name}', 0, 'bootstrap1', contract, args) - # TODO capture output and check error message is correct + expected_error = "Gas limit exceeded during typechecking or execution" + assert utils.check_run_failure(client_cmd, expected_error) + + def test_originate_big_type(self, client, session): + name = 'first_explosion_bigtype.tz' + contract = session[name] + + def client_cmd(): + client.typecheck(contract) + # We could not be bothered with finding how to escape parentheses + # so we put dots + expected_error = "type size .1023. exceeded maximum type size .1000." + assert utils.check_run_failure(client_cmd, expected_error) def test_originate_second_explosion(self, client, session): name = 'second_explosion.tz' @@ -96,4 +172,271 @@ class TestGasBound: inp = '{1;2;3;4;5;6;7;8;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1}' client.run_script(contract, storage, inp) - # TODO complete with tests from test_contract.sh + def test_originate_second_explosion_fail(self, client, session): + name = 'second_explosion.tz' + contract = session[name] + storage = '{}' + inp = ('{1;2;3;4;5;6;7;8;9;0;1;2;3;4;5;6;7;1;1;1;1;1;1;1;1;1;1;1' + + ';1;1;1;1;1;1;1;1;1;1;1}') + + def client_cmd(): + client.run_script(contract, storage, inp) + expected_error = \ + ("Cannot serialize the resulting storage" + + " value within the provided gas bounds.") + assert utils.check_run_failure(client_cmd, expected_error) + + def test_typecheck_map_dup_key(self, client): + + def client_cmd(): + client.typecheck_data('{ Elt 0 1 ; Elt 0 1}', '(map nat nat)') + expected_error = \ + ('Map literals cannot contain duplicate' + + ' keys, however a duplicate key was found') + assert utils.check_run_failure(client_cmd, expected_error) + + def test_typecheck_map_bad_ordering(self, client): + + def client_cmd(): + client.typecheck_data('{ Elt 0 1 ; Elt 10 1 ; Elt 5 1 }', + '(map nat nat)') + expected_error = \ + ("Keys in a map literal must be in strictly" + + " ascending order, but they were unordered in literal") + assert utils.check_run_failure(client_cmd, expected_error) + + def test_typecheck_set_bad_ordering(self, client): + + def client_cmd(): + client.typecheck_data('{ "A" ; "C" ; "B" }', '(set string)') + expected_error = \ + ("Values in a set literal must be in strictly" + + " ascending order, but they were unordered in literal") + assert utils.check_run_failure(client_cmd, expected_error) + + def test_typecheck_set_no_duplicates(self, client): + def client_cmd(): + client.typecheck_data('{ "A" ; "B" ; "B" }', '(set string)') + expected_error = \ + ("Set literals cannot contain duplicate values," + + " however a duplicate value was found") + assert utils.check_run_failure(client_cmd, expected_error) + + +@pytest.mark.contract +class TestChainId: + + def test_chain_id_opcode(self, client, session): + path = f'{CONTRACT_PATH}/opcodes/chain_id.tz' + originate(client, session, path, 'Unit', 0) + client.transfer(0, 'bootstrap2', "chain_id", []) + client.bake('bootstrap5', BAKE_ARGS) + + def test_chain_id_authentication_origination(self, client, session): + path = f'{CONTRACT_PATH}/mini_scenarios/authentication.tz' + pubkey = IDENTITIES['bootstrap1']['public'] + originate(client, session, path, f'Pair 0 "{pubkey}"', 1000) + client.bake('bootstrap5', BAKE_ARGS) + + def test_chain_id_authentication_first_run(self, client, session): + destination = IDENTITIES['bootstrap2']['identity'] + operation = '{DROP; NIL operation; ' + \ + f'PUSH address "{destination}"; ' + \ + 'CONTRACT unit; ASSERT_SOME; PUSH mutez 1000; UNIT; ' + \ + 'TRANSFER_TOKENS; CONS}' + chain_id = client.rpc('get', 'chains/main/chain_id') + contract_address = session['contract'] + packed = client.pack( + f'Pair (Pair "{chain_id}" "{contract_address}") ' + + f'(Pair {operation} 0)', + 'pair (pair chain_id address)' + + '(pair (lambda unit (list operation)) nat)') + signature = client.sign(packed, "bootstrap1") + client.transfer(0, 'bootstrap2', 'authentication', + ['--arg', f'Pair {operation} \"{signature}\"']) + client.bake('bootstrap5', BAKE_ARGS) + + +@pytest.mark.contract +class TestBigMapToSelf: + + def test_big_map_to_self_origination(self, client, session): + path = f'{CONTRACT_PATH}/opcodes/big_map_to_self.tz' + originate(client, session, path, '{}', 0) + client.bake('bootstrap5', BAKE_ARGS) + + def test_big_map_to_self_transfer(self, client): + client.transfer(0, 'bootstrap2', "big_map_to_self", []) + + +@pytest.mark.contract +class TestNonRegression: + """Test contract-related non-regressions""" + + def test_issue_242_originate(self, client, session): + path = f'{CONTRACT_PATH}/non_regression/bug_262.tz' + originate(client, session, path, 'Unit', 1) + + def test_issue_242_assert_balance(self, client): + assert client.get_balance('bug_262') == 1 + + +@pytest.mark.contract +class TestMiniScenarios: + """Test mini scenarios""" + + # replay.tz related tests + def test_replay_originate(self, client, session): + path = f'{CONTRACT_PATH}/mini_scenarios/replay.tz' + originate(client, session, path, 'Unit', 0) + + def test_replay_transfer_fail(self, client): + def client_cmd(): + client.transfer(0, "bootstrap1", "replay", []) + assert utils.check_run_failure(client_cmd, + "Internal operation replay attempt") + + # create_contract.tz related tests + def test_create_contract_originate(self, client, session): + path = f'{CONTRACT_PATH}/mini_scenarios/create_contract.tz' + originate(client, session, path, 'Unit', 1000) + + def test_create_contract_balance(self, client): + assert client.get_balance('create_contract') == 1000 + + def test_create_contract_perform_creation(self, client): + transfer_result = client.transfer(0, "bootstrap1", "create_contract", + ['-arg', + 'None', + '--burn-cap', + '10']) + client.bake('bootstrap5', BAKE_ARGS) + pattern = r"New contract (\w*) originated" + match = re.search(pattern, transfer_result.client_output) + kt_1 = match.groups()[0] + assert client.get_storage(kt_1) == '"abcdefg"' + assert client.get_balance(kt_1) == 100 + assert client.get_balance('create_contract') == 900 + + # default_account.tz related tests + def test_default_account_originate(self, client, session): + path = f'{CONTRACT_PATH}/mini_scenarios/default_account.tz' + originate(client, session, path, 'Unit', 1000) + + def test_default_account_transfer_then_bake(self, client): + tz1 = IDENTITIES['bootstrap4']['identity'] + client.transfer(0, "bootstrap1", "default_account", + ['-arg', f'"{tz1}"', '--burn-cap', '10']) + client.bake('bootstrap5', BAKE_ARGS) + account = 'tz1SuakBpFdG9b4twyfrSMqZzruxhpMeSrE5' + client.transfer(0, "bootstrap1", "default_account", + ['-arg', f'"{account}"', '--burn-cap', '10']) + client.bake('bootstrap5', BAKE_ARGS) + assert client.get_balance(account) == 100 + + # Test bytes, SHA252, CHECK_SIGNATURE + def test_reveal_signed_preimage_originate(self, client, session): + path = f'{CONTRACT_PATH}/mini_scenarios/reveal_signed_preimage.tz' + byt = ('0x9995c2ef7bcc7ae3bd15bdd9b02' + + 'dc6e877c27b26732340d641a4cbc6524813bb') + sign = f'p2pk66uq221795tFxT7jfNmXtBMdjMf6RAaxRTwv1dbuSHbH6yfqGwz' + storage = f'(Pair {byt} "{sign}")' + originate(client, session, path, storage, 1000) + + def test_wrong_preimage(self, client): + byt = ('0x050100000027566f756c657a2d766f75732' + + '0636f75636865722061766563206d6f692c20636520736f6972') + sign = ('p2sigvgDSBnN1bUsfwyMvqpJA1cFhE5s5oi7SetJ' + + 'VQ6LJsbFrU2idPvnvwJhf5v9DhM9ZTX1euS9DgWozVw6BTHiK9VcQVpAU8') + arg = f'(Pair {byt} "{sign}")' + + def client_cmd(): + client.transfer(0, "bootstrap1", "reveal_signed_preimage", + ['-arg', arg, '--burn-cap', '10']) + # We check failure of ASSERT_CMPEQ in the script. + assert utils.check_run_failure(client_cmd, + "At line 8 characters 9 to 21") + + def test_wrong_signature(self, client): + byt = ('0x050100000027566f756c657a2d766f757320636' + + 'f75636865722061766563206d6f692c20636520736f6972203f') + sign = ('p2sigvgDSBnN1bUsfwyMvqpJA1cFhE5s5oi7SetJVQ6' + + 'LJsbFrU2idPvnvwJhf5v9DhM9ZTX1euS9DgWozVw6BTHiK9VcQVpAU8') + arg = f'(Pair {byt} "{sign}")' + + def client_cmd(): + client.transfer(0, "bootstrap1", "reveal_signed_preimage", + ['-arg', arg, '--burn-cap', '10']) + # We check failure of CHECK_SIGNATURE ; ASSERT in the script. + assert utils.check_run_failure(client_cmd, + "At line 15 characters 9 to 15") + + def test_good_preimage_and_signature(self, client): + byt = ('0x050100000027566f756c657a2d766f757320636f7563' + + '6865722061766563206d6f692c20636520736f6972203f') + sign = ('p2sigsceCzcDw2AeYDzUonj4JT341WC9Px4wdhHBxbZcG1F' + + 'hfqFVuG7f2fGCzrEHSAZgrsrQWpxduDPk9qZRgrpzwJnSHC3gZJ') + arg = f'(Pair {byt} "{sign}")' + client.transfer(0, "bootstrap1", "reveal_signed_preimage", + ['-arg', arg, '--burn-cap', '10']) + client.bake('bootstrap5', BAKE_ARGS) + + # Test vote_for_delegate + def test_vote_for_delegate_originate(self, client, session): + b_3 = IDENTITIES['bootstrap3']['identity'] + b_4 = IDENTITIES['bootstrap4']['identity'] + path = f'{CONTRACT_PATH}/mini_scenarios/vote_for_delegate.tz' + storage = f'''(Pair (Pair "{b_3}" None) (Pair "{b_4}" None))''' + originate(client, session, path, storage, 1000) + assert client.get_delegate('vote_for_delegate').delegate is None + + def test_vote_for_delegate_wrong_identity1(self, client): + def client_cmd(): + client.transfer(0, "bootstrap1", "vote_for_delegate", + ['-arg', 'None', '--burn-cap', '10']) + # We check failure of CHECK_SIGNATURE ; ASSERT in the script. + assert utils.check_run_failure(client_cmd, + "At line 15 characters 57 to 61") + + def test_vote_for_delegate_wrong_identity2(self, client): + def client_cmd(): + client.transfer(0, "bootstrap2", "vote_for_delegate", + ['-arg', 'None', '--burn-cap', '10']) + # We check failure of CHECK_SIGNATURE ; ASSERT in the script. + assert utils.check_run_failure(client_cmd, + "At line 15 characters 57 to 61") + + def test_vote_for_delegate_b3_vote_for_b5(self, client): + b_5 = IDENTITIES['bootstrap5']['identity'] + client.transfer(0, "bootstrap3", "vote_for_delegate", + ['-arg', f'(Some "{b_5}")', '--burn-cap', '10']) + client.bake('bootstrap5', BAKE_ARGS) + storage = client.get_storage('vote_for_delegate') + assert re.search(b_5, storage) + + def test_vote_for_delegate_still_no_delegate1(self, client): + assert client.get_delegate('vote_for_delegate').delegate is None + + def test_vote_for_delegate_b4_vote_for_b2(self, client): + b_2 = IDENTITIES['bootstrap2']['identity'] + client.transfer(0, "bootstrap4", "vote_for_delegate", + ['-arg', f'(Some "{b_2}")', '--burn-cap', '10']) + client.bake('bootstrap5', BAKE_ARGS) + storage = client.get_storage('vote_for_delegate') + assert re.search(b_2, storage) + + def test_vote_for_delegate_still_no_delegate2(self, client): + assert client.get_delegate('vote_for_delegate').delegate is None + + def test_vote_for_delegate_b4_vote_for_b5(self, client): + b_5 = IDENTITIES['bootstrap5']['identity'] + client.transfer(0, "bootstrap4", "vote_for_delegate", + ['-arg', f'(Some "{b_5}")', '--burn-cap', '10']) + client.bake('bootstrap5', BAKE_ARGS) + storage = client.get_storage('vote_for_delegate') + assert re.search(b_5, storage) + + def test_vote_for_delegate_has_delegate(self, client): + b_5 = IDENTITIES['bootstrap5']['identity'] + result = client.get_delegate('vote_for_delegate') + assert result.delegate == b_5 diff --git a/tests_python/tests/test_contract_baker.py b/tests_python/tests/test_contract_baker.py index 6da6412cd4ab5fa38c628ab6c58ab423ed7c3546..353802a0c2c3bcc1fa80a4cbd968ac97b0b39eae 100644 --- a/tests_python/tests/test_contract_baker.py +++ b/tests_python/tests/test_contract_baker.py @@ -23,7 +23,7 @@ class TestOriginationCall: path = f'{paths.TEZOS_HOME}/src/bin_client/test/contracts/opcodes' contract = f'{path}/transfer_tokens.tz' args = ['--init', initial_storage, '--burn-cap', '0.400'] - origination = client.originate('foobar', 'bootstrap1', 1000, + origination = client.originate('foobar', 1000, 'bootstrap1', contract, args) session['contract'] = origination.contract client.bake('bootstrap5', BAKE_ARGS) diff --git a/tests_python/tests/test_contract_documentation.py b/tests_python/tests/test_contract_documentation.py new file mode 100644 index 0000000000000000000000000000000000000000..a24f7ff90b823c4aa9934616e6f3d0a8d93def25 --- /dev/null +++ b/tests_python/tests/test_contract_documentation.py @@ -0,0 +1,187 @@ +import os +import subprocess +import pytest +import sys +from tools import paths +from tools.utils import check_run_failure + +# TODO: fix this hack +sys.path.append(paths.TEZOS_HOME + "/docs/doc_gen/michelson_reference/") + +from language_def import LanguageDefinition + +def get_ldef(): + return LanguageDefinition( + 'docs/doc_gen/michelson_reference/michelson-meta.yaml', + 'docs/doc_gen/michelson_reference/michelson-meta-schema.json', + 'docs/doc_gen/michelson_reference/michelson.json', + 'src/bin_client/test/contracts/' + ) + +def all_types(**kwargs): + nofilter = {'passable': None, + 'comparable': None, + 'pushable': None, + 'packable': None, + 'storability': None} + filters = {**nofilter, **kwargs} + ldef = get_ldef() + types = ldef.get_types() + def attr_filter(ty): + return not(any([ + filt is not None and ty[attr] != filt + for (attr, filt) in filters.items() + ])) + + return [ (ty_descr['ty'], ty_descr) + for ty_descr in types + if attr_filter(ty_descr) ] + +def all_type_examples(**kwargs): + types = all_types(**kwargs) + exs = [] + for (ty, ty_descr) in types: + for v in ty_descr['examples']: + exs.append(tuple(v) + (ty_descr,)) + return exs + +def contract(parameter_ty, storage_ty, code): + return f'parameter ({parameter_ty}); storage ({storage_ty}); code {{ {code} }}' + +def contract_with_val_on_stack(ty_descr, code, storage_ty): + if ty_descr['ty'] == 'contract': + code = contract( + 'unit', storage_ty, + f'DROP; SELF; ' + code) + parameter = 'unit' + elif ty_descr['ty'] == 'operation': + code = contract( + 'unit', storage_ty, + f'SELF; PUSH mutez 1; UNIT; TRANSFER_TOKENS; ' + code) + parameter = 'unit' + elif ty_descr['passable']: + assert len(ty_descr['examples']) + (value, ty) = ty_descr['examples'][0] + code = contract( + ty, storage_ty, + f'CAR; ' + code) + parameter = value + else: + assert False + + return { + 'code': code, + 'parameter': parameter + } + +@pytest.mark.slow +@pytest.mark.contract +class TestContractsDocumentation: + + # Check passability + @pytest.mark.parametrize('ty, ty_descr', all_types()) + def test_passable_values_typecheck(self, client, ty, ty_descr): + assert len(ty_descr['insertions']) + tc_contract = contract(ty_descr['insertions'][0], + 'unit', + 'DROP; UNIT; NIL operation; PAIR') + def cmd(): + client.typecheck(tc_contract, file = False) + check_type_checks(cmd, ty_descr['passable'], 'ill-typed script') + + # Check storability + @pytest.mark.parametrize('ty, ty_descr', all_types()) + def test_storable_values_typecheck(self, client, ty, ty_descr): + assert len(ty_descr['insertions']) + store_contract = contract_with_val_on_stack( + ty_descr, + 'NIL operation; PAIR', + ty_descr['insertions'][0] + ) + def cmd(): + client.typecheck(store_contract['code'], file = False) + check_type_checks(cmd, ty_descr['storable'], 'ill-typed script') + + # Check comparability + @pytest.mark.parametrize('ty, ty_descr', all_types()) + def test_uncomparable_values_are_uncomparable(self, client, ty, ty_descr): + cmp_contract = contract_with_val_on_stack( + ty_descr, 'DUP; COMPARE; DROP; ' + + 'UNIT; NIL operation; PAIR', + 'unit' + ) + + def cmd(): + client.typecheck(cmp_contract['code'], file = False) + + check_type_checks(cmd, ty_descr['comparable'], 'comparable type expected') + + @pytest.mark.parametrize('value, ty, ty_descr', all_type_examples()) + def test_comparable_values_in_structures(self, client, value, ty, ty_descr): + assert len(ty_descr['insertions']) + + if ty.startswith('pair '): + pytest.skip('bug: pairs should be comparable') + + tc_contract = contract( + 'unit', 'unit', + 'DROP; ' + + 'EMPTY_SET ' + ty_descr['insertions'][0] + '; DROP; ' + + 'EMPTY_MAP ' + ty_descr['insertions'][0] + ' nat; DROP; ' + + 'EMPTY_BIG_MAP ' + ty_descr['insertions'][0] + ' nat; DROP; ' + + 'UNIT; NIL operation; PAIR') + + def cmd(): + client.typecheck(tc_contract, file = False) + + check_type_checks(cmd, ty_descr['comparable'], 'ill-typed script') + + # Check pushability + @pytest.mark.parametrize('ty, ty_descr', all_types()) + def test_pushable_values_can_be_pushed(self, client, ty, ty_descr): + if not len(ty_descr['examples']): + pytest.skip("no examples values") + + (value, ty) = ty_descr['examples'][0] + + cmp_contract = contract( + 'unit', 'unit', + f'DROP; PUSH ({ty}) {value}; DROP; ' + + 'UNIT; NIL operation; PAIR') + + def cmd(): + client.typecheck(cmp_contract, file = False) + + check_type_checks(cmd, ty_descr['pushable'], 'ill-typed script') + + # Check packability + @pytest.mark.parametrize('ty, ty_descr', all_types()) + def test_nonpackable_values_cannot_be_packed(self, client, ty, ty_descr): + pack_contract = contract_with_val_on_stack( + ty_descr, 'PACK; DROP; UNIT; NIL operation; PAIR', + 'unit' + ) + def cmd(): + client.typecheck(pack_contract['code'], file = False) + check_type_checks(cmd, ty_descr['packable'], 'ill-typed script') + + # Check big_map_values + @pytest.mark.parametrize('ty, ty_descr', all_types()) + def test_unbig_map_value_values_typecheck(self, client, ty, ty_descr): + assert len(ty_descr['insertions']) + + if ty.startswith('contract'): + pytest.skip('bug: contracts should be big map valueable') + + tc_contract = contract('unit', 'unit', + 'DROP; EMPTY_BIG_MAP nat (' + ty_descr['insertions'][0] + ');' + + 'DROP; UNIT; NIL operation; PAIR') + def cmd(): + client.typecheck(tc_contract, file = False) + check_type_checks(cmd, ty_descr['big_map_value'], 'ill-typed script') + +def check_type_checks(cmd, should_type_check, pattern): + if should_type_check: + return cmd() + else: + assert check_run_failure(cmd, pattern) diff --git a/tests_python/tests/test_contract_opcodes.py b/tests_python/tests/test_contract_opcodes.py new file mode 100644 index 0000000000000000000000000000000000000000..518b49ac554a3e8f04f5d7d889a5449052796219 --- /dev/null +++ b/tests_python/tests/test_contract_opcodes.py @@ -0,0 +1,1135 @@ +import os +import pytest +from tools import paths +from tools.utils import check_run_failure +from tools.constants import IDENTITIES + +from client.client import Client +from client.client_output import BakeForResult, RunScriptResult + +CONTRACT_PATH = f'{paths.TEZOS_HOME}/src/bin_client/test/contracts/opcodes/' +KEY1 = 'foo' +KEY2 = 'bar' + + +@pytest.mark.incremental +@pytest.mark.slow +@pytest.mark.contract +class TestContractOpcodes: + def test_gen_keys(self, client): + """Add keys used by later tests.""" + client.gen_key(KEY1) + client.gen_key(KEY2) + + @pytest.mark.parametrize( + "contract,param,storage,expected", + [ # FORMAT: assert_output contract_file storage input expected_result + + # TODO add tests for map_car.tz, subset.tz + # NB: noop.tz is tested in test_basic.sh + + ('cons.tz', '{}', '10', '{ 10 }'), + ('cons.tz', '{ 10 }', '-5', '{ -5 ; 10 }'), + ('cons.tz', '{ -5 ; 10 }', '99', '{ 99 ; -5 ; 10 }'), + + # Tests on Options + ('none.tz', 'Some 10', 'Unit', 'None'), + + ('ret_int.tz', 'None', 'Unit', '(Some 300)'), + + # Map block on lists + ('list_map_block.tz', '{0}', '{}', '{}'), + ('list_map_block.tz', '{0}', '{ 1 ; 1 ; 1 ; 1 }', + '{ 1 ; 2 ; 3 ; 4 }'), + ('list_map_block.tz', '{0}', '{ 1 ; 2 ; 3 ; 0 }', + '{ 1 ; 3 ; 5 ; 3 }'), + + # Reverse a list + ('reverse.tz', '{""}', '{}', '{}'), + ('reverse.tz', '{""}', '{ "c" ; "b" ; "a" }', + '{ "a" ; "b" ; "c" }'), + + # Reverse using LOOP_LEFT + ('loop_left.tz', '{""}', '{}', '{}'), + ('loop_left.tz', '{""}', '{ "c" ; "b" ; "a" }', + '{ "a" ; "b" ; "c" }'), + + # Identity on strings + ('str_id.tz', 'None', '"Hello"', '(Some "Hello")'), + ('str_id.tz', 'None', '"abcd"', '(Some "abcd")'), + + # Slice strings + ('slice.tz', 'None', 'Pair 0 0', 'None'), + ('slice.tz', 'Some "Foo"', 'Pair 10 5', 'None'), + ('slice.tz', 'Some "Foo"', 'Pair 0 0', '(Some "")'), + ('slice.tz', 'Some "Foo"', 'Pair 0 10', 'None'), + ('slice.tz', 'Some "Foo"', 'Pair 0 2', '(Some "Fo")'), + ('slice.tz', 'Some "Foo"', 'Pair 1 3', 'None'), + ('slice.tz', 'Some "Foo"', 'Pair 1 1', '(Some "o")'), + + # Slice bytes + ('slice_bytes.tz', 'None', 'Pair 0 1', 'None'), + ('slice_bytes.tz', 'Some 0xaabbcc', 'Pair 0 0', '(Some 0x)'), + ('slice_bytes.tz', 'Some 0xaabbcc', 'Pair 0 1', '(Some 0xaa)'), + ('slice_bytes.tz', 'Some 0xaabbcc', 'Pair 1 1', '(Some 0xbb)'), + ('slice_bytes.tz', 'Some 0xaabbcc', 'Pair 1 2', '(Some 0xbbcc)'), + ('slice_bytes.tz', 'Some 0xaabbcc', 'Pair 1 3', 'None'), + ('slice_bytes.tz', 'Some 0xaabbcc', 'Pair 1 1', '(Some 0xbb)'), + + # Identity on pairs + ('pair_id.tz', 'None', '(Pair True False)', + '(Some (Pair True False))'), + ('pair_id.tz', 'None', '(Pair False True)', + '(Some (Pair False True))'), + ('pair_id.tz', 'None', '(Pair True True)', + '(Some (Pair True True))'), + ('pair_id.tz', 'None', '(Pair False False)', + '(Some (Pair False False))'), + + # Tests CAR and CDR instructions + ('car.tz', '0', '(Pair 34 17)', '34'), + ('cdr.tz', '0', '(Pair 34 17)', '17'), + + # Logical not + ('not.tz', 'None', 'True', '(Some False)'), + ('not.tz', 'None', 'False', '(Some True)'), + + # Logical and + ('and.tz', 'None', '(Pair False False)', '(Some False)'), + ('and.tz', 'None', '(Pair False True)', '(Some False)'), + ('and.tz', 'None', '(Pair True False)', '(Some False)'), + ('and.tz', 'None', '(Pair True True)', '(Some True)'), + + # Logical or + ('or.tz', 'None', '(Pair False False)', '(Some False)'), + ('or.tz', 'None', '(Pair False True)', '(Some True)'), + ('or.tz', 'None', '(Pair True False)', '(Some True)'), + ('or.tz', 'None', '(Pair True True)', '(Some True)'), + + # Logical and + ('and_logical_1.tz', 'False', "(Pair False False)", 'False'), + ('and_logical_1.tz', 'False', "(Pair False True)", 'False'), + ('and_logical_1.tz', 'False', "(Pair True False)", 'False'), + ('and_logical_1.tz', 'False', "(Pair True True)", 'True'), + + # Binary and + ('and_binary.tz', 'Unit', 'Unit', 'Unit'), + + + # Binary or + ('or_binary.tz', 'None', '(Pair 4 8)', '(Some 12)'), + ('or_binary.tz', 'None', '(Pair 0 8)', '(Some 8)'), + ('or_binary.tz', 'None', '(Pair 8 0)', '(Some 8)'), + ('or_binary.tz', 'None', '(Pair 15 4)', '(Some 15)'), + ('or_binary.tz', 'None', '(Pair 14 1)', '(Some 15)'), + ('or_binary.tz', 'None', '(Pair 7 7)', '(Some 7)'), + + # Binary not + ('not_binary.tz', 'None', '(Left 0)', '(Some -1)'), + ('not_binary.tz', 'None', '(Left 8)', '(Some -9)'), + ('not_binary.tz', 'None', '(Left 7)', '(Some -8)'), + ('not_binary.tz', 'None', '(Left -9)', '(Some 8)'), + ('not_binary.tz', 'None', '(Left -8)', '(Some 7)'), + + ('not_binary.tz', 'None', '(Right 0)', '(Some -1)'), + ('not_binary.tz', 'None', '(Right 8)', '(Some -9)'), + ('not_binary.tz', 'None', '(Right 7)', '(Some -8)'), + + # XOR + ('xor.tz', 'None', 'Left (Pair False False)', '(Some (Left False))'), + ('xor.tz', 'None', 'Left (Pair False True)', '(Some (Left True))'), + ('xor.tz', 'None', 'Left (Pair True False)', '(Some (Left True))'), + ('xor.tz', 'None', 'Left (Pair True True)', '(Some (Left False))'), + + ('xor.tz', 'None', 'Right (Pair 0 0)', '(Some (Right 0))'), + ('xor.tz', 'None', 'Right (Pair 0 1)', '(Some (Right 1))'), + ('xor.tz', 'None', 'Right (Pair 1 0)', '(Some (Right 1))'), + ('xor.tz', 'None', 'Right (Pair 1 1)', '(Some (Right 0))'), + ('xor.tz', 'None', 'Right (Pair 42 21)', '(Some (Right 63))'), + ('xor.tz', 'None', 'Right (Pair 42 63)', '(Some (Right 21))'), + + # test shifts: LSL & LSR + ('shifts.tz', 'None', '(Left (Pair 8 1))', '(Some 16)'), + ('shifts.tz', 'None', '(Left (Pair 0 0))', '(Some 0)'), + ('shifts.tz', 'None', '(Left (Pair 0 1))', '(Some 0)'), + ('shifts.tz', 'None', '(Left (Pair 1 2))', '(Some 4)'), + ('shifts.tz', 'None', '(Left (Pair 15 2))', '(Some 60)'), + + ('shifts.tz', 'None', '(Right (Pair 8 1))', '(Some 4)'), + ('shifts.tz', 'None', '(Right (Pair 0 0))', '(Some 0)'), + ('shifts.tz', 'None', '(Right (Pair 0 1))', '(Some 0)'), + ('shifts.tz', 'None', '(Right (Pair 1 2))', '(Some 0)'), + ('shifts.tz', 'None', '(Right (Pair 15 2))', '(Some 3)'), + + # Concatenate all strings of a list into one string + ('concat_list.tz', '""', '{ "a" ; "b" ; "c" }', '"abc"'), + ('concat_list.tz', '""', '{}', '""'), + ('concat_list.tz', '""', '{ "Hello" ; " " ; "World" ; "!" }', + '"Hello World!"'), + + # Concatenate the bytes in storage with all bytes in the given list + ('concat_hello_bytes.tz', '{}', '{ 0xcd }', + '{ 0xffcd }'), + ('concat_hello_bytes.tz', '{}', '{}', + '{}'), + ('concat_hello_bytes.tz', '{}', '{ 0xab ; 0xcd }', + '{ 0xffab ; 0xffcd }'), + + # Identity on lists + ('list_id.tz', '{""}', '{ "1" ; "2" ; "3" }', + '{ "1" ; "2" ; "3" }'), + ('list_id.tz', '{""}', '{}', '{}'), + ('list_id.tz', '{""}', '{ "a" ; "b" ; "c" }', + '{ "a" ; "b" ; "c" }'), + + ('list_id_map.tz', '{""}', '{ "1" ; "2" ; "3" }', + '{ "1" ; "2" ; "3" }'), + ('list_id_map.tz', '{""}', '{}', '{}'), + ('list_id_map.tz', '{""}', '{ "a" ; "b" ; "c" }', + '{ "a" ; "b" ; "c" }'), + + + # Identity on maps + ('map_id.tz', '{}', '{ Elt 0 1 }', '{ Elt 0 1 }'), + ('map_id.tz', '{}', '{ Elt 0 0 }', '{ Elt 0 0 }'), + ('map_id.tz', '{}', '{ Elt 0 0 ; Elt 3 4 }', + '{ Elt 0 0 ; Elt 3 4 }'), + + # Memberships in maps + ('map_mem_nat.tz', '(Pair { Elt 0 1 } None)', '1', + '(Pair { Elt 0 1 } (Some False))'), + ('map_mem_nat.tz', '(Pair {} None)', '1', + '(Pair {} (Some False))'), + ('map_mem_nat.tz', '(Pair { Elt 1 0 } None)', '1', + '(Pair { Elt 1 0 } (Some True))'), + ('map_mem_nat.tz', '(Pair { Elt 1 4 ; Elt 2 11 } None)', '1', + '(Pair { Elt 1 4 ; Elt 2 11 } (Some True))'), + ('map_mem_nat.tz', '(Pair { Elt 1 4 ; Elt 2 11 } None)', '2', + '(Pair { Elt 1 4 ; Elt 2 11 } (Some True))'), + ('map_mem_nat.tz', '(Pair { Elt 1 4 ; Elt 2 11 } None)', '3', + '(Pair { Elt 1 4 ; Elt 2 11 } (Some False))'), + + ('map_mem_string.tz', '(Pair { Elt "foo" 1 } None)', '"bar"', + '(Pair { Elt "foo" 1 } (Some False))'), + ('map_mem_string.tz', '(Pair {} None)', '"bar"', + '(Pair {} (Some False))'), + ('map_mem_string.tz', '(Pair { Elt "foo" 0 } None)', '"foo"', + '(Pair { Elt "foo" 0 } (Some True))'), + ('map_mem_string.tz', '(Pair { Elt "bar" 4 ; Elt "foo" 11 } None)', + '"foo"', '(Pair { Elt "bar" 4 ; Elt "foo" 11 } (Some True))'), + ('map_mem_string.tz', '(Pair { Elt "bar" 4 ; Elt "foo" 11 } None)', + '"bar"', '(Pair { Elt "bar" 4 ; Elt "foo" 11 } (Some True))'), + ('map_mem_string.tz', '(Pair { Elt "bar" 4 ; Elt "foo" 11 } None)', + '"baz"', '(Pair { Elt "bar" 4 ; Elt "foo" 11 } (Some False))'), + + # Mapping over maps + ('map_map.tz', '{}', '10', '{}'), + ('map_map.tz', '{ Elt "foo" 1 }', '10', '{ Elt "foo" 11 }'), + ('map_map.tz', '{ Elt "bar" 5 ; Elt "foo" 1 }', '15', + '{ Elt "bar" 20 ; Elt "foo" 16 }'), + + # Memberships in big maps + ('big_map_mem_nat.tz', '(Pair { Elt 0 1 } None)', '1', + '(Pair 0 (Some False))'), + ('big_map_mem_nat.tz', '(Pair {} None)', '1', + '(Pair 0 (Some False))'), + ('big_map_mem_nat.tz', '(Pair { Elt 1 0 } None)', '1', + '(Pair 0 (Some True))'), + ('big_map_mem_nat.tz', '(Pair { Elt 1 4 ; Elt 2 11 } None)', '1', + '(Pair 0 (Some True))'), + ('big_map_mem_nat.tz', '(Pair { Elt 1 4 ; Elt 2 11 } None)', '2', + '(Pair 0 (Some True))'), + ('big_map_mem_nat.tz', '(Pair { Elt 1 4 ; Elt 2 11 } None)', '3', + '(Pair 0 (Some False))'), + + ('big_map_mem_string.tz', + '(Pair { Elt "foo" 1 } None)', '"bar"', + '(Pair 0 (Some False))'), + ('big_map_mem_string.tz', + '(Pair {} None)', '"bar"', + '(Pair 0 (Some False))'), + ('big_map_mem_string.tz', + '(Pair { Elt "foo" 0 } None)', '"foo"', + '(Pair 0 (Some True))'), + ('big_map_mem_string.tz', + '(Pair { Elt "bar" 4 ; Elt "foo" 11 } None)', + '"foo"', '(Pair 0 (Some True))'), + ('big_map_mem_string.tz', + '(Pair { Elt "bar" 4 ; Elt "foo" 11 } None)', + '"bar"', '(Pair 0 (Some True))'), + ('big_map_mem_string.tz', + '(Pair { Elt "bar" 4 ; Elt "foo" 11 } None)', + '"baz"', '(Pair 0 (Some False))'), + + # Memberships in big maps + ('big_map_mem_nat.tz', '(Pair { Elt 0 1 } None)', '1', + '(Pair 0 (Some False))'), + ('big_map_mem_nat.tz', '(Pair {} None)', '1', + '(Pair 0 (Some False))'), + ('big_map_mem_nat.tz', '(Pair { Elt 1 0 } None)', '1', + '(Pair 0 (Some True))'), + ('big_map_mem_nat.tz', '(Pair { Elt 1 4 ; Elt 2 11 } None)', '1', + '(Pair 0 (Some True))'), + ('big_map_mem_nat.tz', '(Pair { Elt 1 4 ; Elt 2 11 } None)', '2', + '(Pair 0 (Some True))'), + ('big_map_mem_nat.tz', '(Pair { Elt 1 4 ; Elt 2 11 } None)', '3', + '(Pair 0 (Some False))'), + + # Identity on sets + ('set_id.tz', '{}', '{ "a" ; "b" ; "c" }', '{ "a" ; "b" ; "c" }'), + ('set_id.tz', '{}', '{}', '{}'), + ('set_id.tz', '{}', '{ "asdf" ; "bcde" }', '{ "asdf" ; "bcde" }'), + + # List concat + ('list_concat.tz', '"abc"', '{ "d" ; "e" ; "f" }', '"abcdef"'), + ('list_concat.tz', '"abc"', '{}', '"abc"'), + + ('list_concat_bytes.tz', '0x00ab', '{ 0xcd ; 0xef ; 0x00 }', + '0x00abcdef00'), + ('list_concat_bytes.tz', '0x', '{ 0x00 ; 0x11 ; 0x00 }', + '0x001100'), + ('list_concat_bytes.tz', '0xabcd', '{}', '0xabcd'), + ('list_concat_bytes.tz', '0x', '{}', '0x'), + + # List iter + ('list_iter.tz', '0', '{ 10 ; 2 ; 1 }', '20'), + ('list_iter.tz', '0', '{ 3 ; 6 ; 9 }', '162'), + + # List size + ('list_size.tz', '111', '{}', '0'), + ('list_size.tz', '111', '{ 1 }', '1'), + ('list_size.tz', '111', '{ 1 ; 2 ; 3 }', '3'), + ('list_size.tz', '111', '{ 1 ; 2 ; 3 ; 4 ; 5 ; 6 }', '6'), + + # Set member -- set is in storage + ('set_member.tz', '(Pair {} None)', '"Hi"', + '(Pair {} (Some False))'), + ('set_member.tz', '(Pair { "Hi" } None)', '"Hi"', + '(Pair { "Hi" } (Some True))'), + ('set_member.tz', '(Pair { "Hello" ; "World" } None)', '""', + '(Pair { "Hello" ; "World" } (Some False))'), + + # Set size + ('set_size.tz', '111', '{}', '0'), + ('set_size.tz', '111', '{ 1 }', '1'), + ('set_size.tz', '111', '{ 1 ; 2 ; 3 }', '3'), + ('set_size.tz', '111', '{ 1 ; 2 ; 3 ; 4 ; 5 ; 6 }', '6'), + + # Set iter + ('set_iter.tz', '111', '{}', '0'), + ('set_iter.tz', '111', '{ 1 }', '1'), + ('set_iter.tz', '111', '{ -100 ; 1 ; 2 ; 3 }', '-94'), + + # Map size + ('map_size.tz', '111', '{}', '0'), + ('map_size.tz', '111', '{ Elt "a" 1 }', '1'), + ('map_size.tz', '111', '{ Elt "a" 1 ; Elt "b" 2 ; Elt "c" 3 }', + '3'), + ('map_size.tz', '111', '{ Elt "a" 1 ; Elt "b" 2 ; Elt "c" 3 ; \ + Elt "d" 4 ; Elt "e" 5 ; Elt "f" 6 }', + '6'), + + # Contains all elements -- does the second list contain + # all of the same elements as the first one? I'm ignoring + # element multiplicity + ('contains_all.tz', 'None', '(Pair {} {})', + '(Some True)'), + ('contains_all.tz', 'None', '(Pair { "a" } { "B" })', + '(Some False)'), + ('contains_all.tz', 'None', '(Pair { "A" } { "B" })', + '(Some False)'), + ('contains_all.tz', 'None', '(Pair { "B" } { "B" })', + '(Some True)'), + ('contains_all.tz', 'None', + '(Pair { "B" ; "C" ; "asdf" } { "B" ; "B" ; "asdf" ; "C" })', + '(Some True)'), + ('contains_all.tz', 'None', + '(Pair { "B" ; "B" ; "asdf" ; "C" } { "B" ; "C" ; "asdf" })', + '(Some True)'), + + # Concatenate the string in storage with all strings in + # the given list + ('concat_hello.tz', '{}', '{ "World!" }', '{ "Hello World!" }'), + ('concat_hello.tz', '{}', '{}', '{}'), + ('concat_hello.tz', '{}', '{ "test1" ; "test2" }', + '{ "Hello test1" ; "Hello test2" }'), + + # Create an empty map and add a string to it + ('empty_map.tz', '{}', 'Unit', '{ Elt "hello" "world" }'), + + # Get the value stored at the given key in the map + ('get_map_value.tz', '(Pair None { Elt "hello" "hi" })', + '"hello"', '(Pair (Some "hi") { Elt "hello" "hi" })'), + ('get_map_value.tz', '(Pair None { Elt "hello" "hi" })', + '""', '(Pair None { Elt "hello" "hi" })'), + ('get_map_value.tz', '(Pair None { Elt "1" "one" ; \ + Elt "2" "two" })', + '"1"', '(Pair (Some "one") { Elt "1" "one" ; Elt "2" "two" })'), + + # Map iter + ('map_iter.tz', '(Pair 0 0)', '{ Elt 0 100 ; Elt 2 100 }', + '(Pair 2 200)'), + ('map_iter.tz', '(Pair 0 0)', '{ Elt 1 1 ; Elt 2 100 }', + '(Pair 3 101)'), + + # Return True if True branch of if was taken and False otherwise + ('if.tz', 'None', 'True', '(Some True)'), + ('if.tz', 'None', 'False', '(Some False)'), + + # Generate a pair of or types + ('left_right.tz', '(Left "X")', '(Left True)', '(Right True)'), + ('left_right.tz', '(Left "X")', '(Right "a")', '(Left "a")'), + + # Reverse a list + ('reverse_loop.tz', '{""}', '{}', '{}'), + ('reverse_loop.tz', '{""}', '{ "c" ; "b" ; "a" }', + '{ "a" ; "b" ; "c" }'), + + # Exec concat contract + ('exec_concat.tz', '"?"', '""', '"_abc"'), + ('exec_concat.tz', '"?"', '"test"', '"test_abc"'), + + # Get the current balance of the contract + ('balance.tz', '111', 'Unit', '4000000000000'), + + # Test addition and subtraction on tez + ('tez_add_sub.tz', 'None', '(Pair 2000000 1000000)', + '(Some (Pair 3000000 1000000))'), + ('tez_add_sub.tz', 'None', '(Pair 2310000 1010000)', + '(Some (Pair 3320000 1300000))'), + + # Test various additions + ('add.tz', 'Unit', 'Unit', 'Unit'), + + # Test ABS + ('abs.tz', 'Unit', '12039123919239192312931', 'Unit'), + ('abs.tz', 'Unit', '0', 'Unit'), + ('abs.tz', 'Unit', '948', 'Unit'), + + # Test INT + ('int.tz', 'None', '0', '(Some 0)'), + ('int.tz', 'None', '1', '(Some 1)'), + ('int.tz', 'None', '9999', '(Some 9999)'), + + # Test DIP + ('dip.tz', '(Pair 0 0)', '(Pair 15 9)', '(Pair 15 24)'), + ('dip.tz', '(Pair 0 0)', '(Pair 1 1)', '(Pair 1 2)'), + + # Test get first element of list + ('first.tz', '111', '{ 1 ; 2 ; 3 ; 4 }', '1'), + ('first.tz', '111', '{ 4 }', '4'), + + # Hash input string + # Test assumed to be correct -- hash is based on encoding of AST + ('hash_string.tz', '0x00', '"abcdefg"', '0x46fdbcb4ea4eadad5615c' + + 'daa17d67f783e01e21149ce2b27de497600b4cd8f4e'), + ('hash_string.tz', '0x00', '"12345"', '0xb4c26c20de52a4eaf0d8a34' + + '0db47ad8cb1e74049570859c9a9a3952b204c772f'), + + # IF_SOME + ('if_some.tz', '"?"', '(Some "hello")', '"hello"'), + ('if_some.tz', '"?"', 'None', '""'), + + # Tests the SET_CAR and SET_CDR instructions + ('set_car.tz', '(Pair "hello" 0)', '"world"', '(Pair "world" 0)'), + ('set_car.tz', '(Pair "hello" 0)', '"abc"', '(Pair "abc" 0)'), + ('set_car.tz', '(Pair "hello" 0)', '""', '(Pair "" 0)'), + + ('set_cdr.tz', '(Pair "hello" 0)', '1', '(Pair "hello" 1)'), + ('set_cdr.tz', '(Pair "hello" 500)', '3', '(Pair "hello" 3)'), + ('set_cdr.tz', '(Pair "hello" 7)', '100', '(Pair "hello" 100)'), + + # Convert a public key to a public key hash + ('hash_key.tz', 'None', + '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"', + '(Some "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx")'), + ('hash_key.tz', 'None', + '"edpkuJqtDcA2m2muMxViSM47MPsGQzmyjnNTawUPqR8vZTAMcx61ES"', + '(Some "tz1XPTDmvT3vVE5Uunngmixm7gj7zmdbPq6k")'), + + # Test timestamp operations + ('add_timestamp_delta.tz', 'None', + '(Pair 100 100)', '(Some "1970-01-01T00:03:20Z")'), + ('add_timestamp_delta.tz', 'None', + '(Pair 100 -100)', '(Some "1970-01-01T00:00:00Z")'), + ('add_timestamp_delta.tz', 'None', + '(Pair "1970-01-01T00:00:00Z" 0)', + '(Some "1970-01-01T00:00:00Z")'), + + ('add_delta_timestamp.tz', 'None', + '(Pair 100 100)', '(Some "1970-01-01T00:03:20Z")'), + ('add_delta_timestamp.tz', 'None', + '(Pair -100 100)', '(Some "1970-01-01T00:00:00Z")'), + ('add_delta_timestamp.tz', 'None', + '(Pair 0 "1970-01-01T00:00:00Z")', + '(Some "1970-01-01T00:00:00Z")'), + + ('sub_timestamp_delta.tz', '111', '(Pair 100 100)', + '"1970-01-01T00:00:00Z"'), + ('sub_timestamp_delta.tz', '111', '(Pair 100 -100)', + '"1970-01-01T00:03:20Z"'), + ('sub_timestamp_delta.tz', '111', '(Pair 100 2000000000000000000)', + '-1999999999999999900'), + + ('diff_timestamps.tz', '111', '(Pair 0 0)', '0'), + ('diff_timestamps.tz', '111', '(Pair 0 1)', '-1'), + ('diff_timestamps.tz', '111', '(Pair 1 0)', '1'), + ('diff_timestamps.tz', '111', + '(Pair "1970-01-01T00:03:20Z" "1970-01-01T00:00:00Z")', '200'), + + # Test pack/unpack + ('packunpack_rev.tz', 'Unit', + '(Pair -1 (Pair 1 (Pair "foobar" (Pair 0x00AABBCC (Pair 1000 ' + + '(Pair False (Pair "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" ' + + '(Pair "2019-09-09T08:35:33Z" ' + + '"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5"))))))))', 'Unit'), + + ('packunpack_rev.tz', 'Unit', + '(Pair -1 (Pair 1 (Pair "foobar" (Pair 0x00AABBCC (Pair 1000 ' + + '(Pair False (Pair "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5" ' + + '(Pair "2019-09-09T08:35:33Z" ' + + '"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5"))))))))', 'Unit'), + + ('packunpack_rev_cty.tz', 'Unit', + '(Pair "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9' + + 'sDVC9yav" (Pair Unit (Pair "edsigthTzJ8X7MPmNeEwybRAv' + + 'dxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8' + + 'V2w8ayB5dMJzrYCHhD8C7" (Pair (Some "edsigthTzJ8X7MPmN' + + 'eEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5' + + 'CwoNgqs8V2w8ayB5dMJzrYCHhD8C7") (Pair { Unit } (Pair' + + ' { True } (Pair (Pair 19 10) (Pair (Left "tz1cxcwwnz' + + 'ENRdhe2Kb8ZdTrdNy4bFNyScx5") (Pair { Elt 0 "foo" ; El' + + 't 1 "bar" } { PACK } )))))))))', + 'Unit'), + + ('packunpack_rev_cty.tz', 'Unit', + '(Pair "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9' + + 'sDVC9yav" (Pair Unit (Pair "edsigthTzJ8X7MPmNeEwybRAv' + + 'dxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8' + + 'V2w8ayB5dMJzrYCHhD8C7" (Pair None (Pair { } (Pair {' + + ' } (Pair (Pair 40 -10) (Pair (Right "2019-09-09T08:' + + '35:33Z") (Pair { } { DUP ; DROP ; PACK } )))))))))', + 'Unit'), + + # Test EDIV on nat and int + ('ediv.tz', + '(Pair None (Pair None (Pair None None)))', + '(Pair 10 -3)', + '(Pair (Some (Pair -3 1)) (Pair (Some (Pair 3 1)) ' + + '(Pair (Some (Pair -3 1)) (Some (Pair 3 1)))))'), + ('ediv.tz', + '(Pair None (Pair None (Pair None None)))', + '(Pair 10 0)', + '(Pair None (Pair None (Pair None None)))'), + ('ediv.tz', + '(Pair None (Pair None (Pair None None)))', + '(Pair -8 2)', + '(Pair (Some (Pair -4 0)) (Pair (Some (Pair -4 0)) ' + + '(Pair (Some (Pair 4 0)) (Some (Pair 4 0)))))'), + + # Test EDIV on mutez + ('ediv_mutez.tz', '(Left None)', '(Pair 10 (Left 10))', '(Left (Some (Pair 1 0)))'), + ('ediv_mutez.tz', '(Left None)', '(Pair 10 (Left 3))', '(Left (Some (Pair 3 1)))'), + ('ediv_mutez.tz', '(Left None)', '(Pair 10 (Left 0))', '(Left None)'), + + ('ediv_mutez.tz', '(Left None)', '(Pair 10 (Right 10))', '(Right (Some (Pair 1 0)))'), + ('ediv_mutez.tz', '(Left None)', '(Pair 10 (Right 3))', '(Right (Some (Pair 3 1)))'), + ('ediv_mutez.tz', '(Left None)', '(Pair 10 (Right 0))', '(Right None)'), + ('ediv_mutez.tz', '(Left None)', '(Pair 5 (Right 10))', '(Right (Some (Pair 0 5)))'), + + # Test compare + ('compare.tz', 'Unit', 'Unit', 'Unit'), + + # Test comparison combinators: + # GT, GE, LT, LE, NEQ, EQ + + ('comparisons.tz', '{}', + '{ -9999999; -1 ; 0 ; 1 ; 9999999 }', + '{ ' + + '{ False ; False ; False ; True ; True } ;' "\n" + ' { False ; False ; True ; True ; True } ;' "\n" + ' { True ; True ; False ; False ; False } ;' "\n" + ' { True ; True ; True ; False ; False } ;' "\n" + ' { True ; True ; False ; True ; True } ;' "\n" + ' { False ; False ; True ; False ; False }' + ' }'), + + # Test ADDRESS + ('address.tz', 'None', '"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5"', + '(Some "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5")'), + + # Test (CONTRACT unit) + ('contract.tz', 'Unit', '"tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5"', + 'Unit'), + + # Test create_contract + ('create_contract.tz', 'None', 'Unit', '(Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm")'), + + # Test multiplication - success case (no overflow) + # Failure case is tested in m̀ul_overflow.tz + ('mul.tz', 'Unit', 'Unit', 'Unit'), + + # Test NEG + ('neg.tz', '0', '(Left 2)', '-2'), + ('neg.tz', '0', '(Right 2)', '-2'), + ('neg.tz', '0', '(Left 0)', '0'), + ('neg.tz', '0', '(Right 0)', '0'), + ('neg.tz', '0', '(Left -2)', '2'), + + # Test DIGN, DUGN, DROPN, DIPN + ('dign.tz','0', '(Pair (Pair (Pair (Pair 1 2) 3) 4) 5)', '5'), + ('dugn.tz', '0', '(Pair (Pair (Pair (Pair 1 2) 3) 4) 5)', '1'), + ('dropn.tz','0', '(Pair (Pair (Pair (Pair 1 2) 3) 4) 5)', '5'), + ('dipn.tz', '0', '(Pair (Pair (Pair (Pair 1 2) 3) 4) 5)', '6'), + + # Test DIGN 17 times. + ('dig_eq.tz', + 'Unit', + '(Pair 17 (Pair 16 (Pair 15 (Pair 14 (Pair 13 (Pair 12' + + ' (Pair 11 (Pair 10 (Pair 9 (Pair 8 (Pair 7 (Pair 6 (P' + + 'air 5 (Pair 4 (Pair 3 (Pair 2 1))))))))))))))))', + 'Unit'), + ('dig_eq.tz', + 'Unit', + '(Pair 2 (Pair 3 (Pair 12 (Pair 16 (Pair 10 (Pair 14 (' + + 'Pair 19 (Pair 9 (Pair 18 (Pair 6 (Pair 8 (Pair 11 (Pa' + + 'ir 4 (Pair 13 (Pair 15 (Pair 5 1))))))))))))))))', + 'Unit'), + + # Test Partial Exec + ('pexec.tz', '14', '38', '52'), + ('pexec_2.tz', "{ 0 ; 1 ; 2 ; 3}", '4', "{ 0 ; 7 ; 14 ; 21 }"), + + # Test CHAIN_ID + ('chain_id_store.tz', 'None', 'Unit', '(Some 0x7a06a770)') + ]) + def test_contract_input_output(self, + client, + contract, + param, + storage, + expected): + if contract.endswith('.tz'): + contract = f'{CONTRACT_PATH}/{contract}' + run_script_res = client.run_script(contract, param, storage) + assert run_script_res.storage == expected + + @pytest.mark.parametrize( + "contract,param,storage,expected,big_map_diff", + [ # FORMAT: assert_output contract_file storage input expected_result + # expected_diffs + + # Get the value stored at the given key in the big map + ('get_big_map_value.tz', '(Pair { Elt "hello" "hi" } None)', + '"hello"', '(Pair 0 (Some "hi"))', + [["New map(0) of type (big_map string string)"], + ['Set map(0)["hello"] to "hi"']]), + ('get_big_map_value.tz', '(Pair { Elt "hello" "hi" } None)', '""', + '(Pair 0 None)', + [["New map(0) of type (big_map string string)"], + ['Set map(0)["hello"] to "hi"']]), + ('get_big_map_value.tz', + '(Pair { Elt "1" "one" ; Elt "2" "two" } None)', + '"1"', + '(Pair 0 (Some "one"))', + [["New map(0) of type (big_map string string)"], + ['Set map(0)["1"] to "one"'], + ['Set map(0)["2"] to "two"']]), + + # Test updating big maps + ('update_big_map.tz', + '(Pair { Elt "1" "one" ; Elt "2" "two" } Unit)', + '{}', '(Pair 0 Unit)', + [["New map(0) of type (big_map string string)"], + ['Set map(0)["1"] to "one"'], + ['Set map(0)["2"] to "two"']]), + ('update_big_map.tz', + '(Pair { Elt "1" "one" ; Elt "2" "two" } Unit)', + '{ Elt "1" (Some "two") }', '(Pair 0 Unit)', + [["New map(0) of type (big_map string string)"], + ['Set map(0)["1"] to "two"'], + ['Set map(0)["2"] to "two"']]), + ('update_big_map.tz', + '(Pair { Elt "1" "one" ; Elt "2" "two" } Unit)', + '{ Elt "3" (Some "three") }', '(Pair 0 Unit)', + [["New map(0) of type (big_map string string)"], + ['Set map(0)["1"] to "one"'], + ['Set map(0)["2"] to "two"'], + ['Set map(0)["3"] to "three"']]), + ('update_big_map.tz', + '(Pair { Elt "1" "one" ; Elt "2" "two" } Unit)', + '{ Elt "3" None }', '(Pair 0 Unit)', + [["New map(0) of type (big_map string string)"], + ['Set map(0)["1"] to "one"'], + ['Set map(0)["2"] to "two"'], + ['Unset map(0)["3"]']]), + ('update_big_map.tz', + '(Pair { Elt "1" "one" ; Elt "2" "two" } Unit)', + '{ Elt "2" None }', '(Pair 0 Unit)', + [["New map(0) of type (big_map string string)"], + ['Set map(0)["1"] to "one"'], + ['Unset map(0)["2"]']]), + ('update_big_map.tz', + '(Pair { Elt "1" "one" ; Elt "2" "two" } Unit)', + '{ Elt "1" (Some "two") }', '(Pair 0 Unit)', + [["New map(0) of type (big_map string string)"], + ['Set map(0)["1"] to "two"'], + ['Set map(0)["2"] to "two"']]) + ]) + def test__big_map_contract_io(self, + client, + contract, + param, + storage, + expected, + big_map_diff): + contract = f'{CONTRACT_PATH}/{contract}' + run_script_res = client.run_script(contract, param, storage) + assert run_script_res.storage == expected + assert run_script_res.big_map_diff == big_map_diff + + @pytest.mark.parametrize( + "param,storage,expected,big_map_diff", + [ # test swap + ('(Left (Pair { Elt "1" "one" } { Elt "2" "two" }))', + '(Left Unit)', + '(Left (Pair 0 1))', + [ ['New map(1) of type (big_map string string)'], + ['Set map(1)["1"] to "one"'], + ['New map(0) of type (big_map string string)'], + ['Set map(0)["2"] to "two"'] ]), + # test reset with new map + ('(Left (Pair { Elt "1" "one" } { Elt "2" "two" }))', + '(Right (Left (Left (Pair { Elt "3" "three" } { Elt "4" "four" }))))', + '(Left (Pair 0 1))', + [ ['New map(1) of type (big_map string string)'], + ['Set map(1)["4"] to "four"'], + ['New map(0) of type (big_map string string)'], + ['Set map(0)["3"] to "three"'] ]), + # test reset to unit + ('(Left (Pair { Elt "1" "one" } { Elt "2" "two" }))', + '(Right (Left (Right Unit)))', + '(Right Unit)', + [ ['\n'] ] ), + # test import to big_map + ('(Right Unit)', + '(Right (Right (Left (Pair { Pair "foo" "bar" } { Pair "gaz" "baz" }) )))', + '(Left (Pair 0 1))', + [ ['New map(1) of type (big_map string string)'], + ['Set map(1)["gaz"] to "baz"'], + ['New map(0) of type (big_map string string)'], + ['Set map(0)["foo"] to "bar"'] ]), + # test add to big_map + ('(Left (Pair { Elt "1" "one" } { Elt "2" "two" }) )', + '(Right (Right (Right (Left { Pair "3" "three" }))))', + '(Left (Pair 0 1))', + [ ['New map(1) of type (big_map string string)'], + ['Set map(1)["2"] to "two"'], + ['New map(0) of type (big_map string string)'], + ['Set map(0)["1"] to "one"'], + ['Set map(0)["3"] to "three"'] ]), + # test remove from big_map + ('(Left (Pair { Elt "1" "one" } { Elt "2" "two" }))', + '(Right (Right (Right (Right { "1" }))))', + '(Left (Pair 0 1))', + [ ['New map(1) of type (big_map string string)'], + ['Set map(1)["2"] to "two"'], + ['New map(0) of type (big_map string string)'], + ['Unset map(0)["1"]'] ]) + ]) + def test_big_map_magic(self, + client, + param, + storage, + expected, + big_map_diff): + contract = f'{paths.TEZOS_HOME}/src/bin_client/test/' + \ + 'contracts/mini_scenarios/big_map_magic.tz' + run_script_res = client.run_script(contract, param, storage) + assert run_script_res.storage == expected + assert run_script_res.big_map_diff == big_map_diff + + def test_packunpack(self, client): + """Test PACK/UNPACK and binary format.""" + assert_run_script_success( + client, + f'{CONTRACT_PATH}/packunpack.tz', + 'Unit', + '(Pair (Pair (Pair "toto" {3;7;9;1}) {1;2;3}) ' + + '0x05070707070100000004746f746f020000000800030' + + '007000900010200000006000100020003)' + ) + assert_run_script_failwith( + client, + f'{CONTRACT_PATH}/packunpack.tz', + 'Unit', + '(Pair (Pair (Pair "toto" {3;7;9;1}) {1;2;3}) ' + + '0x05070707070100000004746f746f020000000800030' + + '0070009000102000000060001000200030004)' + ) + + def test_check_signature(self, client): + sig = 'edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZA' \ + + 'e7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7' + assert_run_script_success( + client, + f'{CONTRACT_PATH}/check_signature.tz', + f'(Pair "{sig}" "hello")', + '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"' + ) + assert_run_script_failwith( + client, + f'{CONTRACT_PATH}/check_signature.tz', + f'(Pair "{sig}" "abcd")', + '"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"' + ) + + def test_store_input(self, client): + client.transfer(1000, "bootstrap1", KEY1, ['--burn-cap', '0.257']) + bake(client) + + client.transfer(2000, "bootstrap1", KEY2, ['--burn-cap', '0.257']) + bake(client) + + assert_balance(client, KEY1, 1000) + assert_balance(client, KEY2, 2000) + + # Create a contract and transfer 100 ꜩ to it + init_with_transfer(client, f'{CONTRACT_PATH}/store_input.tz', + '""', 100, 'bootstrap1') + + client.transfer(100, "bootstrap1", "store_input", + ["-arg", '"abcdefg"', '--burn-cap', '10']) + bake(client) + + assert_balance(client, "store_input", 200) + + assert_storage_contains(client, "store_input", '"abcdefg"') + + client.transfer(100, "bootstrap1", "store_input", + ["-arg", '"xyz"', '--burn-cap', '10']) + bake(client) + + assert_storage_contains(client, "store_input", '"xyz"') + + def test_transfer_amount(self, client): + init_with_transfer(client, + f'{CONTRACT_PATH}/transfer_amount.tz', + '0', 100, 'bootstrap1') + + client.transfer(500, "bootstrap1", 'transfer_amount', + ['-arg', 'Unit', '--burn-cap', '10']) + bake(client) + + assert_storage_contains(client, "transfer_amount", '500000000') + + def test_now(self, client): + init_with_transfer(client, + f'{CONTRACT_PATH}/store_now.tz', + '"2017-07-13T09:19:01Z"', 100, 'bootstrap1') + + client.transfer(500, "bootstrap1", 'store_now', + ['-arg', 'Unit', '--burn-cap', '10']) + bake(client) + + assert_storage_contains(client, 'store_now', + f'"{client.get_now()}"') + + def test_transfer_tokens(self, client): + """Tests TRANSFER_TOKENS.""" + client.originate('test_transfer_account1', + 100, + 'bootstrap1', + f'{CONTRACT_PATH}/noop.tz', + ['--burn-cap', '10']) + bake(client) + + client.originate('test_transfer_account2', + 20, + 'bootstrap1', + f'{CONTRACT_PATH}/noop.tz', + ['--burn-cap', '10']) + bake(client) + + init_with_transfer(client, f'{CONTRACT_PATH}/transfer_tokens.tz', + 'Unit', 1000, 'bootstrap1') + + assert_balance(client, 'test_transfer_account1', 100) + + account1_addr = client.get_contract_address('test_transfer_account1') + client.transfer(100, 'bootstrap1', 'transfer_tokens', + ['-arg', f'"{account1_addr}"', '--burn-cap', '10']) + bake(client) + + # Why isn't this 200 ꜩ? Baking fee? + assert_balance(client, 'test_transfer_account1', 200) + + account2_addr = client.get_contract_address('test_transfer_account2') + client.transfer(100, 'bootstrap1', 'transfer_tokens', + ['-arg', f'"{account2_addr}"', '--burn-cap', '10']) + bake(client) + + assert_balance(client, 'test_transfer_account2', 120) + + def test_self(self, client): + init_with_transfer(client, f'{CONTRACT_PATH}/self.tz', + '"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"', + 1000, 'bootstrap1') + + client.transfer(0, 'bootstrap1', 'self', ['--burn-cap', '10']) + bake(client) + + self_addr = client.get_contract_address('self') + assert_storage_contains(client, 'self', f'"{self_addr}"') + + def test_contract_fails(self, client): + init_with_transfer(client, f'{CONTRACT_PATH}/contract.tz', + 'Unit', + 1000, 'bootstrap1') + + client.transfer(0, 'bootstrap1', 'self', ['--burn-cap', '10']) + bake(client) + addr = client.get_contract_address('contract') + def cmd(): + client.transfer( + 0, 'bootstrap1', 'contract', + ['-arg', f'"{addr}"', '--burn-cap', '10']) + + assert check_run_failure(cmd, r'script reached FAILWITH instruction') + + def test_init_proxy(self, client): + init_with_transfer(client, + f'{CONTRACT_PATH}/proxy.tz', + 'Unit', + 1000, 'bootstrap1') + + def test_source(self, client): + init_store = IDENTITIES['bootstrap4']['identity'] + init_with_transfer(client, + f'{CONTRACT_PATH}/source.tz', + f'"{init_store}"', + 1000, 'bootstrap1') + + # direct transfer to the contract + client.transfer(0, 'bootstrap2', 'source', ['--burn-cap', '10']) + bake(client) + + source_addr = IDENTITIES['bootstrap2']['identity'] + assert_storage_contains(client, 'source', f'"{source_addr}"') + + + # indirect transfer to the contract through proxy + contract_addr = client.get_contract_address('source') + client.transfer(0, 'bootstrap2', 'proxy', + ['--burn-cap', '10', '--arg', f'"{contract_addr}"']) + bake(client) + assert_storage_contains(client, 'source', f'"{source_addr}"') + + def test_sender(self, client): + init_store = IDENTITIES['bootstrap4']['identity'] + init_with_transfer(client, + f'{CONTRACT_PATH}/sender.tz', + f'"{init_store}"', + 1000, 'bootstrap1') + + # direct transfer to the contract + client.transfer(0, 'bootstrap2', 'sender', ['--burn-cap', '10']) + bake(client) + + sender_addr = IDENTITIES['bootstrap2']['identity'] + assert_storage_contains(client, 'sender', f'"{sender_addr}"') + + + # indirect transfer to the contract through proxy + contract_addr = client.get_contract_address('sender') + proxy_addr = client.get_contract_address('proxy') + client.transfer(0, 'bootstrap2', 'proxy', + ['--burn-cap', '10', '--arg', f'"{contract_addr}"']) + bake(client) + assert_storage_contains(client, 'sender', f'"{proxy_addr}"') + + def test_slice(self, client): + init_with_transfer( + client, f'{CONTRACT_PATH}/slices.tz', + '"sppk7dBPqMPjDjXgKbb5f7V3PuKUrA4Zuwc3c3H7XqQerqPUWbK7Hna"', + 1000, 'bootstrap1') + + @pytest.mark.parametrize('contract_arg', + [line.rstrip('\n') + for line + in open(f'{paths.TEZOS_HOME}/tests_python/tests/' + + 'test_slice_fails_params.txt')]) + def test_slice_fails(self, client, contract_arg): + def cmd(): + client.transfer( + 0, 'bootstrap1', 'slices', + ['-arg', contract_arg, '--burn-cap', '10']) + + assert check_run_failure(cmd, r'script reached FAILWITH instruction') + # bake(client) + + @pytest.mark.parametrize('contract_arg', + [line.rstrip('\n') + for line + in open(f'{paths.TEZOS_HOME}/tests_python/tests/' + + 'test_slice_success_params.txt')]) + def test_slice_success(self, client, contract_arg): + client.transfer(0, 'bootstrap1', 'slices', + ['-arg', contract_arg, '--burn-cap', '10']) + bake(client) + + def test_split_string(self, client): + init_with_transfer(client, f'{CONTRACT_PATH}/split_string.tz', + '{}', + 1000, 'bootstrap1') + + client.transfer(0, 'bootstrap1', 'split_string', + ['-arg', '"abc"', '--burn-cap', '10']) + bake(client) + assert_storage_contains(client, 'split_string', + '{ "a" ; "b" ; "c" }') + + client.transfer(0, 'bootstrap1', 'split_string', + ['-arg', '"def"', '--burn-cap', '10']) + bake(client) + assert_storage_contains(client, 'split_string', + '{ "a" ; "b" ; "c" ; "d" ; "e" ; "f" }') + + def test_split_bytes(self, client): + init_with_transfer(client, f'{CONTRACT_PATH}/split_bytes.tz', + '{}', + 1000, 'bootstrap1') + + client.transfer(0, 'bootstrap1', 'split_bytes', + ['-arg', '0xaabbcc', '--burn-cap', '10']) + bake(client) + assert_storage_contains(client, 'split_bytes', + '{ 0xaa ; 0xbb ; 0xcc }') + + client.transfer(0, 'bootstrap1', 'split_bytes', + ['-arg', '0xddeeff', '--burn-cap', '10']) + bake(client) + assert_storage_contains(client, 'split_bytes', + '{ 0xaa ; 0xbb ; 0xcc ; 0xdd ; 0xee ; 0xff }') + + def test_hash_consistency_michelson_cli(self, client): + hash_result = client.get_hash_data( + '(Pair 22220000000 (Pair "2017-12-13T04:49:00Z" 034))', + '(pair mutez (pair timestamp int))').raw_hash + hash_contract = f'{CONTRACT_PATH}/hash_consistency_checker.tz' + run_script_res = client.run_script( + hash_contract, '0x00', + '(Pair 22220000000 (Pair "2017-12-13T04:49:00Z" 034))') + assert run_script_res.storage == hash_result + run_script_res = client.run_script( + hash_contract, '0x00', + '(Pair 22220000000 (Pair "2017-12-13T04:49:00Z" 034))') + assert run_script_res.storage == hash_result + + @pytest.mark.parametrize( + "contract,param,storage", + [ # FORMAT: assert_output contract_file storage input + + # Test overflow in shift + ('shifts.tz', 'None', '(Left (Pair 1 257))'), + ('shifts.tz', 'None', '(Left (Pair 123 257))'), + ('shifts.tz', 'None', '(Right (Pair 1 257))'), + ('shifts.tz', 'None', '(Right (Pair 123 257))'), + ('mul_overflow.tz', 'Unit', 'Left Unit'), + ('mul_overflow.tz', 'Unit', 'Right Unit') + ]) + def test_arithmetic_overflow(self, + client, + contract, + param, + storage): + contract = f'{CONTRACT_PATH}/{contract}' + + def cmd(): + client.run_script(contract, param, storage) + assert check_run_failure(cmd, r'unexpected arithmetic overflow') + + def test_set_delegate(self, client): + init_with_transfer(client, f'{CONTRACT_PATH}/set_delegate.tz', + 'Unit', 1000, 'bootstrap1') + bake(client) + + assert client.get_delegate('set_delegate').delegate is None + + addr = IDENTITIES['bootstrap5']['identity'] + client.transfer(0, 'bootstrap1', 'set_delegate', + ['-arg', f'(Some "{addr}")']) + bake(client) + + assert client.get_delegate('set_delegate').delegate == addr + + client.transfer(0, 'bootstrap1', 'set_delegate', + ['-arg', f'None']) + bake(client) + + assert client.get_delegate('set_delegate').delegate is None + + @pytest.mark.skip(reason="Bug in annotation system") + def test_fails_annotated_set_car_cdr(self, client): + """Tests the SET_CAR and SET_CDR instructions.""" + def cmd(): + client.run_script(f'{CONTRACT_PATH}/set_car.tz', + '(Pair %wrong %field "hello" 0)', + '""') + assert check_run_failure(cmd, r'The two annotations do not match') + + + +def assert_storage_contains(client: Client, + contract: str, + expected_storage: str) -> None: + actual_storage = client.get_script_storage(contract) + assert actual_storage == expected_storage + + +def contract_name_of_file(contract_path: str) -> str: + return os.path.splitext(os.path.basename(contract_path))[0] + + +def bake(client: Client) -> BakeForResult: + return client.bake('bootstrap1', + ['--max-priority', '512', + '--minimal-timestamp', + '--minimal-fees', '0', + '--minimal-nanotez-per-byte', '0', + '--minimal-nanotez-per-gas-unit', '0']) + + +def init_with_transfer(client: Client, + contract: str, + initial_storage: str, + amount: float, + sender: str): + client.originate(contract_name_of_file(contract), amount, + sender, contract, + ['-init', initial_storage, '--burn-cap', '10']) + bake(client) + + +def assert_balance(client: Client, + account: str, + expected_balance: float) -> None: + actual_balance = client.get_balance(account) + assert actual_balance == expected_balance + + +def assert_run_script_success(client: Client, + contract: str, + param: str, + storage: str) -> RunScriptResult: + return client.run_script(contract, param, storage) + + +def assert_run_script_failwith(client: Client, + contract: str, + param: str, + storage: str) -> None: + def cmd(): + client.run_script(contract, param, storage) + + assert check_run_failure(cmd, r'script reached FAILWITH instruction') diff --git a/tests_python/tests/test_fork.py b/tests_python/tests/test_fork.py index 6e40c3c9b11d1d52c27416820e43392c8fbf4fbf..577871aceb2412674e47a46388de03da6e8f941b 100644 --- a/tests_python/tests/test_fork.py +++ b/tests_python/tests/test_fork.py @@ -33,23 +33,15 @@ class TestFork: """Client 0 bakes block A at level 2, not communicated to 1 and 2""" sandbox.client(0).bake('bootstrap1', BAKE_ARGS) - def test_endorse_node_0(self, sandbox, session): - """bootstrap1 builds an endorsement for block A""" - client = sandbox.client(0) - client.endorse('bootstrap1') - mempool = client.get_mempool() - endorsement = mempool['applied'][0] - session['endorsement1'] = endorsement - def test_bake_node_0_again(self, sandbox): - """Client 0 bakes block A' at level 3, not communicated to 1 and 2""" + """Client 0 bakes block A' at level 3 & 4, not communicated to 1 and 2""" + sandbox.client(0).bake('bootstrap1', BAKE_ARGS) sandbox.client(0).bake('bootstrap1', BAKE_ARGS) def test_first_branch(self, sandbox, session): head = sandbox.client(0).get_head() - assert head['header']['level'] == 3 + assert head['header']['level'] == 4 session['hash1'] = head['hash'] - assert len(head['operations'][0]) == 1 def test_terminate_node_0(self, sandbox): sandbox.node(0).terminate() diff --git a/tests_python/tests/test_multinode_snapshot.py b/tests_python/tests/test_multinode_snapshot.py index b8ae3723ab44c3c079f5a03352ab5d43bfca329a..6d2a511c0812db2c576cd119cec9c15dc2d6f663 100644 --- a/tests_python/tests/test_multinode_snapshot.py +++ b/tests_python/tests/test_multinode_snapshot.py @@ -25,6 +25,7 @@ class TestMultiNodeSnapshot: def test_bake_group1_level_a(self, sandbox): for _ in range(LEVEL_A - 1): sandbox.client(GROUP1[0]).bake('bootstrap1', BAKE_ARGS) + sandbox.client(GROUP1[0]).endorse('bootstrap2') def test_group1_level_a(self, sandbox, session): for i in GROUP1: @@ -57,6 +58,7 @@ class TestMultiNodeSnapshot: def test_bake_group2_level_b(self, sandbox): for _ in range(LEVEL_B - LEVEL_A): sandbox.client(GROUP2[0]).bake('bootstrap1', BAKE_ARGS) + sandbox.client(GROUP2[0]).endorse('bootstrap2') def test_all_level_c(self, sandbox): for client in sandbox.all_clients(): diff --git a/tests_python/tests/test_slice_fails_params.txt b/tests_python/tests/test_slice_fails_params.txt new file mode 100644 index 0000000000000000000000000000000000000000..7241bd22aff35f4c48ef00a059b8a0968f78556b --- /dev/null +++ b/tests_python/tests/test_slice_fails_params.txt @@ -0,0 +1,5 @@ +(Pair 0xe009ab79e8b84ef0e55c43a9a857214d8761e67b75ba63500a5694fb2ffe174acc2de22d01ccb7259342437f05e1987949f0ad82e9f32e9a0b79cb252d7f7b8236ad728893f4e7150742eefdbeda254970f9fcd92c6228c178e1a923e5600758eb83f2a05edd0be7625657901f2ba81eaf145d003dbef78e33f43a32a3788bdf0501000000085341554349535345 "p2sigsceCzcDw2AeYDzUonj4JT341WC9Px4wdhHBxbZcG1FhfqFVuG7f2fGCzrEHSAZgrsrQWpxduDPk9qZRgrpzwJnSHC3gZJ") +(Pair 0xeaa9ab79e8b84ef0e55c43a9a857214d8761e67b75ba63500a5694fb2ffe174acc2de22d01ccb7259342437f05e1987949f0ad82e9f32e9a0b79cb252d7f7b8236ad728893f4e7150742eefdbeda254970f9fcd92c6228c178e1a923e5600758eb83f2a05edd0be7625657901f2ba81eaf145d003dbef78e33f43a32a3788bdf0501000000085341554349535345 "spsig1PPUFZucuAQybs5wsqsNQ68QNgFaBnVKMFaoZZfi1BtNnuCAWnmL9wVy5HfHkR6AeodjVGxpBVVSYcJKyMURn6K1yknYLm") +(Pair 0xe009ab79e8b84ef0e55c43a9a857214d8761e67b75ba63500a5694fb2ffe174acc2deaad01ccb7259342437f05e1987949f0ad82e9f32e9a0b79cb252d7f7b8236ad728893f4e7150742eefdbeda254970f9fcd92c6228c178e1a923e5600758eb83f2a05edd0be7625657901f2ba81eaf145d003dbef78e33f43a32a3788bdf0501000000085341554349535345 "spsig1PPUFZucuAQybs5wsqsNQ68QNgFaBnVKMFaoZZfi1BtNnuCAWnmL9wVy5HfHkR6AeodjVGxpBVVSYcJKyMURn6K1yknYLm") +(Pair 0xe009ab79e8b84ef0e55c43a9a857214d8761e67b75ba63500a5694fb2ffe174acc2de22d01ccb7259342437f05e1987949f0ad82e9f32e9a0b79cb252d7f7b8236ad728893f4e7150733eefdbeda254970f9fcd92c6228c178e1a923e5600758eb83f2a05edd0be7625657901f2ba81eaf145d003dbef78e33f43a32a3788bdf0501000000085341554349535345 "spsig1PPUFZucuAQybs5wsqsNQ68QNgFaBnVKMFaoZZfi1BtNnuCAWnmL9wVy5HfHkR6AeodjVGxpBVVSYcJKyMURn6K1yknYLm") +(Pair 0xe009ab79e8b84ef0 "spsig1PPUFZucuAQybs5wsqsNQ68QNgFaBnVKMFaoZZfi1BtNnuCAWnmL9wVy5HfHkR6AeodjVGxpBVVSYcJKyMURn6K1yknYLm") diff --git a/tests_python/tests/test_slice_success_params.txt b/tests_python/tests/test_slice_success_params.txt new file mode 100644 index 0000000000000000000000000000000000000000..8c0d89bd81420ef39e1218e19b6475b23ff46444 --- /dev/null +++ b/tests_python/tests/test_slice_success_params.txt @@ -0,0 +1 @@ +(Pair 0xe009ab79e8b84ef0e55c43a9a857214d8761e67b75ba63500a5694fb2ffe174acc2de22d01ccb7259342437f05e1987949f0ad82e9f32e9a0b79cb252d7f7b8236ad728893f4e7150742eefdbeda254970f9fcd92c6228c178e1a923e5600758eb83f2a05edd0be7625657901f2ba81eaf145d003dbef78e33f43a32a3788bdf0501000000085341554349535345 "spsig1PPUFZucuAQybs5wsqsNQ68QNgFaBnVKMFaoZZfi1BtNnuCAWnmL9wVy5HfHkR6AeodjVGxpBVVSYcJKyMURn6K1yknYLm") diff --git a/tests_python/tools/constants.py b/tests_python/tools/constants.py index ca5d7e65b6b4fbf0b501bbc77bc1b060bf84ed4d..53840647327cafc92b2e5a5af26a42c8025062b9 100644 --- a/tests_python/tools/constants.py +++ b/tests_python/tools/constants.py @@ -27,12 +27,32 @@ COMMITMENTS = [ PARAMETERS = { "bootstrap_accounts": BOOTSTRAP_ACCOUNTS, "commitments": COMMITMENTS, + "preserved_cycles": 2, + "blocks_per_cycle": 8, + "blocks_per_commitment": 4, + "blocks_per_roll_snapshot": 4, + "blocks_per_voting_period": 64, "time_between_blocks": ["1", "0"], - "blocks_per_cycle": 128, - "blocks_per_roll_snapshot": 32, - "blocks_per_voting_period": 16, - "preserved_cycles": 1, - "proof_of_work_threshold": "-1" + "endorsers_per_block": 32, + "hard_gas_limit_per_operation": "800000", + "hard_gas_limit_per_block": "8000000", + "proof_of_work_threshold": "-1", + "tokens_per_roll": "8000000000", + "michelson_maximum_type_size": 1000, + "seed_nonce_revelation_tip": "125000", + "origination_size": 257, + "block_security_deposit": "512000000", + "endorsement_security_deposit": "64000000", + "block_reward": "16000000", + "endorsement_reward": "2000000", + "cost_per_byte": "1000", + "hard_storage_limit_per_operation": "60000", + "test_chain_duration": "1966080", + "quorum_min": 3000, + "quorum_max": 7000, + "min_proposal_quorum": 500, + "initial_endorsers": 1, + "delay_per_missing_endorsement": "1" } GENESIS_SK = "edsk31vznjHSSpGExDMHYASz45VZqXN4DPxvsa4hAyY8dHM28cZzp6" diff --git a/tests_python/tools/utils.py b/tests_python/tools/utils.py index 08ede84d3126188d0c7f006e1af1896aac76054d..31cf451a048b81699ba4862c038078d2e81854e7 100644 --- a/tests_python/tools/utils.py +++ b/tests_python/tools/utils.py @@ -7,6 +7,7 @@ import json import time import re import hashlib +import subprocess import requests import ed25519 import base58check @@ -273,3 +274,25 @@ def sign_operation(encoded_operation: str, secret_key: str) -> str: sig_hex = sign(watermarked_operation, sender_sk_bin) signed_op = encoded_operation + sig_hex return signed_op + + +def check_run_failure(code, pattern, mode='stderr'): + """Executes [code()] and expects the code to fail and raise + [subprocess.CalledProcessError]. If so, the [pattern] is searched + in stderr. If it is found, returns True; else returns False. + """ + try: + code() + return False + except subprocess.CalledProcessError as exc: + stdout_output = exc.args[2] + stderr_output = exc.args[3] + data = [] + if mode == 'stderr': + data = stderr_output.split('\n') + else: + data = stdout_output.split('\n') + for line in data: + if re.search(pattern, line): + return True + return False diff --git a/vendors/flextesa-lib/tezos_protocol.ml b/vendors/flextesa-lib/tezos_protocol.ml index ea27b8f9e31bc232171880ef37c00a4edaf760a9..72320b79e6e0c87c0e0b8c9aad04eb481f9ceb07 100644 --- a/vendors/flextesa-lib/tezos_protocol.ml +++ b/vendors/flextesa-lib/tezos_protocol.ml @@ -76,7 +76,27 @@ type t = ; blocks_per_voting_period: int ; blocks_per_cycle: int ; preserved_cycles: int - ; proof_of_work_threshold: int } + ; proof_of_work_threshold: int + ; blocks_per_commitment: int + ; endorsers_per_block: int + ; hard_gas_limit_per_operation: int + ; hard_gas_limit_per_block: int + ; tokens_per_roll: int + ; michelson_maximum_type_size: int + ; seed_nonce_revelation_tip: int + ; origination_size: int + ; block_security_deposit: int + ; endorsement_security_deposit: int + ; block_reward: int + ; endorsement_reward: int + ; hard_storage_limit_per_operation: int + ; cost_per_byte: int + ; test_chain_duration: int + ; quorum_min: int + ; quorum_max: int + ; min_proposal_quorum: int + ; initial_endorsers: int + ; delay_per_missing_endorsement: int } let compare a b = String.compare a.id b.id @@ -96,7 +116,27 @@ let default () = ; blocks_per_voting_period= 16 ; blocks_per_cycle= 8 ; preserved_cycles= 2 - ; proof_of_work_threshold= -1 } + ; proof_of_work_threshold= -1 + ; blocks_per_commitment= 4 + ; endorsers_per_block= 32 + ; hard_gas_limit_per_operation= 800000 + ; hard_gas_limit_per_block= 8000000 + ; tokens_per_roll= 8000000000 + ; michelson_maximum_type_size= 1000 + ; seed_nonce_revelation_tip= 125000 + ; origination_size= 257 + ; block_security_deposit= 512000000 + ; endorsement_security_deposit= 64000000 + ; block_reward= 16000000 + ; endorsement_reward= 2000000 + ; hard_storage_limit_per_operation= 60000 + ; cost_per_byte= 1000 + ; test_chain_duration= 1966080 + ; quorum_min= 3000 + ; quorum_max= 7000 + ; min_proposal_quorum= 500 + ; initial_endorsers= 1 + ; delay_per_missing_endorsement= 1 } let protocol_parameters_json t : Ezjsonm.t = let open Ezjsonm in @@ -118,7 +158,37 @@ let protocol_parameters_json t : Ezjsonm.t = ; ("blocks_per_cycle", int t.blocks_per_cycle) ; ("preserved_cycles", int t.preserved_cycles) ; ( "proof_of_work_threshold" - , ksprintf string "%d" t.proof_of_work_threshold ) ] + , ksprintf string "%d" t.proof_of_work_threshold ) + (* which constants are encoded in json as int or string looks a bit arbitrary + e.g. michelson_maximum_type_size=1000 is an int but cost_per_byte=1000 is + a string *) + ; ("blocks_per_commitment", int t.blocks_per_commitment) + ; ("endorsers_per_block", int t.endorsers_per_block) + ; ( "hard_gas_limit_per_operation" + , string (Int.to_string t.hard_gas_limit_per_operation) ) + ; ( "hard_gas_limit_per_block" + , string (Int.to_string t.hard_gas_limit_per_block) ) + ; ("tokens_per_roll", string (Int.to_string t.tokens_per_roll)) + ; ("michelson_maximum_type_size", int t.michelson_maximum_type_size) + ; ( "seed_nonce_revelation_tip" + , string (Int.to_string t.seed_nonce_revelation_tip) ) + ; ("origination_size", int t.origination_size) + ; ( "block_security_deposit" + , string (Int.to_string t.block_security_deposit) ) + ; ( "endorsement_security_deposit" + , string (Int.to_string t.endorsement_security_deposit) ) + ; ("block_reward", string (Int.to_string t.block_reward)) + ; ("endorsement_reward", string (Int.to_string t.endorsement_reward)) + ; ( "hard_storage_limit_per_operation" + , string (Int.to_string t.hard_storage_limit_per_operation) ) + ; ("cost_per_byte", string (Int.to_string t.cost_per_byte)) + ; ("test_chain_duration", string (Int.to_string t.test_chain_duration)) + ; ("quorum_min", int t.quorum_min) + ; ("quorum_max", int t.quorum_max) + ; ("min_proposal_quorum", int t.min_proposal_quorum) + ; ("initial_endorsers", int t.initial_endorsers) + ; ( "delay_per_missing_endorsement" + , string (Int.to_string t.delay_per_missing_endorsement) ) ] let sandbox {dictator; _} = let pk = Account.pubkey dictator in @@ -163,28 +233,31 @@ let ensure t ~config = let cli_term () = let open Cmdliner in let open Term in - let def = default () in let docs = "PROTOCOL OPTIONS" in pure (fun remove_default_bas - (`Blocks_per_voting_period blocks_per_voting_period) - (`Protocol_hash hash) - (`Time_between_blocks time_between_blocks) - (`Blocks_per_cycle blocks_per_cycle) - (`Preserved_cycles preserved_cycles) + (`Blocks_per_voting_period bpvp) + (`Protocol_hash hashopt) + (`Time_between_blocks tbb) add_bootstraps -> - let id = "default-and-command-line" in + let d = default () in + let id = + if add_bootstraps = [] && remove_default_bas = false then d.id + else "default-and-command-line" in + let time_between_blocks = + Option.value tbb ~default:d.time_between_blocks in let bootstrap_accounts = add_bootstraps - @ if remove_default_bas then [] else def.bootstrap_accounts in - { def with + @ if remove_default_bas then [] else d.bootstrap_accounts in + let blocks_per_voting_period = + match bpvp with Some v -> v | None -> d.blocks_per_voting_period in + let hash = Option.value hashopt ~default:d.hash in + { d with id - ; blocks_per_cycle ; hash ; bootstrap_accounts ; time_between_blocks - ; preserved_cycles ; blocks_per_voting_period }) $ Arg.( value @@ -195,39 +268,25 @@ let cli_term () = $ Arg.( pure (fun x -> `Blocks_per_voting_period x) $ value - (opt int def.blocks_per_voting_period - (info ~docs + (opt (some int) None + (info ["blocks-per-voting-period"] ~doc:"Set the length of voting periods."))) $ Arg.( pure (fun x -> `Protocol_hash x) $ value - (opt string def.hash - (info ["protocol-hash"] ~docs - ~doc:"Set the (initial) protocol hash."))) + (opt (some string) None + (info ["protocol-hash"] ~doc:"Set the (initial) protocol hash."))) $ Arg.( pure (fun x -> `Time_between_blocks x) $ value - (opt (list ~sep:',' int) def.time_between_blocks + (opt + (some (list ~sep:',' int)) + None (info ["time-between-blocks"] ~docv:"COMMA-SEPARATED-SECONDS" - ~docs ~doc: "Set the time between blocks bootstrap-parameter, e.g. \ `2,3,2`."))) - $ Arg.( - pure (fun x -> `Blocks_per_cycle x) - $ value - (opt int def.blocks_per_cycle - (info ["blocks-per-cycle"] ~docv:"NUMBER" ~docs - ~doc:"Number of blocks per cycle."))) - $ Arg.( - pure (fun x -> `Preserved_cycles x) - $ value - (opt int def.preserved_cycles - (info ["preserved-cycles"] ~docv:"NUMBER" ~docs - ~doc: - "Base constant for baking rights (search for \ - `PRESERVED_CYCLES` in the white paper)."))) $ Arg.( pure (fun l -> List.map l ~f:(fun ((name, pubkey, pubkey_hash, private_key), tez) -> @@ -236,7 +295,7 @@ let cli_term () = (opt_all (pair ~sep:'@' (t4 ~sep:',' string string string string) int64) [] - (info ["add-bootstrap-account"] ~docs + (info ["add-bootstrap-account"] ~docv:"NAME,PUBKEY,PUBKEY-HASH,PRIVATE-URI@MUTEZ-AMOUNT" ~doc: "Add a custom bootstrap account, e.g. \ diff --git a/vendors/flextesa-lib/tezos_protocol.mli b/vendors/flextesa-lib/tezos_protocol.mli index aa2e1266c2dd108aec012bcaa94027713ecc412d..f84ed4ed1c9b73487c7434c172c47016631cfe93 100644 --- a/vendors/flextesa-lib/tezos_protocol.mli +++ b/vendors/flextesa-lib/tezos_protocol.mli @@ -51,7 +51,27 @@ type t = ; blocks_per_voting_period: int ; blocks_per_cycle: int ; preserved_cycles: int - ; proof_of_work_threshold: int } + ; proof_of_work_threshold: int + ; blocks_per_commitment: int + ; endorsers_per_block: int + ; hard_gas_limit_per_operation: int + ; hard_gas_limit_per_block: int + ; tokens_per_roll: int + ; michelson_maximum_type_size: int + ; seed_nonce_revelation_tip: int + ; origination_size: int + ; block_security_deposit: int + ; endorsement_security_deposit: int + ; block_reward: int + ; endorsement_reward: int + ; hard_storage_limit_per_operation: int + ; cost_per_byte: int + ; test_chain_duration: int + ; quorum_min: int + ; quorum_max: int + ; min_proposal_quorum: int + ; initial_endorsers: int + ; delay_per_missing_endorsement: int } (** [t] wraps bootstrap parameters for sandboxed protocols. *) val compare : t -> t -> int