diff --git a/.gitlab/ci/opam.yml b/.gitlab/ci/opam.yml index 7698134840e6b79ad43c040d99a2b4d54433b2c4..98422ccfac35df0de27ce13f6c9c84541c23de43 100644 --- a/.gitlab/ci/opam.yml +++ b/.gitlab/ci/opam.yml @@ -421,6 +421,11 @@ opam:tezos-codec: variables: package: tezos-codec +opam:tezos-contract-metadata: + extends: .opam_template + variables: + package: tezos-contract-metadata + opam:tezos-crypto: extends: .opam_template variables: diff --git a/.gitlab/ci/tezt.yml b/.gitlab/ci/tezt.yml index 1c18cbbbb1eefd7f0515e8eecb85e1948fffff40..289343b82bbfa60988598f3a0e5702624a5f31e5 100644 --- a/.gitlab/ci/tezt.yml +++ b/.gitlab/ci/tezt.yml @@ -1,35 +1,35 @@ # We use `scripts/run-tezt-tests-ci.sh` to split the Tezt tests into ranges: -tezt:run-1-33: +tezt:run-1-65: extends: .test_template before_script: - make script: - - sh scripts/run-tezt-tests-ci.sh 1 33 + - sh scripts/run-tezt-tests-ci.sh 1 65 artifacts: paths: - tezt.log expire_in: 1 day when: on_failure -tezt:run-34-66: +tezt:run-66-130: extends: .test_template before_script: - make script: - - sh scripts/run-tezt-tests-ci.sh 34 66 + - sh scripts/run-tezt-tests-ci.sh 66 130 artifacts: paths: - tezt.log expire_in: 1 day when: on_failure -tezt:run-67-end: +tezt:run-131-end: extends: .test_template before_script: - make script: - - sh scripts/run-tezt-tests-ci.sh 67 + - sh scripts/run-tezt-tests-ci.sh 131 artifacts: paths: - tezt.log diff --git a/CHANGES.md b/CHANGES.md index 8a4b44cbdea7ca482cedd6bb3fc65a5f1a580f5d..665c5efbaecca4a19435d4d8590753c58fee8a1c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -45,6 +45,11 @@ be documented here either. ## Client - Fixed the return code of errors in the client calls to be non-zero. +- Add support for + [TZIP-016](https://gitlab.com/tzip/tzip/-/blob/master/proposals/tzip-16/tzip-16.md) + contract-metadata: fetch the metadata and call off-chain-views. + This includes the `tezos-contract-metadata` OCaml library also used in + [TZComet](https://tqtezos.github.io/TZComet/) with `js_of_ocaml`. - Added a new multisig command to change keys and threshold `set threshold of multisig contract ...`. diff --git a/src/lib_client_base/client_context.ml b/src/lib_client_base/client_context.ml index edab6a8a00c9525116941f6048b3f6e4342b8ae9..90eb72509940e026a0f25a0653e6e4cd30b48f3c 100644 --- a/src/lib_client_base/client_context.ml +++ b/src/lib_client_base/client_context.ml @@ -85,6 +85,8 @@ class type wallet = string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t method get_base_dir : string + + method ipfs_gateway : Uri.t end class type chain = @@ -204,6 +206,8 @@ class proxy_context (obj : full) = method now : unit -> Ptime.t = obj#now method get_base_dir : string = obj#get_base_dir + + method ipfs_gateway = obj#ipfs_gateway end let log _ _ = Lwt.return_unit diff --git a/src/lib_client_base/client_context.mli b/src/lib_client_base/client_context.mli index a0d6cd2f8932e69f589cd3702a6a3724a123537d..5b83929d029dc070b1e2b7456cbdff6d53db4e53 100644 --- a/src/lib_client_base/client_context.mli +++ b/src/lib_client_base/client_context.mli @@ -68,6 +68,8 @@ class type wallet = string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t method get_base_dir : string + + method ipfs_gateway : Uri.t end class type chain = diff --git a/src/lib_client_base_unix/client_config.ml b/src/lib_client_base_unix/client_config.ml index 68528b9610829a01ae20fc12f0a7ab6ab579ea22..192e5f255c3f4f36a09dad4523c287c570aa81ad 100644 --- a/src/lib_client_base_unix/client_config.ml +++ b/src/lib_client_base_unix/client_config.ml @@ -188,6 +188,8 @@ let default_block = `Head 0 let default_endpoint = Uri.of_string "http://localhost:8732" +let default_ipfs_gateway = Uri.of_string "https://ipfs.io/ipfs/" + open Filename.Infix module Cfg_file = struct @@ -200,6 +202,7 @@ module Cfg_file = struct node_port : int option; tls : bool option; endpoint : Uri.t option; + ipfs_gateway : Uri.t; web_port : int; remote_signer : Uri.t option; confirmations : int option; @@ -213,6 +216,7 @@ module Cfg_file = struct node_addr = None; node_port = None; tls = None; + ipfs_gateway = default_ipfs_gateway; web_port = 8080; remote_signer = None; confirmations = Some 0; @@ -228,6 +232,7 @@ module Cfg_file = struct node_port; tls; endpoint; + ipfs_gateway; web_port; remote_signer; confirmations; @@ -237,6 +242,7 @@ module Cfg_file = struct node_port, tls, endpoint, + ipfs_gateway, Some web_port, remote_signer, confirmations, @@ -246,6 +252,7 @@ module Cfg_file = struct node_port, tls, endpoint, + ipfs_gateway, web_port, remote_signer, confirmations, @@ -257,17 +264,19 @@ module Cfg_file = struct node_port; tls; endpoint; + ipfs_gateway; web_port; remote_signer; confirmations; password_filename; }) - (obj9 + (obj10 (req "base_dir" string) (opt "node_addr" string) (opt "node_port" uint16) (opt "tls" bool) (opt "endpoint" RPC_encoding.uri_encoding) + (dft "ipfs-gateway" RPC_encoding.uri_encoding default_ipfs_gateway) (opt "web_port" uint16) (opt "remote_signer" RPC_encoding.uri_encoding) (opt "confirmations" int8) @@ -473,6 +482,16 @@ let endpoint_arg () = "HTTP(S) endpoint of the node RPC interface; e.g. 'http://localhost:8732'" (endpoint_parameter ()) +let ipfs_gateway_arg () = + arg + ~long:"ipfs-gateway" + ~placeholder:"uri" + ~doc: + (Printf.sprintf + "Endpoint to use to reach ipfs:// URIs. By default: %s." + (Uri.to_string default_ipfs_gateway)) + (endpoint_parameter ()) + let remote_signer_arg () = arg ~long:"remote-signer" @@ -744,8 +763,27 @@ let commands config_file cfg (client_mode : client_mode) protocol_constants_file base_dir) ] -let global_options () = - args15 +type t = + string option + * string option + * bool + * Shell_services.chain + * Shell_services.block + * int option option + * Protocol_hash.t option option + * bool + * string option + * int option + * bool + * Uri.t option + * Uri.t option + * Uri.t option + * string option + * client_mode + +let global_options () : (t, #Client_context.full) Clic.options = + (* We force the type `t` to ensure nicer error messages. *) + args16 (base_dir_arg ()) (config_file_arg ()) (timings_switch ()) @@ -758,6 +796,7 @@ let global_options () = (port_arg ()) (tls_switch ()) (endpoint_arg ()) + (ipfs_gateway_arg ()) (remote_signer_arg ()) (password_filename_arg ()) (client_mode_arg ()) @@ -890,6 +929,7 @@ let parse_config_args (ctx : #Client_context.full) argv = node_port, tls, endpoint, + ipfs_gateway, remote_signer, password_filename, client_mode ), @@ -995,6 +1035,7 @@ let parse_config_args (ctx : #Client_context.full) argv = let password_filename = Option.either password_filename cfg.password_filename in + let ipfs_gateway = Option.value ~default:cfg.ipfs_gateway ipfs_gateway in let cfg = { cfg with @@ -1002,6 +1043,7 @@ let parse_config_args (ctx : #Client_context.full) argv = node_port = None; tls = None; endpoint = Some endpoint; + ipfs_gateway; remote_signer; confirmations; password_filename; @@ -1039,23 +1081,6 @@ let parse_config_args (ctx : #Client_context.full) argv = }, remaining ) -type t = - string option - * string option - * bool - * Shell_services.chain - * Shell_services.block - * int option option - * Protocol_hash.t option option - * bool - * string option - * int option - * bool - * Uri.t option - * Uri.t option - * string option - * client_mode - module type Remote_params = sig val authenticate : Signature.public_key_hash list -> Bytes.t -> Signature.t tzresult Lwt.t diff --git a/src/lib_client_base_unix/client_context_unix.ml b/src/lib_client_base_unix/client_context_unix.ml index 9bc579fad58020f19d10a239bfc50e2a4f55a1a1..641123101cf2910377e89bd00dadf4164531b799 100644 --- a/src/lib_client_base_unix/client_context_unix.ml +++ b/src/lib_client_base_unix/client_context_unix.ml @@ -24,7 +24,8 @@ (* *) (*****************************************************************************) -class unix_wallet ~base_dir ~password_filename : Client_context.wallet = +class unix_wallet ~base_dir ~password_filename ~ipfs_gateway : + Client_context.wallet = object (self) method load_passwords = match password_filename with @@ -48,6 +49,8 @@ class unix_wallet ~base_dir ~password_filename : Client_context.wallet = method get_base_dir = base_dir + method ipfs_gateway = ipfs_gateway + method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t = fun f -> let unlock fd = @@ -153,9 +156,10 @@ class unix_logger ~base_dir : Client_context.printer = inherit Client_context.simple_printer log end -class unix_io_wallet ~base_dir ~password_filename : Client_context.io_wallet = +class unix_io_wallet ~base_dir ~password_filename ~ipfs_gateway : + Client_context.io_wallet = object - inherit unix_wallet ~base_dir ~password_filename + inherit unix_wallet ~base_dir ~password_filename ~ipfs_gateway inherit unix_logger ~base_dir @@ -172,13 +176,13 @@ class unix_ui : Client_context.ui = end class unix_full ~base_dir ~chain ~block ~confirmations ~password_filename - ~rpc_config : Client_context.full = + ~rpc_config ~ipfs_gateway : Client_context.full = object inherit unix_logger ~base_dir inherit unix_prompter - inherit unix_wallet ~base_dir ~password_filename + inherit unix_wallet ~base_dir ~password_filename ~ipfs_gateway inherit Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt @@ -193,14 +197,14 @@ class unix_full ~base_dir ~chain ~block ~confirmations ~password_filename method confirmations = confirmations end -class unix_mockup ~base_dir ~mem_only ~mockup_env ~chain_id ~rpc_context : - Client_context.full = +class unix_mockup ~base_dir ~mem_only ~mockup_env ~chain_id ~rpc_context + ~ipfs_gateway : Client_context.full = object inherit unix_logger ~base_dir inherit unix_prompter - inherit unix_wallet ~base_dir ~password_filename:None + inherit unix_wallet ~base_dir ~password_filename:None ~ipfs_gateway inherit Tezos_mockup.RPC_client.mockup_ctxt @@ -216,13 +220,13 @@ class unix_mockup ~base_dir ~mem_only ~mockup_env ~chain_id ~rpc_context : end class unix_proxy ~base_dir ~chain ~block ~confirmations ~password_filename - ~rpc_config ~proxy_env : Client_context.full = + ~rpc_config ~proxy_env ~ipfs_gateway : Client_context.full = object inherit unix_logger ~base_dir inherit unix_prompter - inherit unix_wallet ~base_dir ~password_filename + inherit unix_wallet ~base_dir ~password_filename ~ipfs_gateway inherit Tezos_proxy.RPC_client.http_local_ctxt diff --git a/src/lib_client_base_unix/client_context_unix.mli b/src/lib_client_base_unix/client_context_unix.mli index 1ff9f797c1674d7abe101e3d0c994255b9f3006a..2ec3da5a4ec7a63517bcf8040c687ebd1352925a 100644 --- a/src/lib_client_base_unix/client_context_unix.mli +++ b/src/lib_client_base_unix/client_context_unix.mli @@ -25,7 +25,10 @@ (*****************************************************************************) class unix_wallet : - base_dir:string -> password_filename:string option -> Client_context.wallet + base_dir:string + -> password_filename:string option + -> ipfs_gateway:Uri.t + -> Client_context.wallet class unix_prompter : Client_context.prompter @@ -34,6 +37,7 @@ class unix_logger : base_dir:string -> Client_context.printer class unix_io_wallet : base_dir:string -> password_filename:string option + -> ipfs_gateway:Uri.t -> Client_context.io_wallet class unix_ui : Client_context.ui @@ -45,6 +49,7 @@ class unix_full : -> confirmations:int option -> password_filename:string option -> rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config + -> ipfs_gateway:Uri.t -> Client_context.full class unix_mockup : @@ -53,6 +58,7 @@ class unix_mockup : -> mockup_env:Tezos_mockup_registration.Registration.mockup_environment -> chain_id:Chain_id.t -> rpc_context:Tezos_protocol_environment.rpc_context + -> ipfs_gateway:Uri.t -> Client_context.full class unix_proxy : @@ -63,4 +69,5 @@ class unix_proxy : -> password_filename:string option -> rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config -> proxy_env:Tezos_proxy.Registration.proxy_environment + -> ipfs_gateway:Uri.t -> Client_context.full diff --git a/src/lib_client_base_unix/client_main_run.ml b/src/lib_client_base_unix/client_main_run.ml index ada64d17d6db4d9322da7b788147a8e967d86e23..201ef5b97cb8bcd4daea7498c07161b7538d9395 100644 --- a/src/lib_client_base_unix/client_main_run.ml +++ b/src/lib_client_base_unix/client_main_run.ml @@ -129,7 +129,8 @@ let setup_remote_signer (module C : M) client_config | None -> () ) -let setup_default_proxy_client_config parsed_args base_dir rpc_config mode = +let setup_default_proxy_client_config parsed_args base_dir rpc_config + ipfs_gateway mode = (* Make sure that base_dir is not a mockup. *) Tezos_mockup.Persistence.classify_base_dir base_dir >>=? (function @@ -165,6 +166,7 @@ let setup_default_proxy_client_config parsed_args base_dir rpc_config mode = ~password_filename ~base_dir ~rpc_config + ~ipfs_gateway | `Mode_proxy -> let printer = new unix_logger ~base_dir in let rpc_context = @@ -188,10 +190,11 @@ let setup_default_proxy_client_config parsed_args base_dir rpc_config mode = ~base_dir ~rpc_config ~proxy_env + ~ipfs_gateway let setup_mockup_rpc_client_config (cctxt : Tezos_client_base.Client_context.full) - (args : Client_config.cli_args) base_dir = + (args : Client_config.cli_args) base_dir ipfs_gateway = let in_memory_mockup (args : Client_config.cli_args) = match args.protocol with | None -> @@ -219,12 +222,23 @@ let setup_mockup_rpc_client_config >>=? fun res -> return (res, mem_only)) >>=? fun ((mockup_env, (chain_id, rpc_context)), mem_only) -> return - (new unix_mockup ~base_dir ~mem_only ~mockup_env ~chain_id ~rpc_context) + (new unix_mockup + ~base_dir + ~mem_only + ~mockup_env + ~chain_id + ~rpc_context + ~ipfs_gateway) let setup_client_config (cctxt : Tezos_client_base.Client_context.full) - (parsed_args : Client_config.cli_args option) base_dir rpc_config = + (parsed_args : Client_config.cli_args option) base_dir rpc_config + ipfs_gateway = let client_or_proxy_fun = - setup_default_proxy_client_config parsed_args base_dir rpc_config + setup_default_proxy_client_config + parsed_args + base_dir + rpc_config + ipfs_gateway in match parsed_args with | None -> @@ -234,7 +248,7 @@ let setup_client_config (cctxt : Tezos_client_base.Client_context.full) | `Mode_client -> client_or_proxy_fun `Mode_client | `Mode_mockup -> - setup_mockup_rpc_client_config cctxt args base_dir + setup_mockup_rpc_client_config cctxt args base_dir ipfs_gateway | `Mode_proxy -> client_or_proxy_fun `Mode_proxy ) @@ -284,6 +298,7 @@ let main (module C : M) ~select_commands = ~password_filename:None ~base_dir:C.default_base_dir ~rpc_config:RPC_client_unix.default_config + ~ipfs_gateway:Client_config.default_ipfs_gateway in C.parse_config_args full original_args >>=? (fun (parsed, remaining) -> @@ -336,7 +351,19 @@ let main (module C : M) ~select_commands = | None -> rpc_config in - setup_client_config full parsed_args base_dir rpc_config + let ipfs_gateway = + match parsed_config_file with + | None -> + Client_config.default_ipfs_gateway + | Some p -> + p.Client_config.Cfg_file.ipfs_gateway + in + setup_client_config + full + parsed_args + base_dir + rpc_config + ipfs_gateway >>=? fun client_config -> setup_remote_signer (module C) diff --git a/src/lib_client_base_unix/test/test_mockup_wallet.ml b/src/lib_client_base_unix/test/test_mockup_wallet.ml index f55c4d765e8822181eddc98189f3a45f21dff814..04cc6c197e6132dc9568e22ea61153674204b980 100644 --- a/src/lib_client_base_unix/test/test_mockup_wallet.ml +++ b/src/lib_client_base_unix/test/test_mockup_wallet.ml @@ -107,6 +107,7 @@ let test_no_bootstrap_accounts_file_populates_defaults = new Client_context_unix.unix_io_wallet ~base_dir ~password_filename:None + ~ipfs_gateway:(Uri.of_string "https://example.com") in let () = Client_keys.register_signer @@ -132,6 +133,7 @@ let test_with_valid_bootstrap_accounts_file_populates = new Client_context_unix.unix_io_wallet ~base_dir ~password_filename:None + ~ipfs_gateway:(Uri.of_string "https://example.com") in let account_name_1 = "account 1" in let account_name_2 = "account 2" in diff --git a/src/lib_contract_metadata/.ocamlformat b/src/lib_contract_metadata/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_contract_metadata/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_contract_metadata/dune b/src/lib_contract_metadata/dune new file mode 100644 index 0000000000000000000000000000000000000000..349bfafa745d81754fdde445b936e4b19dc59bcf --- /dev/null +++ b/src/lib_contract_metadata/dune @@ -0,0 +1,14 @@ +(library + (name tezos_contract_metadata) + (public_name tezos-contract-metadata) + (libraries tezos-micheline + cohttp + fmt + ) + (flags (:standard -open Tezos_error_monad )) + ) + +(alias + (name runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_contract_metadata/dune-project b/src/lib_contract_metadata/dune-project new file mode 100644 index 0000000000000000000000000000000000000000..7611aabfcf764c674676234f68ca7fe3a7e96615 --- /dev/null +++ b/src/lib_contract_metadata/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name tezos-contract-metadata) diff --git a/src/lib_contract_metadata/metadata_contents.ml b/src/lib_contract_metadata/metadata_contents.ml new file mode 100644 index 0000000000000000000000000000000000000000..60504702d0edbe0306a777a86d7216a04164f486 --- /dev/null +++ b/src/lib_contract_metadata/metadata_contents.ml @@ -0,0 +1,994 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 TQ Tezos *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module License = struct + type t = {name : string; details : string option} + + let pp ppf {name; details} = + Fmt.pf + ppf + "%s%a" + name + Fmt.(option ~none:(const string "") (sp ++ parens string)) + details + + let encoding = + let open Json_encoding in + conv + (function {name; details} -> (name, details)) + (fun (name, details) -> {name; details}) + (obj2 + (req + "name" + string + ~description: + "A mnemonic name for the license, see also the License-name case.") + (opt + "details" + string + ~description: + "Paragraphs of free text, with punctuation and proper language.")) +end + +module Michelson_blob = struct + open Tezos_micheline + + type t = Micheline of string Micheline.canonical + + let pp ppf (Micheline m) = + Fmt.pf + ppf + "'%a'" + Micheline_printer.print_expr + (Micheline_printer.printable Base.Fn.id m) + + let encoding = + let open Json_encoding in + conv + (function Micheline m -> m) + (fun m -> Micheline m) + (Data_encoding.Json.convert + (Micheline.canonical_encoding ~variant:"tzip-16" Data_encoding.string)) +end + +module View = struct + module Implementation = struct + open Tezos_micheline + + module Michelson_storage = struct + type t = { + parameter : Michelson_blob.t option; + return_type : Michelson_blob.t; + code : Michelson_blob.t; + human_annotations : (string * string) list; + version : string option; + } + end + + module Rest_api_query = struct + type t = { + specification_uri : string; + base_uri : string option; + path : string; + meth : Cohttp.Code.meth; + } + end + + type t = + | Michelson_storage of Michelson_storage.t + | Rest_api_query of Rest_api_query.t + + let michelson_storage ?parameter ~return_type ?(annotations = []) ?version + code = + Michelson_storage + { + parameter; + return_type; + code; + human_annotations = annotations; + version; + } + + let rest_api_query ?base_uri ?(meth = `GET) specification_uri path = + Rest_api_query {specification_uri; base_uri; path; meth} + + let pp ?(with_code = true) ppf impl = + let open Fmt in + pf + ppf + "%a" + (box + ~indent:2 + ( match impl with + | Michelson_storage + {parameter; return_type; code; human_annotations; version} -> + let michelfield field_name = + box + ( cut ++ const string field_name ++ const string ":" ++ sp + ++ Michelson_blob.pp ) + in + vbox + ~indent:2 + ( const string "Michelson-storage:" + ++ const + (option + ( cut + ++ field ~label:string "Version" Base.Fn.id string )) + version + ++ const + (option ~none:nop (cut ++ michelfield "Parameter")) + parameter + ++ const (cut ++ michelfield "Return-type") return_type + ++ ( if with_code then const (cut ++ michelfield "Code") code + else nop ) + ++ const + (fun ppf -> function [] -> nop ppf () | annots -> + pf + ppf + "%a" + ( cut + ++ field + ~label:string + "Annotations" + Base.Fn.id + (vbox + (list + ~sep:cut + (box + ~indent:2 + (pair + ~sep:(any " ->@ ") + string + text)))) ) + annots) + human_annotations ) + | Rest_api_query {specification_uri; base_uri; path; meth} -> + let string_field f = field ~label:string f Base.Fn.id string in + vbox + ~indent:2 + ( const string "REST-API-Query:" + ++ const + (cut ++ string_field "Specification-URI") + specification_uri + ++ const + (option ~none:nop (cut ++ string_field "Base-URI")) + base_uri + ++ const (cut ++ string_field "Specification-URI") path + ++ const + ( cut + ++ field + ~label:string + "Path" + Cohttp.Code.string_of_method + string ) + meth ) )) + () + + let encoding = + let open Json_encoding in + union + [ case + ~title:"michelsonStorageView" + ~description: + "An off-chain view using Michelson as a scripting language to \ + interpret the storage of a contract." + (obj1 + (req + "michelsonStorageView" + (obj5 + (opt + "parameter" + Michelson_blob.encoding + ~description: + "The Michelson type of the potential external \ + parameters required by the code of the view.") + (req + "returnType" + Michelson_blob.encoding + ~description: + "The type of the result of the view, i.e. the value \ + left on the stack by the code.") + (req + "code" + Michelson_blob.encoding + ~description: + "The Michelson code expression implementing the view.") + (dft + "annotations" + ~description: + "List of objects documenting the annotations used \ + in the 3 above fields." + (list + (obj2 (req "name" string) (req "description" string))) + []) + (opt + "version" + string + ~description: + "A string representing the version of Michelson \ + that the view is meant to work with; versions here \ + should be base58check-encoded protocol hashes.")))) + (function + | Michelson_storage + {parameter; return_type; code; human_annotations; version} -> + Some + (parameter, return_type, code, human_annotations, version) + | Rest_api_query _ -> + None) + (fun (parameter, return_type, code, human_annotations, version) -> + Michelson_storage + {parameter; return_type; code; human_annotations; version}); + case + ~title:"restApiQueryView" + ~description: + "An off-chain view using a REST API described in a separate \ + OpenAPI specification. The following parameters form a pointer \ + to the localtion in the OpenAPI description." + (obj1 + (req + "restApiQuery" + (obj4 + (req + "specificationUri" + string + ~description: + "A URI pointing at the location of the OpenAPI \ + specification.") + (opt + "baseUri" + string + ~description:"The URI-prefix to use to query the API.") + (req + "path" + string + ~description: + "The path component of the URI to look-up in the \ + OpenAPI specification.") + (dft + "method" + ~description:"The HTTP method to use." + (string_enum + [("GET", `GET); ("POST", `POST); ("PUT", `PUT)]) + `GET)))) + (function + | Michelson_storage _ -> + None + | Rest_api_query {specification_uri; base_uri; path; meth} -> + Some (specification_uri, base_uri, path, meth)) + (fun (specification_uri, base_uri, path, meth) -> + Rest_api_query {specification_uri; base_uri; path; meth}) ] + + module Example = struct + let build = function + | 0 -> + michelson_storage + ~return_type: + (Micheline + Micheline.(Prim (0, "nat", [], []) |> strip_locations)) + (Micheline Micheline.(Seq (0, []) |> strip_locations)) + | 1 -> + rest_api_query + ~meth:`GET + "https://example.com/v1.json" + "/get-something" + | 2 -> + let mich s = + let (toks, errs) = Micheline_parser.tokenize s in + assert (errs = []) ; + let (node, errs) = Micheline_parser.parse_expression toks in + assert (errs = []) ; + node + in + let elson e = + Michelson_blob.Micheline (Micheline.strip_locations e) + in + michelson_storage + ( mich "{ DUP ; DIP { CDR ; PUSH string \"Huh\" ; FAILWITH } }" + |> elson ) + ~parameter:(mich "(pair (mutez %amount) (string %name))" |> elson) + ~return_type:(mich "map string string" |> elson) + ~version:"PsCARTHAGazKbHtnKfLzQg3kms52kSRpgnDY982a9oYsSXRLQEb" + ~annotations: + [ ( "%amount", + "The amount which should mean something in context. It's \ + in `mutez` which should also mean something more than \ + lorem ipsum dolor whatever …" ); + ("%name", "The name of the thing being queried.") ] + | _ -> + assert false + end + end + + type t = { + name : string; + description : string option; + implementations : Implementation.t list; + is_pure : bool; + } + + let make ?description ?(is_pure = false) name implementations = + {name; description; implementations; is_pure} + + let pp ?with_code ppf view = + let open Fmt in + pf + ppf + "@[%sView %S:%a@,%a@]" + (if view.is_pure then "Pure-" else "") + view.name + (option + ~none:nop + ( cut + ++ hovbox + ~indent:2 + (const string "Description:" ++ sp ++ box paragraphs) )) + view.description + (vbox (list ~sep:cut (Implementation.pp ?with_code))) + view.implementations + + let encoding = + let open Json_encoding in + conv + (fun {name; description; implementations; is_pure} -> + (name, description, implementations, is_pure)) + (fun (name, description, implementations, is_pure) -> + {name; description; implementations; is_pure}) + (obj4 + (req "name" string) + (opt + "description" + string + ~description: + "Plain language documentation of the off-chain view; with \ + punctuation.") + (req + "implementations" + ~description: + "The list of available and equivalent implementations." + (list Implementation.encoding)) + (dft "pure" bool false)) + + module Example = struct + let build = function + | 0 -> + make + "view0" + ~is_pure:true + [Implementation.Example.build 0; Implementation.Example.build 1] + | 1 -> + make "view-01" [Implementation.Example.build 2] + | _ -> + assert false + end +end + +module Source = struct + type t = {tools : string list; location : string option} + + let pp ppf {tools; location} = + let open Fmt in + pf + ppf + "@[<2>Tools:@ @[%a@]@]@,Location:@ %a" + (list ~sep:(any ", ") (quote string)) + tools + (option ~none:(any "None") string) + location + + let encoding = + let open Json_encoding in + conv + (fun {tools; location} -> (tools, location)) + (fun (tools, location) -> {tools; location}) + (obj2 + (dft + "tools" + (list string) + [] + ~title:"Contract Producing Tools" + ~description: + "List of tools/versions used in producing the Michelson.") + (opt + "location" + string + ~title:"Source Location" + ~description:"Location (URL) of the source code.")) +end + +module Errors = struct + module Translation = struct + type t = + | Static of { + error : Michelson_blob.t; + expansion : Michelson_blob.t; + languages : string list option; + } + | Dynamic of {view_name : string; languages : string list option} + + let pp ppf = + let open Fmt in + let langs ppf = function + | None -> + pf ppf "" + | Some more -> + pf ppf "@ (langs: %a)" (list ~sep:(any "|") string) more + in + function + | Static {error; expansion; languages} -> + pf + ppf + "@[<2>%a -> %a%a@]" + Michelson_blob.pp + error + Michelson_blob.pp + expansion + langs + languages + | Dynamic {view_name; languages} -> + pf ppf "@[<2>View %S%a@]" view_name langs languages + + let encoding = + let open Json_encoding in + union + [ case + ~title:"staticErrorTranslator" + ~description: + "A convertor between error codes and expanded messages." + (obj3 + (req "error" Michelson_blob.encoding) + (req "expansion" Michelson_blob.encoding) + (opt "languages" (list string))) + (function + | Static {error; expansion; languages} -> + Some (error, expansion, languages) + | Dynamic _ -> + None) + (fun (error, expansion, languages) -> + Static {error; expansion; languages}); + case + ~title:"dynamicErrorTranslator" + ~description: + "An off-chain-view to call to convert error codes to expanded \ + messages." + (obj2 (req "view" string) (opt "languages" (list string))) + (function + | Static _ -> + None + | Dynamic {view_name; languages} -> + Some (view_name, languages)) + (fun (view_name, languages) -> Dynamic {view_name; languages}) ] + end + + type t = Translation.t list + + let pp ppf t = + Fmt.pf ppf "@[<2>[%a]@]" Fmt.(list ~sep:(any "; ,") Translation.pp) t + + let encoding = + let open Json_encoding in + list Translation.encoding +end + +type t = { + name : string option; + description : string option; + version : string option; + license : License.t option; + authors : string list; + homepage : string option; + source : Source.t option; + interfaces : string list; + errors : Errors.t option; + views : View.t list; + unknown : (string * Ezjsonm.value) list; +} + +let make ?name ?description ?version ?license ?(authors = []) ?homepage ?source + ?(interfaces = []) ?errors ?(extras = []) views = + { + name; + description; + version; + license; + authors; + homepage; + source; + interfaces; + errors; + views; + unknown = extras; + } + +let pp_gen ?(shorter = false) ppf t = + let open Fmt in + let all = + let field name conv value = + const + (option ~none:nop (cut ++ field ~label:string name Base.Fn.id conv)) + value + in + let optlist = function [] -> None | m -> Some m in + let { name; + description; + version; + license; + authors; + homepage; + source; + interfaces; + errors; + views; + unknown } = + t + (* we force ocaml to warn us for missing fields *) + in + vbox + ~indent:2 + ( const string "Contract-Metadata-TZIP-16:" + ++ field "Name" string name + ++ field "Description" paragraphs description + ++ field "Version" string version + ++ field "License" License.pp license + ++ field "Authors" (list ~sep:comma string) (optlist authors) + ++ field "Homepage" string homepage + ++ field "Source" Source.pp source + ++ field "Interfaces" (list ~sep:comma string) (optlist interfaces) + ++ field "Errors" Errors.pp errors + ++ field + "Views" + (list ~sep:cut (View.pp ~with_code:(not shorter))) + (optlist views) + ++ + match unknown with + | [] -> + nop + | more -> + cut + ++ vbox + ~indent:2 + ( const string "Unknown:" ++ cut + ++ const lines (Ezjsonm.value_to_string ~minify:false (`O more)) + ) ) + in + pf ppf "%a" all () + +let pp = pp_gen ~shorter:false + +let pp_short = pp_gen ~shorter:true + +let _reserved_fields = + [ "name"; + "description"; + "version"; + "license"; + "authors"; + "homepage"; + "source"; + "interfaces"; + "errors"; + "views" ] + +let encoding = + let open Json_encoding in + let extensible fields (enc : 'a encoding) : + ('a * (string * Ezjsonm.value) list) encoding = + (* merge_objs enc (assoc any_ezjson_value) *) + let schema = + let o = schema enc in + let open Json_schema in + let root = root o in + match root.kind with + | Object ob -> + assert (List.length ob.properties = List.length fields) ; + let new_root = + { + root with + kind = + Object {ob with additional_properties = Some (element Any)}; + } + in + Json_schema.update new_root o + | _ -> + assert false + in + custom + ~schema + (fun (a, args) -> + match construct enc a with + | `O l -> + `O (l @ args) + | _ -> + Fmt.failwith "extensible: failed to get an object") + (fun json -> + let (retained, unknown) = + match json with + | `O obj -> + Base.List.partition_tf obj ~f:(fun (k, _) -> List.mem k fields) + | other -> + Fmt.failwith + "Wrong json: %s" + (Ezjsonm.value_to_string ~minify:false other) + in + (destruct enc (`O retained), unknown)) + in + def + "contractMetadataTzip16" + ~title:"contractMetadataTzip16" + ~description:"Smart Contract Metadata Standard (TZIP-16)." + (conv + (fun { name; + description; + version; + license; + authors; + homepage; + source; + interfaces; + errors; + views; + unknown } -> + ( ( name, + description, + version, + license, + authors, + homepage, + source, + interfaces, + errors, + views ), + unknown )) + (fun ( ( name, + description, + version, + license, + authors, + homepage, + source, + interfaces, + errors, + views ), + unknown ) -> + { + name; + description; + version; + license; + authors; + homepage; + source; + interfaces; + errors; + views; + unknown; + }) + (extensible + _reserved_fields + (obj10 + (opt + "name" + string + ~description:"The identification of the contract.") + (opt + "description" + string + ~description: + "Natural language description of the contract and/or its \ + behavior.") + (opt + "version" + string + ~description:"The version of the contract code.") + (opt + "license" + License.encoding + ~description:"The software license of the contract.") + (dft + "authors" + ~description:"The list of authors of the contract." + (list string) + []) + (opt + "homepage" + string + ~description: + "A link for humans to follow for documentation, sources, \ + issues, etc.") + (opt + "source" + Source.encoding + ~description: + "Description of how the contract's Michelson was generated.") + (dft + "interfaces" + ~description: + "The list of interfaces the contract claims to implement \ + (e.g. TZIP-12)." + (list string) + []) + (opt "errors" ~description:"Error translators." Errors.encoding) + (dft + "views" + ~description: + "The storage queries, a.k.a. off-chain views provided." + (list View.encoding) + [])))) + +let of_json s = + try + let jsonm = Ezjsonm.value_from_string s in + let contents = Json_encoding.destruct encoding jsonm in + Ok contents + with e -> Error_monad.error_exn e + +let to_json c = + let jsonm = Json_encoding.construct encoding c in + Ezjsonm.value_to_string ~minify:false jsonm + +module Validation = struct + module Error = struct + type t = + | Forbidden_michelson_instruction of { + view : string; + instruction : string; + } + | Michelson_version_not_a_protocol_hash of { + view : string; + value : string; + } + + let pp ppf = + let open Fmt in + let textf f = kstr (fun s -> (box text) ppf s) f in + function + | Forbidden_michelson_instruction {view; instruction} -> + textf + "Forbidden Michelson instruction %S in view %S" + instruction + view + | Michelson_version_not_a_protocol_hash {view; value} -> + textf + "Michelson version %S in view %S is not a protocol hash" + value + view + end + + module Warning = struct + type t = + | Wrong_author_format of string + | Unexpected_whitespace of {field : string; value : string} + | Self_unaddressed of {view : string; instruction : string option} + + let pp ppf = + let open Fmt in + let textf f = kstr (fun s -> (box text) ppf s) f in + function + | Wrong_author_format auth -> + textf "Wrong format for author field: %S" auth + | Unexpected_whitespace {field; value} -> + textf + "Unexpected whitespace character(s) in field %S = %S" + field + value + | Self_unaddressed {view; instruction} -> + textf + "SELF instruction not followed by ADDRESS (%s) in view %S" + (Option.value instruction ~default:"by nothing") + view + end + + module Data = struct + let author_re = lazy Re.Posix.(re "^[^\\<\\>]*<[^ ]+>$" |> compile) + + let forbidden_michelson_instructions = + [ "AMOUNT"; + "CREATE_CONTRACT"; + "SENDER"; + "SET_DELEGATE"; + "SOURCE"; + "TRANSFER_TOKENS" ] + end + + open Data + + let validate ?(protocol_hash_is_valid = fun _ -> true) (metadata : t) = + let errors = ref [] in + let warnings = ref [] in + let error e = errors := e :: !errors in + let warning e = warnings := e :: !warnings in + let nl_or_tab = function '\n' | '\t' -> true | _ -> false in + let nl_or_tab_or_sp = function '\n' | '\t' | ' ' -> true | _ -> false in + let check_for_whitespace ?(whitespace = nl_or_tab) field value = + if Base.String.exists value ~f:whitespace then + warning Warning.(Unexpected_whitespace {field; value}) + in + let check_author = function + | s when not (Re.execp (Lazy.force author_re) s) -> + warning Warning.(Wrong_author_format s) + | _ -> + () + in + List.iter + (fun a -> + check_author a ; + check_for_whitespace "author" a) + metadata.authors ; + Option.iter (check_for_whitespace "name") metadata.name ; + Option.iter (check_for_whitespace "version") metadata.version ; + let check_view (v : View.t) = + let implementation (i : View.Implementation.t) = + let open View.Implementation in + match i with + | Michelson_storage {code = Micheline mich_code; version; _} -> ( + Option.iter + (fun value -> + if protocol_hash_is_valid value then () + else + error + (Error.Michelson_version_not_a_protocol_hash + {view = v.name; value})) + version ; + let open Tezos_micheline.Micheline in + let node = root mich_code in + let rec iter = function + | Int _ | String _ | Bytes _ -> + `Other "literal" + | Prim (_loc, p, args, _annots) -> ( + if List.mem p forbidden_michelson_instructions then + error + (Error.Forbidden_michelson_instruction + {view = v.name; instruction = p}) ; + let _ = List.map iter args in + match p with + | "SELF" -> + `Self + | "ADDRESS" -> + `Address + | _ -> + `Other p ) + | Seq (_loc, l) -> + let selves = List.map iter l in + ListLabels.fold_left + (selves : [`Address | `Other of string | `Self] list) + ~init: + (`Other "none" : [`Address | `Other of string | `Self]) + ~f:(fun prev cur -> + match (prev, cur) with + | (`Other _, _) -> + cur + | (`Self, `Address) -> + cur + | (`Self, _) -> + warning + Warning.( + Self_unaddressed + { + view = v.name; + instruction = + ( match cur with + | `Self -> + Some "SELF" + | `Other p -> + Some p + | `Address -> + assert false ); + }) ; + cur + | (`Address, _) -> + cur) + in + match iter node with + | `Self -> + warning + Warning.( + Self_unaddressed {view = v.name; instruction = None}) + | _ -> + () ) + | Rest_api_query _ -> + () + in + check_for_whitespace "view.name" v.name ~whitespace:nl_or_tab_or_sp ; + List.iter implementation v.implementations + in + List.iter check_view metadata.views ; + (List.rev !errors, List.rev !warnings) + + let pp ppf = + let open Fmt in + function + | ([], []) -> + pf ppf "No errors nor warnings." + | (errs, warns) -> + let pp_events prompt pp = + let itemize ppf = function + | [] -> + const string "None" ppf () + | more -> + (cut ++ list ~sep:cut (const string "* " ++ pp)) ppf more + in + vbox ~indent:2 (const string prompt ++ itemize) + in + vbox + ( const (pp_events "Errors: " Error.pp) errs + ++ cut + ++ const (pp_events "Warnings: " Warning.pp) warns ) + ppf + () +end + +module Example = struct + let rec build = function + | 0 -> + make [] + | 1 -> + make + [] + ~homepage:"https://gitlab.com/tezos/tezos" + ~name:"example-from-the-source" + ~description: + {txt|This is a fake metadata blob constructed at +src/lib_contract_metadata/core/metadata_contents.ml in the Tezos codebase. + +Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do +eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad +minim veniam, quis nostrud exercitation ullamco laboris nisi ut +aliquip ex ea commodo consequat. + +Duis aute irure dolor in reprehenderit in voluptate velit esse cillum +dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non +proident, sunt in culpa qui officia deserunt mollit anim id est +laborum. +|txt} + ~version:"0.42.0" + ~license:License.{name = "MIT"; details = Some "The MIT License"} + | 2 -> + let m1 = build 1 in + {m1 with interfaces = ["TZIP-16"; "TZIP-12"]} + | 3 -> + let m2 = build 2 in + { + m2 with + unknown = + [ ("source-repository", `String "https://gitlab.com/tezos/tezos"); + ("commit", `String "8d3077fb78ff157b36a72f15ff2d17df7c4763f7") ]; + } + | 4 -> + let m2 = build 2 in + {m2 with views = [View.Example.build 0]} + | 5 -> + let m2 = build 2 in + {m2 with views = [View.Example.build 0; View.Example.build 1]} + | _ -> + assert false + + let all () = + let rec o n = + try + let ex = build n in + ex :: o (n + 1) + with _ -> [] + in + o 0 +end diff --git a/src/lib_contract_metadata/metadata_contents.mli b/src/lib_contract_metadata/metadata_contents.mli new file mode 100644 index 0000000000000000000000000000000000000000..710818cb3f25497caaf68e2ba95eaffe34b1f8b4 --- /dev/null +++ b/src/lib_contract_metadata/metadata_contents.mli @@ -0,0 +1,235 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 TQ Tezos *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Implementation of the TZIP-16 metadata "content", a.k.a. JSON blob. *) + +(** This module defines types, their corresponding {!Json_encoding.t} + values, pretty-printers and some generative examples. + + The type [t] corresponds to the top-level fields of the metadata + JSON (section "Reserved Fields" in the specification), it's the + root for all the other submodules and it's encoding is used to + generate the JSON-Schema. +*) + +module License : sig + type t = {name : string; details : string option} + + val pp : Format.formatter -> t -> unit + + val encoding : t Json_encoding.encoding +end + +module Michelson_blob : sig + type t = Micheline of string Tezos_micheline.Micheline.canonical + + val pp : Format.formatter -> t -> unit + + val encoding : t Json_encoding.encoding +end + +module View : sig + module Implementation : sig + module Michelson_storage : sig + type t = { + parameter : Michelson_blob.t option; + return_type : Michelson_blob.t; + code : Michelson_blob.t; + human_annotations : (string * string) list; + version : string option; + } + end + + module Rest_api_query : sig + type t = { + specification_uri : string; + base_uri : string option; + path : string; + meth : Cohttp.Code.meth; + } + end + + type t = + | Michelson_storage of Michelson_storage.t + | Rest_api_query of Rest_api_query.t + + val michelson_storage : + ?parameter:Michelson_blob.t -> + return_type:Michelson_blob.t -> + ?annotations:(string * string) list -> + ?version:string -> + Michelson_blob.t -> + t + + val rest_api_query : + ?base_uri:string -> ?meth:Cohttp.Code.meth -> string -> string -> t + + val pp : ?with_code:bool -> Format.formatter -> t -> unit + + val encoding : t Json_encoding.encoding + + module Example : sig + val build : int -> t + end + end + + type t = { + name : string; + description : string option; + implementations : Implementation.t list; + is_pure : bool; + } + + val make : + ?description:string -> + ?is_pure:bool -> + string -> + Implementation.t list -> + t + + val pp : ?with_code:bool -> Format.formatter -> t -> unit + + val encoding : t Json_encoding.encoding + + module Example : sig + val build : int -> t + end +end + +module Source : sig + type t = {tools : string list; location : string option} + + val pp : Format.formatter -> t -> unit + + val encoding : t Json_encoding.encoding +end + +module Errors : sig + module Translation : sig + type t = + | Static of { + error : Michelson_blob.t; + expansion : Michelson_blob.t; + languages : string list option; + } + | Dynamic of {view_name : string; languages : string list option} + + val pp : Format.formatter -> t -> unit + + val encoding : t Json_encoding.encoding + end + + type t = Translation.t list + + val pp : Format.formatter -> Translation.t list -> unit + + val encoding : Translation.t list Json_encoding.encoding +end + +type t = { + name : string option; + description : string option; + version : string option; + license : License.t option; + authors : string list; + homepage : string option; + source : Source.t option; + interfaces : string list; + errors : Errors.t option; + views : View.t list; + unknown : (string * Ezjsonm.value) list; +} + +val make : + ?name:string -> + ?description:string -> + ?version:string -> + ?license:License.t -> + ?authors:string list -> + ?homepage:string -> + ?source:Source.t -> + ?interfaces:string list -> + ?errors:Errors.t -> + ?extras:(string * Ezjsonm.value) list -> + View.t list -> + t + +val pp : Format.formatter -> t -> unit + +val pp_short : Format.formatter -> t -> unit + +val encoding : t Json_encoding.encoding + +val of_json : string -> t Error_monad.tzresult + +val to_json : t -> string + +module Validation : sig + module Error : sig + type t = + | Forbidden_michelson_instruction of { + view : string; + instruction : string; + } + | Michelson_version_not_a_protocol_hash of { + view : string; + value : string; + } + + val pp : Format.formatter -> t -> unit + end + + module Warning : sig + type t = + | Wrong_author_format of string + | Unexpected_whitespace of {field : string; value : string} + | Self_unaddressed of {view : string; instruction : string option} + + val pp : Format.formatter -> t -> unit + end + + module Data : sig + val author_re : Re.re lazy_t + + val forbidden_michelson_instructions : string list + end + + (** Run the validation on a metadata instance. The default + [protocol_hash_is_valid] is [(fun _ -> true)], so by default the + error [Michelson_version_not_a_protocol_hash _] is not reported (for + library dependency reasons). *) + val validate : + ?protocol_hash_is_valid:(string -> bool) -> + t -> + Error.t list * Warning.t list + + val pp : Format.formatter -> Error.t list * Warning.t list -> unit +end + +module Example : sig + val build : int -> t + + val all : unit -> t list +end diff --git a/src/lib_contract_metadata/metadata_uri.ml b/src/lib_contract_metadata/metadata_uri.ml new file mode 100644 index 0000000000000000000000000000000000000000..c714107688fea566df937396ef35d23c6b2445a8 --- /dev/null +++ b/src/lib_contract_metadata/metadata_uri.ml @@ -0,0 +1,302 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 TQ Tezos *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +type hash_kind = [`Sha256] + +type t = + | Web of string + | Ipfs of {cid : string; path : string} + | Storage of {network : string option; address : string option; key : string} + | Hash of {kind : hash_kind; value : string; target : t} + +module Parsing_error = struct + type error_kind = + | Wrong_scheme of string option + | Missing_cid_for_ipfs + | Wrong_tezos_storage_host of string + | Forbidden_slash_in_tezos_storage_path of string + | Missing_host_for_hash_uri of hash_kind + | Wrong_hex_format_for_hash of { + hash : hash_kind; + host : string; + message : string; + } + + type t = {input : string; error_kind : error_kind} + + let pp ppf {input; error_kind} = + let open Fmt in + let err_fmt = function + | Wrong_scheme None -> + const text "Missing URI scheme" + | Wrong_scheme (Some s) -> + kstr (const text) "Unknown URI scheme: %S" s + | Missing_cid_for_ipfs -> + const text "Missing CID in ipfs:// URI" + | Wrong_tezos_storage_host s -> + kstr (const text) "Wrong host for tezos-storage: %S" s + | Forbidden_slash_in_tezos_storage_path s -> + kstr (const text) "Forbidden slash in tezos-storage path: %S" s + | Missing_host_for_hash_uri `Sha256 -> + const text "Missing hash in sha256:// URI" + | Wrong_hex_format_for_hash {hash = `Sha256; host; message} -> + kstr + (const text) + "Wrong hex-format for sha256:// URI: %S -> %s" + host + message + in + pf + ppf + "%a" + (box + ( const text "Error while parsing" + ++ const (quote string) input + ++ const string ":" ++ sp ++ err_fmt error_kind )) + () + + let encoding = + let open Data_encoding in + let err_kind = + let cases = ref [] (* imperative ⇒ proper tag numbers *) in + let special_case name enc proj find = + let c = + case + ~title:name + (Tag (List.length !cases)) + (obj1 (req name enc)) + proj + find + in + cases := c :: !cases + in + let hash_kind = + union + [ case + ~title:"sha256" + (Tag 0) + (constant "sha256") + (function `Sha256 -> Some ()) + (function () -> `Sha256) ] + in + special_case + "wrong-scheme" + (option string) + (function Wrong_scheme s -> Some s | _ -> None) + (fun o -> Wrong_scheme o) ; + special_case + "missing-cid" + unit + (function Missing_cid_for_ipfs -> Some () | _ -> None) + (fun () -> Missing_cid_for_ipfs) ; + special_case + "wrong-tezos-storage-host" + string + (function Wrong_tezos_storage_host s -> Some s | _ -> None) + (fun o -> Wrong_tezos_storage_host o) ; + special_case + "slash-in-tezos-storage-path" + string + (function + | Forbidden_slash_in_tezos_storage_path s -> Some s | _ -> None) + (fun o -> Forbidden_slash_in_tezos_storage_path o) ; + special_case + "missing-host-for-hash-uri" + hash_kind + (function Missing_host_for_hash_uri s -> Some s | _ -> None) + (fun o -> Missing_host_for_hash_uri o) ; + special_case + "wrong-hex-format-for-hash" + (obj3 (req "hash" hash_kind) (req "host" string) (req "message" string)) + (function + | Wrong_hex_format_for_hash {hash; host; message} -> + Some (hash, host, message) + | _ -> + None) + (fun (hash, host, message) -> + Wrong_hex_format_for_hash {hash; host; message}) ; + union (List.rev !cases) + in + conv + (fun {input; error_kind} -> (input, error_kind)) + (fun (input, error_kind) -> {input; error_kind}) + (obj2 (req "input" string) (req "kind" err_kind)) +end + +open Error_monad + +type error += Contract_metadata_uri_parsing of Parsing_error.t + +let () = + register_error_kind + `Permanent + ~id:"contract_metadata.uri.parsing_error" + ~title:"Contract Metadata Parsing Error" + ~description:"An error occurred while parsing a contract metadata URI." + ~pp:Parsing_error.pp + Parsing_error.encoding + (function Contract_metadata_uri_parsing err -> Some err | _ -> None) + (fun err -> Contract_metadata_uri_parsing err) + +type field_validation = + string -> + ( unit, + Tezos_error_monad.Error_monad.error + Tezos_error_monad.Error_monad.TzTrace.trace ) + result + +let rec of_uri ?validate_network ?validate_kt1_address uri = + let open Uri in + let open Parsing_error in + let fail error_kind = + error + (Contract_metadata_uri_parsing {input = Uri.to_string uri; error_kind}) + in + let remove_first_slash s = + match Tezos_stdlib.TzString.remove_prefix s ~prefix:"/" with + | Some cleaned -> + cleaned + | None -> + s + in + match scheme uri with + | None -> + fail (Wrong_scheme None) + | Some "https" | Some "http" -> + ok (Web (to_string uri)) + | Some "ipfs" -> ( + let path = path uri in + match host uri with + | None -> + fail Missing_cid_for_ipfs + | Some cid -> + ok (Ipfs {cid; path}) ) + | Some "tezos-storage" -> ( + ( match host uri with + | None -> + ok (None, None) + | Some s -> ( + match Tezos_stdlib.TzString.split '.' s with + | [one] -> + ok (None, Some one) + | [one; two] -> + ok (Some two, Some one) + | _ -> + fail (Wrong_tezos_storage_host s) ) ) + >>? fun (network, address) -> + let validate_option f v = + match (f, v) with + | (Some (validate : field_validation), Some value) -> + validate value + | (_, _) -> + ok () + in + validate_option validate_network network + >>? fun () -> + validate_option validate_kt1_address address + >>? fun () -> + match remove_first_slash (path uri) with + | k when String.contains k '/' -> + fail (Forbidden_slash_in_tezos_storage_path k) + | k -> + let key = Uri.pct_decode k in + ok (Storage {network; address; key}) ) + | Some "sha256" -> ( + match host uri with + | None -> + fail (Missing_host_for_hash_uri `Sha256) + | Some host -> ( + let fail_m message = + fail (Wrong_hex_format_for_hash {hash = `Sha256; host; message}) + in + match Tezos_stdlib.TzString.remove_prefix host ~prefix:"0x" with + | Some hex -> ( + match Hex.to_string (`Hex hex) with + | value -> + of_uri + ( Uri.path uri |> remove_first_slash |> Uri.pct_decode + |> Uri.of_string ) + >>? fun target -> ok (Hash {kind = `Sha256; value; target}) + | exception exn -> + Fmt.kstr + fail_m + "Hex-to-string conversion error: %s" + ( match exn with + | Invalid_argument ia -> + ia + | other -> + Printexc.to_string other ) ) + | None -> + Fmt.kstr fail_m "Host does not start with 0x" ) ) + | Some s -> + fail (Wrong_scheme (Some s)) + +let rec to_string_uri = function + | Web s -> + s + | Ipfs {cid; path} -> + Fmt.str "ipfs://%s%s" cid path + | Storage {network; address; key} -> + Fmt.str + "tezos-storage:%s%s" + ( match (network, address) with + | (None, None) -> + "" + | (Some n, Some a) -> + Fmt.str "//%s.%s/" a n + | (Some x, None) | (None, Some x) -> + Fmt.str "//%s/" x ) + (Uri.pct_encode key) + | Hash {kind = `Sha256; value; target} -> + Fmt.str + "sha256://0x%s/%s" + (let (`Hex hx) = Hex.of_string value in + hx) + (Uri.pct_encode (to_string_uri target)) + +let rec pp ppf (t : t) = + let open Fmt in + match t with + | Web s -> + pf ppf "Web-URL: %s" s + | Ipfs {cid; path} -> + pf ppf "IPFS-URI: CID: %s PATH: %s" cid path + | Storage {network; address; key} -> + pf + ppf + "On-chain: %a.%a @%S" + (option ~none:(const string "current-network") string) + network + (option ~none:(const string "current-contract") string) + address + key + | Hash {kind; value; target} -> + pf + ppf + "%s(%a) = %s" + (match kind with `Sha256 -> "sha256") + pp + target + value diff --git a/src/lib_contract_metadata/metadata_uri.mli b/src/lib_contract_metadata/metadata_uri.mli new file mode 100644 index 0000000000000000000000000000000000000000..b92dff3eb0526747b4b90f8834cfe6505ec7129f --- /dev/null +++ b/src/lib_contract_metadata/metadata_uri.mli @@ -0,0 +1,83 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 TQ Tezos *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Implementation of the TZIP-16 metadata URIs. *) + +type hash_kind = [`Sha256] + +(** The type for {i parsed} metadata URIs. *) +type t = + | Web of string (** A web-URI is an ["http://"] or ["https://"] URL. *) + | Ipfs of {cid : string; path : string} (** An IPFS URI. *) + | Storage of {network : string option; address : string option; key : string} + (** A URI pointing inside a contract's storage. *) + | Hash of {kind : hash_kind; value : string; target : t} + (** A ["sha256://0xdeadbeef/"] checked URI. *) + +module Parsing_error : sig + type error_kind = + | Wrong_scheme of string option + | Missing_cid_for_ipfs + | Wrong_tezos_storage_host of string + | Forbidden_slash_in_tezos_storage_path of string + | Missing_host_for_hash_uri of hash_kind + | Wrong_hex_format_for_hash of { + hash : hash_kind; + host : string; + message : string; + } + + type t = {input : string; error_kind : error_kind} + + val pp : Format.formatter -> t -> unit + + val encoding : t Data_encoding.encoding +end + +type Error_monad.error += Contract_metadata_uri_parsing of Parsing_error.t + +type field_validation = + string -> + ( unit, + Tezos_error_monad.Error_monad.error + Tezos_error_monad.Error_monad.TzTrace.trace ) + result + +(** Parse a metadata URI, validation of the network and address fields + is left optional. *) +val of_uri : + ?validate_network:field_validation -> + ?validate_kt1_address:field_validation -> + Uri.t -> + ( t, + Tezos_error_monad.Error_monad.error + Tezos_error_monad.Error_monad.TzTrace.trace ) + result + +(** Make a parsable URI. *) +val to_string_uri : t -> string + +(** Pretty-print a URI. *) +val pp : Format.formatter -> t -> unit diff --git a/src/lib_contract_metadata/micheline_helpers.ml b/src/lib_contract_metadata/micheline_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..9dbda650d4a8863ae88c1e81c42bb42705b1fac0 --- /dev/null +++ b/src/lib_contract_metadata/micheline_helpers.ml @@ -0,0 +1,136 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 TQ Tezos *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Tezos_micheline + +let get_script_field_exn string_micheline field = + let open Micheline in + let type_opt = + match root string_micheline with + | Seq (_, l) -> + Base.List.find_map l ~f:(function + | Prim (_, f, [t], _) when f = field -> + Some t + | _ -> + None) + | _ -> + None + in + match type_opt with + | None -> + Fmt.failwith "Cannot find the %S field for the contract" field + | Some s -> + s + +let get_storage_type_exn string_micheline = + get_script_field_exn string_micheline "storage" + +let get_parameter_type_exn string_micheline = + get_script_field_exn string_micheline "parameter" + +let pp_arbitrary_micheline ppf e = + let module P = Micheline_printer in + P.print_expr + ppf + (Micheline.map_node (fun _ -> {P.comment = None}) (fun x -> x) e) + +let rec find_metadata_big_maps ~storage_node ~type_node = + let open Micheline in + let go (storage_node, type_node) = + find_metadata_big_maps ~storage_node ~type_node + in + match (storage_node, type_node) with + | (Prim (_, "Pair", [l; r], _), Prim (_, "pair", [lt; rt], _)) -> + go (l, lt) @ go (r, rt) + | ( Int (_, z), + Prim + ( _, + "big_map", + [Prim (_, "string", [], _); Prim (_, "bytes", [], _)], + ["%metadata"] ) ) -> + [z] + | (Int (_, _z), _) -> + [] + | (String (_, _s), _) -> + [] + | (Bytes (_, _b), _) -> + [] + | (Prim (_, _prim, _args, _annot), _t) -> + [] + | (Seq (_, _l), _t) -> + [] + +let build_off_chain_view_contract view ~contract_balance ~contract_address + ~contract_storage_type ~contract_parameter_type ~view_parameters + ~contract_storage = + let open Metadata_contents.View in + let open Metadata_contents.Michelson_blob in + let open Implementation.Michelson_storage in + let open Micheline in + let getm = function Micheline m -> root m in + let seq l = Seq (0, l) in + let prim p l = Prim (0, p, l, []) in + let (parameter, input) = + match Option.map getm view.parameter with + | Some m -> + ( prim "pair" [m; contract_storage_type], + prim "Pair" [view_parameters; contract_storage] ) + | None -> + (contract_storage_type, contract_storage) + in + let storage = getm view.return_type in + let code = getm view.code in + let rec fix_code c = + let continue = List.map fix_code in + match c with + | (Int _ | String _ | Bytes _) as lit -> + lit + | Prim (loc, "SELF", [], annots) -> + seq + [ prim "PUSH" [prim "address" []; String (loc, contract_address)]; + Prim (loc, "CONTRACT", [contract_parameter_type], annots); + prim "IF_NONE" [seq [prim "UNIT" []; prim "FAILWITH" []]; seq []] + ] + | Prim (loc, "BALANCE", [], annots) -> + Prim (loc, "PUSH", [prim "mutez" []; Int (0, contract_balance)], annots) + | Prim (loc, name, args, annots) -> + Prim (loc, name, continue args, annots) + | Seq (loc, l) -> + Seq (loc, continue l) + in + ( `Contract + (seq + [ prim "parameter" [parameter]; + prim "storage" [prim "option" [storage]]; + prim + "code" + [ seq + [ prim "CAR" [] (* We drop the storage (= None). *); + fix_code code; + prim "SOME" []; + prim "NIL" [prim "operation" []]; + prim "PAIR" [] ] ] ]), + `Input input, + `Storage (prim "None" []) ) diff --git a/src/lib_contract_metadata/micheline_helpers.mli b/src/lib_contract_metadata/micheline_helpers.mli new file mode 100644 index 0000000000000000000000000000000000000000..d70ed43b58bf062aeeeec84c5da73e14a048bc8f --- /dev/null +++ b/src/lib_contract_metadata/micheline_helpers.mli @@ -0,0 +1,70 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 TQ Tezos *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Contract-storage-parsing helper functions for the implementation + of TZIP-16. *) + +(** Find the ["storage"] section of a Micheline-encoded Michelson contract. + + @raises [Failure _] if not found. *) +val get_storage_type_exn : + string Tezos_micheline.Micheline.canonical -> + ( Tezos_micheline.Micheline.canonical_location, + string ) + Tezos_micheline.Micheline.node + +(** Find the ["parameter"] section of a Micheline-encoded Michelson contract. + + @raises [Failure _] if not found. *) +val get_parameter_type_exn : + string Tezos_micheline.Micheline.canonical -> + ( Tezos_micheline.Micheline.canonical_location, + string ) + Tezos_micheline.Micheline.node + +(** Pretty-print a piece of Micheline regardless of the location type. *) +val pp_arbitrary_micheline : + Format.formatter -> ('a, string) Tezos_micheline.Micheline.node -> unit + +(** Assuming that [storage_node] is the storage expression of a + contract has type [type_node], find the identifier of + metadata-big-map according to the TZIP-16 specification. *) +val find_metadata_big_maps : + storage_node:('a, string) Tezos_micheline.Micheline.node -> + type_node:('b, string) Tezos_micheline.Micheline.node -> + Z.t list + +(** Build a contract for the [".../run_script"] RPC of the node. *) +val build_off_chain_view_contract : + Metadata_contents.View.Implementation.Michelson_storage.t -> + contract_balance:Z.t -> + contract_address:string -> + contract_storage_type:(int, string) Tezos_micheline.Micheline.node -> + contract_parameter_type:(int, string) Tezos_micheline.Micheline.node -> + view_parameters:(int, string) Tezos_micheline.Micheline.node -> + contract_storage:(int, string) Tezos_micheline.Micheline.node -> + [`Contract of (int, string) Tezos_micheline.Micheline.node] + * [`Input of (int, string) Tezos_micheline.Micheline.node] + * [`Storage of (int, string) Tezos_micheline.Micheline.node] diff --git a/src/lib_contract_metadata/tezos-contract-metadata.opam b/src/lib_contract_metadata/tezos-contract-metadata.opam new file mode 100644 index 0000000000000000000000000000000000000000..035da2c19793a140d5efce0ee1459cd73fad7c70 --- /dev/null +++ b/src/lib_contract_metadata/tezos-contract-metadata.opam @@ -0,0 +1,19 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "tezos-tooling" { with-test } + "dune" { >= "1.11" } + "tezos-micheline" + "cohttp" + "fmt" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Implementation of TZIP-16: core types and converters" diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/alpha_commands_registration.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/alpha_commands_registration.ml index e949d736951e81ff6a28d88c5cf4ae1fcc9e1081..517ba9c37d5f4c86083929a64ec1c4f4e9a27eff 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/alpha_commands_registration.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/alpha_commands_registration.ml @@ -33,4 +33,5 @@ let () = @ Client_proto_context_commands.commands network () @ Client_proto_multisig_commands.commands () @ Client_proto_mockup_commands.commands () + @ Contract_metadata_commands.all @ Client_sapling_commands.commands () diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/contract_metadata_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/contract_metadata_commands.ml new file mode 100644 index 0000000000000000000000000000000000000000..483a7cf4cbc2ab9e156dbf4fd10895f007094e49 --- /dev/null +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/contract_metadata_commands.ml @@ -0,0 +1,596 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 TQ Tezos *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Protocol +open Tezos_micheline +open Client_proto_context +open Client_proto_contracts +open Tezos_contract_metadata + +module Log = Internal_event.Legacy_logging.Make (struct + let name = Printf.sprintf "client.%s.metadata_commands" Protocol.name +end) + +let get_big_map_string_at_string (cctxt : #Protocol_client_context.full) bm + ~key = + let (data, typ) = + let open Alpha_context.Script in + let open Micheline in + ( strip_locations (String (0, key)), + strip_locations (Prim (0, T_string, [], [])) ) + in + Alpha_services.Helpers.Scripts.pack_data + cctxt + (cctxt#chain, cctxt#block) + ?gas:None + ~data + ~ty:typ + >>=? fun (bytes, _remaining_gas) -> + get_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~unparsing_mode:Script_ir_translator.Optimized_legacy + bm + (Script_expr_hash.hash_bytes [bytes]) + >>=? fun expr -> + match Michelson_v1_primitives.strings_of_prims expr |> Micheline.root with + | Bytes (_, s) -> + return (Bytes.to_string s) + | _ -> + cctxt#error + "Value at %S is not a string: %a" + key + Michelson_v1_printer.print_expr_unwrapped + expr + +let get_storage_and_type_micheline (cctxt : #Protocol_client_context.full) + ~chain ~block contract = + get_script cctxt ~chain ~block contract + >>=? (function + | None -> + cctxt#error "This is not a smart contract." + | Some script -> + return script) + >>=? fun script -> + ( match script.code |> Data_encoding.force_decode with + | None -> + cctxt#error "Cannot decode storage." + | Some s -> + return s ) + >>=? fun code -> + get_storage cctxt ~chain:cctxt#chain ~block:cctxt#block contract + >>=? function + | None -> + cctxt#error "This is not a smart contract." + | Some storage -> + let storage_root_node = + let string_micheline : string Tezos_micheline.Micheline.canonical = + Michelson_v1_primitives.strings_of_prims storage + in + Micheline.root string_micheline + in + let (type_root_node, parameter_root_node) = + let string_micheline : string Tezos_micheline.Micheline.canonical = + Michelson_v1_primitives.strings_of_prims code + in + ( Micheline_helpers.get_storage_type_exn string_micheline, + Micheline_helpers.get_parameter_type_exn string_micheline ) + in + return (storage_root_node, type_root_node, parameter_root_node) + +let get_metadata_big_map_value (cctxt : #Protocol_client_context.full) ~chain + ~block contract ~key = + get_storage_and_type_micheline cctxt ~chain ~block contract + >>=? fun (storage_node, type_node, _) -> + match Micheline_helpers.find_metadata_big_maps ~storage_node ~type_node with + | [] -> + cctxt#error + "Cannot find metadata big-map within@ '%a'@ of@ type@ '%a'" + Micheline_helpers.pp_arbitrary_micheline + storage_node + Micheline_helpers.pp_arbitrary_micheline + type_node + | [one] -> + (* dbg "TODO: explore %a" Z.pp_print one ; *) + get_big_map_string_at_string + cctxt + (Protocol.Alpha_context.Big_map.Id.parse_z one) + ~key + | more -> + cctxt#error + "Found too many (= %d) metadata big-maps within@ '%a'@ of@ type@ '%a'" + (List.length more) + Micheline_helpers.pp_arbitrary_micheline + storage_node + Micheline_helpers.pp_arbitrary_micheline + type_node + +let rec fetch_uri_contents (cctxt : #Protocol_client_context.full) + ~current_contract uri = + let open Metadata_uri in + let ni fmt = cctxt#error ("Not implemented: " ^^ fmt) in + let get url = + Cohttp_lwt_unix.Client.get (Uri.of_string url) + >>= fun (resp, body) -> + match Cohttp.Response.status resp with + | `OK -> + Cohttp_lwt.Body.to_string body >>= fun content -> return content + | _ -> + cctxt#error "Wrong HTTP status: %a" Cohttp.Response.pp_hum resp + in + match uri with + | Web url -> + get url + | Ipfs {cid; path} -> + (* https://docs.ipfs.io/how-to/address-ipfs-on-web/#dweb-addressing-in-brief *) + let url = + let prefix = Uri.path cctxt#ipfs_gateway in + Uri.with_path cctxt#ipfs_gateway (Filename.concat prefix (cid ^ path)) + |> Uri.to_string + in + Log.lwt_debug "IPFS URI transformed into %s" url >>= fun () -> get url + | Storage {network = Some n; _} -> + ni "Network = %s in storage URI" n + | Storage {network = None; address; key} -> + ( match address with + | None -> + return current_contract + | Some addr -> + Lwt.return + (Environment.wrap_error (Alpha_context.Contract.of_b58check addr)) + ) + >>=? fun contract -> + get_metadata_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + ~key + | Hash {kind = `Sha256; value; target} -> + fetch_uri_contents cctxt ~current_contract target + >>=? fun content -> + let real_hash = + Hacl.Hash.SHA256.digest (Bytes.of_string content) |> Bytes.to_string + in + if real_hash <> value then + cctxt#error + "SHA256-hash 0x%a@ for@ metadata@ at@ %a@ does@ not@ match@ the@ \ + expected@ value:@ 0x%a" + Hex.pp + (Hex.of_string real_hash) + Metadata_uri.pp + target + Hex.pp + (Hex.of_string value) + else return content + +let get_metadata_of_contract ?(strict = true) cctxt ~contract = + get_metadata_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + ~key:"" + >>=? fun value -> + let uri = Uri.of_string value in + let (validate_network, validate_kt1_address) = + if strict then + ( Some + (function + | "mainnet" | "carthagenet" | "delphinet" | "dalphanet" -> + ok () + | chain_id -> + Tezos_crypto.Chain_id.of_b58check chain_id >>? fun _ -> ok ()), + Some + (fun s -> + match Protocol.Contract_hash.of_b58check_opt s with + | Some _kt1 -> + ok () + | None -> + error (failure "%S is not a valid contract address" s)) ) + else (None, None) + in + Lwt.return (Metadata_uri.of_uri ?validate_network ?validate_kt1_address uri) + >>=? fun parsed_uri -> + fetch_uri_contents cctxt ~current_contract:contract parsed_uri + +let group = + { + Clic.name = "contract-metadata"; + title = + "Block contextual commands related to the Contract Metadata (TZIP-16)"; + } + +module Output_path = struct + let arg = + Clic.( + arg + ~doc:"Output path" + ~long:"output" + ~placeholder:"PATH" + (parameter (fun _ s -> return s))) + + let output ?(none = fun _ -> return ()) output_path_opt content = + match output_path_opt with + | None -> + none content + | Some s -> + Lwt_io.with_file ~mode:Lwt_io.output s (fun ochan -> + Lwt_io.fprint ochan content) + >>= fun () -> return_unit +end + +let all = + let open Clic in + [ command + ~group + ~desc:"Get the JSON-Schema and example of TZIP-016 metadata." + (args2 + (switch ~doc:"Also output examples." ~long:"with-examples" ()) + (default_arg + ~doc:"Output path" + ~long:"output" + ~placeholder:"PATH" + ~default:"/tmp/tzip-16-metadata" + (parameter (fun _ s -> return s)))) + (fixed ["get"; "contract"; "metadata"; "schema"]) + (fun (with_examples, output_path) (cctxt : Protocol_client_context.full) -> + cctxt#message + "Outputting to %S with%s examples." + output_path + (if with_examples then "" else "out") + >>= fun () -> + Lwt_utils_unix.create_dir output_path + >>= fun () -> + let schema = Json_encoding.schema Metadata_contents.encoding in + let path = Filename.(concat output_path "schema.json") in + cctxt#message "Outputting schema to %S." path + >>= fun () -> + Lwt_io.with_file ~mode:Lwt_io.output path (fun o -> + Lwt_io.fprintl + o + ( Json_schema.to_json schema + |> Ezjsonm.value_to_string ~minify:false )) + >>= fun () -> + cctxt#message "Outputting examples." + >>= fun () -> + if with_examples then + Lwt_list.iteri_s + (fun ith example -> + let path = + Filename.(concat output_path (Fmt.str "example-%03d.json" ith)) + in + cctxt#message + "@[<2>Outputting example #%d@ to %S:@ %a@]" + ith + path + Metadata_contents.pp + example + >>= fun () -> + Lwt_io.with_file ~mode:Lwt_io.output path (fun o -> + let jzon = + Json_encoding.construct Metadata_contents.encoding example + |> Ezjsonm.value_to_string ~minify:false + in + Lwt_io.fprintl o jzon)) + (Metadata_contents.Example.all ()) + >>= fun () -> return_unit + else return_unit); + command + ~group + ~desc:"Fetch and output the metadata from a KT1 contract." + (args3 + (default_arg + ~doc: + "Output format: 'text', 'text:short', 'text:full', 'raw', or \ + 'json'." + ~long:"format" + ~placeholder:"FORMAT" + ~default:"JSON" + (parameter (fun _ s -> + match String.lowercase_ascii s with + | "text" -> + return (`Text `Full) + | "text:full" -> + return (`Text `Full) + | "text:short" -> + return (`Text `Short) + | "raw" -> + return `Raw + | "json" -> + return `Json + | other -> + failwith "Output format unknown: %S" other))) + Output_path.arg + (arg + ~doc: + "Also display extra validation errors and warnings. Default: \ + true when output format is text, false otherwise." + ~long:"validate" + ~placeholder:"BOOL" + (parameter (fun _ s -> + match String.lowercase_ascii s with + | "true" -> + return true + | "false" -> + return false + | other -> + failwith "Cannot understand boolean %S" other)))) + ( prefixes ["get"; "metadata"; "for"; "contract"] + @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" + @@ stop ) + (fun (output_format, output_path_opt, validation) + (_, contract) + (cctxt : Protocol_client_context.full) -> + let should_validate = + match (validation, output_format) with + | (Some true, _) | (None, `Text `Full) -> + true + | _ -> + false + in + get_metadata_of_contract cctxt ~contract ~strict:should_validate + >>=? fun content -> + let none s = cctxt#message "%s" s >>= fun () -> return_unit in + let maybe_show_validation f = + let protocol_hash_is_valid s = + match Tezos_crypto.Protocol_hash.of_b58check_opt s with + | None -> + false + | Some _ -> + true + in + if should_validate then + f (fun c -> + return + (Metadata_contents.Validation.validate + ~protocol_hash_is_valid + c)) + >>=? fun errs_and_warns -> + cctxt#message + "@[<2>Validation result:@ %a@]" + Metadata_contents.Validation.pp + errs_and_warns + >>= fun () -> + match fst errs_and_warns with + | [] -> + return_unit + | more -> + failwith "There were %d validation errors." (List.length more) + else return_unit + in + match output_format with + | `Text style -> + Lwt.return (Metadata_contents.of_json content) + >>=? fun contents -> + let meta_pp = + match style with + | `Full -> + Metadata_contents.pp + | `Short -> + Metadata_contents.pp_short + in + Output_path.output + ~none + output_path_opt + (Format.asprintf "%a" meta_pp contents) + >>=? fun () -> + maybe_show_validation (fun validate -> validate contents) + | `Raw -> + Output_path.output ~none output_path_opt content + >>=? fun () -> + maybe_show_validation (fun validate -> + Lwt.return (Metadata_contents.of_json content) + >>=? fun contents -> validate contents) + | `Json -> + Lwt.return (Metadata_contents.of_json content) + >>=? fun contents -> + Output_path.output + ~none + output_path_opt + (Metadata_contents.to_json contents) + >>=? fun () -> + maybe_show_validation (fun validate -> validate contents)); + command + ~group + ~desc:"Get a value from a TZIP-016 %metadata big-map." + no_options + ( prefixes ["get"; "metadata"; "element"] + @@ Clic.string ~name:"key" ~desc:"the string key to look for" + @@ prefixes ["from"] + @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" + @@ stop ) + (fun () key (_, contract) (cctxt : Protocol_client_context.full) -> + get_metadata_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + ~key + >>=? fun value -> cctxt#answer "%S" value >>= fun () -> return_unit); + command + ~group + ~desc:"Call an off-chain-view from a TZIP-016-enabled contract." + (args4 + (Client_proto_args.unparsing_mode_arg ~default:"Readable") + Output_path.arg + (switch + ~doc:"Output JSON instead of concrete Micheline syntax." + ~long:"json" + ()) + (default_arg + ~doc:"Michelson argument to pass to the view." + ~long:"arg" + ~placeholder:"MICHELSON" + ~default:"Unit" + (parameter (fun _ s -> + let open Micheline_parser in + Lwt.return (no_parsing_error (tokenize s)) + >>=? fun tokens -> + Lwt.return (no_parsing_error (parse_expression tokens)) + >>=? fun mich -> return (Micheline.strip_locations mich))))) + ( prefixes ["query"; "off-chain-view"] + @@ Clic.string ~name:"name" ~desc:"The view to call." + @@ prefixes ["from"] + @@ ContractAlias.destination_param ~name:"contract" ~desc:"KT1 contract" + @@ stop ) + (fun (unparsing_mode, output_path_opt, json, input_michelson) + name + (_, contract) + (cctxt : Protocol_client_context.full) -> + get_metadata_of_contract ~strict:false cctxt ~contract + >>=? fun content -> + let open Metadata_contents in + let open View in + Lwt.return (of_json content) + >>=? fun metadata -> + ( match + List.find_all (fun {name = n; _} -> n = name) metadata.views + with + | [one] -> + return one + | [] -> + cctxt#error + "View not found: %S, available views: %a" + name + Fmt.(vbox (one_of ~empty:(any "None") pp)) + metadata.views + | one :: _more -> + cctxt#warning + "Too many views called %S going with %a" + name + (pp ~with_code:true) + one + >>= fun () -> return one ) + >>=? fun view -> + Implementation.( + match + List.filter_map + (function Michelson_storage s -> Some s | _ -> None) + view.implementations + with + | [] -> + cctxt#error + "View %S does not have any michelson-storage implementation." + name + | [one] -> + return one + | one :: more -> + cctxt#warning + "Using the first michelson-storage implementation of %d" + (List.length more + 1) + >>= fun () -> return one) + >>=? fun first_michelson_implementation -> + get_storage_and_type_micheline + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + >>=? fun (storage_node, type_node, parameter_node) -> + get_balance cctxt ~chain:cctxt#chain ~block:cctxt#block contract + >>=? fun contract_balance -> + let (`Contract the_contract, `Input input_node, `Storage init_storage) + = + Micheline_helpers.build_off_chain_view_contract + first_michelson_implementation + ~contract_balance: + (Alpha_context.Tez.to_mutez contract_balance |> Z.of_int64) + ~contract_address:(Alpha_context.Contract.to_b58check contract) + ~contract_storage_type:type_node + ~contract_parameter_type:parameter_node + ~view_parameters:(Micheline.root input_michelson) + ~contract_storage:storage_node + in + (* We need to print and reparse+type-check the `string Micheline.node`s + into the protocol's own Michelson in order to use the typed + RPC `Client_proto_programs.run`: *) + let program = + Fmt.str "%a" Micheline_helpers.pp_arbitrary_micheline the_contract + in + let input = + Fmt.str "%a" Micheline_helpers.pp_arbitrary_micheline input_node + in + let storage = + Fmt.str "%a" Micheline_helpers.pp_arbitrary_micheline init_storage + in + let parse_expr expr = + Lwt.return @@ Micheline_parser.no_parsing_error + @@ Michelson_v1_parser.parse_expression expr + in + parse_expr program + >>=? fun program -> + parse_expr storage + >>=? fun storage -> + parse_expr input + >>=? fun input -> + Client_proto_programs.run + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~unparsing_mode + ~program + ~storage + ~input + ~balance:Alpha_context.Tez.zero + (* Balance has been fixed by build_off_chain_view_contract *) + () + >>= function + | Ok (storage_result, _, _) -> ( + let open Michelson_v1_primitives in + let open Micheline in + match root storage_result with + | Prim (_, D_Some, [one], _) -> + let result = strip_locations one in + let to_output = + match json with + | false -> + Fmt.str "%a\n" Michelson_v1_printer.print_expr result + | true -> + let enc = + Micheline.canonical_encoding_v1 + ~variant:"result" + Michelson_v1_primitives.prim_encoding + in + Data_encoding.Json.construct enc result + |> Data_encoding.Json.to_string + ~newline:true + ~minify:false + in + Output_path.output + ~none:(fun s -> + cctxt#message "%s" s >>= fun () -> return_unit) + output_path_opt + to_output + | _ -> + cctxt#error + "@[@[%a:@]@,%a@]" + Format.pp_print_text + "Running the off-chain-view failed in an unexpected way, \ + please report a bug" + Michelson_v1_printer.print_expr + storage_result ) + | Error el -> + cctxt#error "Run failed: %a" Error_monad.pp_print_error el) ] diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/dune b/src/proto_008_PtEdo2Zk/lib_client_commands/dune index 8c832520c7d2131987ced9111c0e29e429bc94f5..87b59672292fa7367a668a715404308888e662e6 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/dune +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/dune @@ -12,6 +12,8 @@ tezos-client-008-PtEdo2Zk tezos-client-commands tezos-rpc + tezos-rpc-http-client-unix + tezos-contract-metadata tezos-protocol-plugin-008-PtEdo2Zk) (library_flags (:standard -linkall)) (modules (:standard \ alpha_commands_registration)) diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands.opam b/src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands.opam index 80de5f365119b2115850f8089cdbba289b3c10e3..3d1cbfd0d9fc14202c13d2f79c7dc309f1d3f8b8 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands.opam +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/tezos-client-008-PtEdo2Zk-commands.opam @@ -15,6 +15,8 @@ depends: [ "tezos-client-base-unix" "tezos-client-008-PtEdo2Zk" "tezos-client-commands" + "tezos-rpc-http-client-unix" + "tezos-contract-metadata" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/proto_alpha/lib_client_commands/alpha_commands_registration.ml b/src/proto_alpha/lib_client_commands/alpha_commands_registration.ml index 4280e5a40fd925bd7ad74bbccfee4eecc843c615..9621aad3d741323fbd30b24c3b1a8375d87e63ce 100644 --- a/src/proto_alpha/lib_client_commands/alpha_commands_registration.ml +++ b/src/proto_alpha/lib_client_commands/alpha_commands_registration.ml @@ -33,5 +33,6 @@ let () = @ Client_proto_context_commands.commands network () @ Client_proto_multisig_commands.commands () @ Client_proto_mockup_commands.commands () + @ Contract_metadata_commands.all @ Client_sapling_commands.commands () @ Client_proto_utils_commands.commands () diff --git a/src/proto_alpha/lib_client_commands/contract_metadata_commands.ml b/src/proto_alpha/lib_client_commands/contract_metadata_commands.ml new file mode 100644 index 0000000000000000000000000000000000000000..4a4706d738e877e3acf6a89428ba69794c875824 --- /dev/null +++ b/src/proto_alpha/lib_client_commands/contract_metadata_commands.ml @@ -0,0 +1,595 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 TQ Tezos *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Protocol +open Tezos_micheline +open Client_proto_context +open Client_proto_contracts +open Tezos_contract_metadata + +module Log = Internal_event.Legacy_logging.Make (struct + let name = Printf.sprintf "client.%s.metadata_commands" Protocol.name +end) + +let get_big_map_string_at_string (cctxt : #Protocol_client_context.full) bm + ~key = + let (data, typ) = + let open Alpha_context.Script in + let open Micheline in + ( strip_locations (String (0, key)), + strip_locations (Prim (0, T_string, [], [])) ) + in + Alpha_services.Helpers.Scripts.pack_data + cctxt + (cctxt#chain, cctxt#block) + ?gas:None + ~data + ~ty:typ + >>=? fun (bytes, _remaining_gas) -> + get_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + bm + (Script_expr_hash.hash_bytes [bytes]) + >>=? fun expr -> + match Michelson_v1_primitives.strings_of_prims expr |> Micheline.root with + | Bytes (_, s) -> + return (Bytes.to_string s) + | _ -> + cctxt#error + "Value at %S is not a string: %a" + key + Michelson_v1_printer.print_expr_unwrapped + expr + +let get_storage_and_type_micheline (cctxt : #Protocol_client_context.full) + ~chain ~block contract = + get_script cctxt ~chain ~block contract + >>=? (function + | None -> + cctxt#error "This is not a smart contract." + | Some script -> + return script) + >>=? fun script -> + ( match script.code |> Data_encoding.force_decode with + | None -> + cctxt#error "Cannot decode storage." + | Some s -> + return s ) + >>=? fun code -> + get_storage cctxt ~chain:cctxt#chain ~block:cctxt#block contract + >>=? function + | None -> + cctxt#error "This is not a smart contract." + | Some storage -> + let storage_root_node = + let string_micheline : string Tezos_micheline.Micheline.canonical = + Michelson_v1_primitives.strings_of_prims storage + in + Micheline.root string_micheline + in + let (type_root_node, parameter_root_node) = + let string_micheline : string Tezos_micheline.Micheline.canonical = + Michelson_v1_primitives.strings_of_prims code + in + ( Micheline_helpers.get_storage_type_exn string_micheline, + Micheline_helpers.get_parameter_type_exn string_micheline ) + in + return (storage_root_node, type_root_node, parameter_root_node) + +let get_metadata_big_map_value (cctxt : #Protocol_client_context.full) ~chain + ~block contract ~key = + get_storage_and_type_micheline cctxt ~chain ~block contract + >>=? fun (storage_node, type_node, _) -> + match Micheline_helpers.find_metadata_big_maps ~storage_node ~type_node with + | [] -> + cctxt#error + "Cannot find metadata big-map within@ '%a'@ of@ type@ '%a'" + Micheline_helpers.pp_arbitrary_micheline + storage_node + Micheline_helpers.pp_arbitrary_micheline + type_node + | [one] -> + (* dbg "TODO: explore %a" Z.pp_print one ; *) + get_big_map_string_at_string + cctxt + (Protocol.Alpha_context.Big_map.Id.parse_z one) + ~key + | more -> + cctxt#error + "Found too many (= %d) metadata big-maps within@ '%a'@ of@ type@ '%a'" + (List.length more) + Micheline_helpers.pp_arbitrary_micheline + storage_node + Micheline_helpers.pp_arbitrary_micheline + type_node + +let rec fetch_uri_contents (cctxt : #Protocol_client_context.full) + ~current_contract uri = + let open Metadata_uri in + let ni fmt = cctxt#error ("Not implemented: " ^^ fmt) in + let get url = + Cohttp_lwt_unix.Client.get (Uri.of_string url) + >>= fun (resp, body) -> + match Cohttp.Response.status resp with + | `OK -> + Cohttp_lwt.Body.to_string body >>= fun content -> return content + | _ -> + cctxt#error "Wrong HTTP status: %a" Cohttp.Response.pp_hum resp + in + match uri with + | Web url -> + get url + | Ipfs {cid; path} -> + (* https://docs.ipfs.io/how-to/address-ipfs-on-web/#dweb-addressing-in-brief *) + let url = + let prefix = Uri.path cctxt#ipfs_gateway in + Uri.with_path cctxt#ipfs_gateway (Filename.concat prefix (cid ^ path)) + |> Uri.to_string + in + Log.lwt_debug "IPFS URI transformed into %s" url >>= fun () -> get url + | Storage {network = Some n; _} -> + ni "Network = %s in storage URI" n + | Storage {network = None; address; key} -> + ( match address with + | None -> + return current_contract + | Some addr -> + Lwt.return + (Environment.wrap_tzresult + (Alpha_context.Contract.of_b58check addr)) ) + >>=? fun contract -> + get_metadata_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + ~key + | Hash {kind = `Sha256; value; target} -> + fetch_uri_contents cctxt ~current_contract target + >>=? fun content -> + let real_hash = + Hacl.Hash.SHA256.digest (Bytes.of_string content) |> Bytes.to_string + in + if real_hash <> value then + cctxt#error + "SHA256-hash 0x%a@ for@ metadata@ at@ %a@ does@ not@ match@ the@ \ + expected@ value:@ 0x%a" + Hex.pp + (Hex.of_string real_hash) + Metadata_uri.pp + target + Hex.pp + (Hex.of_string value) + else return content + +let get_metadata_of_contract ?(strict = true) cctxt ~contract = + get_metadata_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + ~key:"" + >>=? fun value -> + let uri = Uri.of_string value in + let (validate_network, validate_kt1_address) = + if strict then + ( Some + (function + | "mainnet" | "carthagenet" | "delphinet" | "dalphanet" -> + ok () + | chain_id -> + Tezos_crypto.Chain_id.of_b58check chain_id >>? fun _ -> ok ()), + Some + (fun s -> + match Protocol.Contract_hash.of_b58check_opt s with + | Some _kt1 -> + ok () + | None -> + error (failure "%S is not a valid contract address" s)) ) + else (None, None) + in + Lwt.return (Metadata_uri.of_uri ?validate_network ?validate_kt1_address uri) + >>=? fun parsed_uri -> + fetch_uri_contents cctxt ~current_contract:contract parsed_uri + +let group = + { + Clic.name = "contract-metadata"; + title = + "Block contextual commands related to the Contract Metadata (TZIP-16)"; + } + +module Output_path = struct + let arg = + Clic.( + arg + ~doc:"Output path" + ~long:"output" + ~placeholder:"PATH" + (parameter (fun _ s -> return s))) + + let output ?(none = fun _ -> return ()) output_path_opt content = + match output_path_opt with + | None -> + none content + | Some s -> + Lwt_io.with_file ~mode:Lwt_io.output s (fun ochan -> + Lwt_io.fprint ochan content) + >>= fun () -> return_unit +end + +let all = + let open Clic in + [ command + ~group + ~desc:"Get the JSON-Schema and example of TZIP-016 metadata." + (args2 + (switch ~doc:"Also output examples." ~long:"with-examples" ()) + (default_arg + ~doc:"Output path" + ~long:"output" + ~placeholder:"PATH" + ~default:"/tmp/tzip-16-metadata" + (parameter (fun _ s -> return s)))) + (fixed ["get"; "contract"; "metadata"; "schema"]) + (fun (with_examples, output_path) (cctxt : Protocol_client_context.full) -> + cctxt#message + "Outputting to %S with%s examples." + output_path + (if with_examples then "" else "out") + >>= fun () -> + Lwt_utils_unix.create_dir output_path + >>= fun () -> + let schema = Json_encoding.schema Metadata_contents.encoding in + let path = Filename.(concat output_path "schema.json") in + cctxt#message "Outputting schema to %S." path + >>= fun () -> + Lwt_io.with_file ~mode:Lwt_io.output path (fun o -> + Lwt_io.fprintl + o + ( Json_schema.to_json schema + |> Ezjsonm.value_to_string ~minify:false )) + >>= fun () -> + cctxt#message "Outputting examples." + >>= fun () -> + if with_examples then + Lwt_list.iteri_s + (fun ith example -> + let path = + Filename.(concat output_path (Fmt.str "example-%03d.json" ith)) + in + cctxt#message + "@[<2>Outputting example #%d@ to %S:@ %a@]" + ith + path + Metadata_contents.pp + example + >>= fun () -> + Lwt_io.with_file ~mode:Lwt_io.output path (fun o -> + let jzon = + Json_encoding.construct Metadata_contents.encoding example + |> Ezjsonm.value_to_string ~minify:false + in + Lwt_io.fprintl o jzon)) + (Metadata_contents.Example.all ()) + >>= fun () -> return_unit + else return_unit); + command + ~group + ~desc:"Fetch and output the metadata from a KT1 contract." + (args3 + (default_arg + ~doc: + "Output format: 'text', 'text:short', 'text:full', 'raw', or \ + 'json'." + ~long:"format" + ~placeholder:"FORMAT" + ~default:"JSON" + (parameter (fun _ s -> + match String.lowercase_ascii s with + | "text" -> + return (`Text `Full) + | "text:full" -> + return (`Text `Full) + | "text:short" -> + return (`Text `Short) + | "raw" -> + return `Raw + | "json" -> + return `Json + | other -> + failwith "Output format unknown: %S" other))) + Output_path.arg + (arg + ~doc: + "Also display extra validation errors and warnings. Default: \ + true when output format is text, false otherwise." + ~long:"validate" + ~placeholder:"BOOL" + (parameter (fun _ s -> + match String.lowercase_ascii s with + | "true" -> + return true + | "false" -> + return false + | other -> + failwith "Cannot understand boolean %S" other)))) + ( prefixes ["get"; "metadata"; "for"; "contract"] + @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" + @@ stop ) + (fun (output_format, output_path_opt, validation) + (_, contract) + (cctxt : Protocol_client_context.full) -> + let should_validate = + match (validation, output_format) with + | (Some true, _) | (None, `Text `Full) -> + true + | _ -> + false + in + get_metadata_of_contract cctxt ~contract ~strict:should_validate + >>=? fun content -> + let none s = cctxt#message "%s" s >>= fun () -> return_unit in + let maybe_show_validation f = + let protocol_hash_is_valid s = + match Tezos_crypto.Protocol_hash.of_b58check_opt s with + | None -> + false + | Some _ -> + true + in + if should_validate then + f (fun c -> + return + (Metadata_contents.Validation.validate + ~protocol_hash_is_valid + c)) + >>=? fun errs_and_warns -> + cctxt#message + "@[<2>Validation result:@ %a@]" + Metadata_contents.Validation.pp + errs_and_warns + >>= fun () -> + match fst errs_and_warns with + | [] -> + return_unit + | more -> + failwith "There were %d validation errors." (List.length more) + else return_unit + in + match output_format with + | `Text style -> + Lwt.return (Metadata_contents.of_json content) + >>=? fun contents -> + let meta_pp = + match style with + | `Full -> + Metadata_contents.pp + | `Short -> + Metadata_contents.pp_short + in + Output_path.output + ~none + output_path_opt + (Format.asprintf "%a" meta_pp contents) + >>=? fun () -> + maybe_show_validation (fun validate -> validate contents) + | `Raw -> + Output_path.output ~none output_path_opt content + >>=? fun () -> + maybe_show_validation (fun validate -> + Lwt.return (Metadata_contents.of_json content) + >>=? fun contents -> validate contents) + | `Json -> + Lwt.return (Metadata_contents.of_json content) + >>=? fun contents -> + Output_path.output + ~none + output_path_opt + (Metadata_contents.to_json contents) + >>=? fun () -> + maybe_show_validation (fun validate -> validate contents)); + command + ~group + ~desc:"Get a value from a TZIP-016 %metadata big-map." + no_options + ( prefixes ["get"; "metadata"; "element"] + @@ Clic.string ~name:"key" ~desc:"the string key to look for" + @@ prefixes ["from"] + @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" + @@ stop ) + (fun () key (_, contract) (cctxt : Protocol_client_context.full) -> + get_metadata_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + ~key + >>=? fun value -> cctxt#answer "%S" value >>= fun () -> return_unit); + command + ~group + ~desc:"Call an off-chain-view from a TZIP-016-enabled contract." + (args4 + (Client_proto_args.unparsing_mode_arg ~default:"Readable") + Output_path.arg + (switch + ~doc:"Output JSON instead of concrete Micheline syntax." + ~long:"json" + ()) + (default_arg + ~doc:"Michelson argument to pass to the view." + ~long:"arg" + ~placeholder:"MICHELSON" + ~default:"Unit" + (parameter (fun _ s -> + let open Micheline_parser in + Lwt.return (no_parsing_error (tokenize s)) + >>=? fun tokens -> + Lwt.return (no_parsing_error (parse_expression tokens)) + >>=? fun mich -> return (Micheline.strip_locations mich))))) + ( prefixes ["query"; "off-chain-view"] + @@ Clic.string ~name:"name" ~desc:"The view to call." + @@ prefixes ["from"] + @@ ContractAlias.destination_param ~name:"contract" ~desc:"KT1 contract" + @@ stop ) + (fun (unparsing_mode, output_path_opt, json, input_michelson) + name + (_, contract) + (cctxt : Protocol_client_context.full) -> + get_metadata_of_contract ~strict:false cctxt ~contract + >>=? fun content -> + let open Metadata_contents in + let open View in + Lwt.return (of_json content) + >>=? fun metadata -> + ( match + List.find_all (fun {name = n; _} -> n = name) metadata.views + with + | [one] -> + return one + | [] -> + cctxt#error + "View not found: %S, available views: %a" + name + Fmt.(vbox (one_of ~empty:(any "None") pp)) + metadata.views + | one :: _more -> + cctxt#warning + "Too many views called %S going with %a" + name + (pp ~with_code:true) + one + >>= fun () -> return one ) + >>=? fun view -> + Implementation.( + match + List.filter_map + (function Michelson_storage s -> Some s | _ -> None) + view.implementations + with + | [] -> + cctxt#error + "View %S does not have any michelson-storage implementation." + name + | [one] -> + return one + | one :: more -> + cctxt#warning + "Using the first michelson-storage implementation of %d" + (List.length more + 1) + >>= fun () -> return one) + >>=? fun first_michelson_implementation -> + get_storage_and_type_micheline + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + >>=? fun (storage_node, type_node, parameter_node) -> + get_balance cctxt ~chain:cctxt#chain ~block:cctxt#block contract + >>=? fun contract_balance -> + let (`Contract the_contract, `Input input_node, `Storage init_storage) + = + Micheline_helpers.build_off_chain_view_contract + first_michelson_implementation + ~contract_balance: + (Alpha_context.Tez.to_mutez contract_balance |> Z.of_int64) + ~contract_address:(Alpha_context.Contract.to_b58check contract) + ~contract_storage_type:type_node + ~contract_parameter_type:parameter_node + ~view_parameters:(Micheline.root input_michelson) + ~contract_storage:storage_node + in + (* We need to print and reparse+type-check the `string Micheline.node`s + into the protocol's own Michelson in order to use the typed + RPC `Client_proto_programs.run`: *) + let program = + Fmt.str "%a" Micheline_helpers.pp_arbitrary_micheline the_contract + in + let input = + Fmt.str "%a" Micheline_helpers.pp_arbitrary_micheline input_node + in + let storage = + Fmt.str "%a" Micheline_helpers.pp_arbitrary_micheline init_storage + in + let parse_expr expr = + Lwt.return @@ Micheline_parser.no_parsing_error + @@ Michelson_v1_parser.parse_expression expr + in + parse_expr program + >>=? fun program -> + parse_expr storage + >>=? fun storage -> + parse_expr input + >>=? fun input -> + Client_proto_programs.run + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~unparsing_mode + ~program + ~storage + ~input + ~balance:Alpha_context.Tez.zero + (* Balance has been fixed by build_off_chain_view_contract *) + () + >>= function + | Ok (storage_result, _, _) -> ( + let open Michelson_v1_primitives in + let open Micheline in + match root storage_result with + | Prim (_, D_Some, [one], _) -> + let result = strip_locations one in + let to_output = + match json with + | false -> + Fmt.str "%a\n" Michelson_v1_printer.print_expr result + | true -> + let enc = + Micheline.canonical_encoding_v1 + ~variant:"result" + Michelson_v1_primitives.prim_encoding + in + Data_encoding.Json.construct enc result + |> Data_encoding.Json.to_string + ~newline:true + ~minify:false + in + Output_path.output + ~none:(fun s -> + cctxt#message "%s" s >>= fun () -> return_unit) + output_path_opt + to_output + | _ -> + cctxt#error + "@[@[%a:@]@,%a@]" + Format.pp_print_text + "Running the off-chain-view failed in an unexpected way, \ + please report a bug" + Michelson_v1_printer.print_expr + storage_result ) + | Error el -> + cctxt#error "Run failed: %a" Error_monad.pp_print_error el) ] diff --git a/src/proto_alpha/lib_client_commands/dune b/src/proto_alpha/lib_client_commands/dune index 554b79e84c58d2af1430d684319e06af7a14ecc1..a1af1ed96d693c6ef52878c629c37de9c1284504 100644 --- a/src/proto_alpha/lib_client_commands/dune +++ b/src/proto_alpha/lib_client_commands/dune @@ -13,6 +13,8 @@ tezos-client-alpha tezos-client-commands tezos-rpc + tezos-rpc-http-client-unix + tezos-contract-metadata tezos-protocol-plugin-alpha) (library_flags (:standard -linkall)) (modules (:standard \ alpha_commands_registration)) diff --git a/src/proto_alpha/lib_client_commands/tezos-client-alpha-commands.opam b/src/proto_alpha/lib_client_commands/tezos-client-alpha-commands.opam index a4804e1ed51855693fe4ba919491d1a11ed93966..5ddc5813ecfc5a72dec268a362cb39ebace6431d 100644 --- a/src/proto_alpha/lib_client_commands/tezos-client-alpha-commands.opam +++ b/src/proto_alpha/lib_client_commands/tezos-client-alpha-commands.opam @@ -15,6 +15,8 @@ depends: [ "tezos-client-base-unix" "tezos-client-alpha" "tezos-client-commands" + "tezos-rpc-http-client-unix" + "tezos-contract-metadata" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/tezt/lib/process.ml b/tezt/lib/process.ml index 309147de38e1e91af98002ac9b1964d2499bedf8..53141c13275470fa2d893123a144d77d73681b70 100644 --- a/tezt/lib/process.ml +++ b/tezt/lib/process.ml @@ -401,3 +401,12 @@ let run_and_read_stderr ?log_status_on_exit ?name ?color ?env ?expect_failure spawn ?log_status_on_exit ?name ?color ?env command arguments in check_and_read_stdout ?expect_failure process + +let run_and_read_all ?log_status_on_exit ?name ?color ?env command arguments = + let process = + spawn ?log_status_on_exit ?name ?color ?env command arguments + in + let* status = wait process + and* out = Lwt_io.read (stdout process) + and* err = Lwt_io.read (stderr process) in + return (status = WEXITED 0, out, err) diff --git a/tezt/lib/process.mli b/tezt/lib/process.mli index f5e9125f168aee949c7ab17b618623904b91093f..9ac30ba412a13cb1c094a277bdc2a2a901ebba72 100644 --- a/tezt/lib/process.mli +++ b/tezt/lib/process.mli @@ -162,3 +162,13 @@ val run_and_read_stderr : string -> string list -> string Lwt.t + +(** Spawn a process and obtain [ (success, stdout, stderr) ]. *) +val run_and_read_all : + ?log_status_on_exit:bool -> + ?name:string -> + ?color:Log.Color.t -> + ?env:string Base.String_map.t -> + string -> + string list -> + (bool * string * string) Lwt.t diff --git a/tezt/lib_tezos/client.ml b/tezt/lib_tezos/client.ml index 7e24ae2138089b8068036bcf9a19759948eaf650..27a8cd53da1d1857159e7af1901df4256dec08dd 100644 --- a/tezt/lib_tezos/client.ml +++ b/tezt/lib_tezos/client.ml @@ -30,8 +30,8 @@ type mockup_sync_mode = Asynchronous | Synchronous type normalize_mode = Readable | Optimized | Optimized_legacy type t = { - path : string; - admin_path : string; + path : string list; + admin_path : string list; name : string; color : Log.Color.t; base_dir : string; @@ -86,8 +86,21 @@ let mode_arg client = | Proxy _ -> ["--mode"; "proxy"] +let make_command ?node ?(admin = false) client command = + let full = + (if admin then client.admin_path else client.path) + @ endpoint_arg ?node client @ mode_arg client @ base_dir_arg client + @ command + in + match full with + | bin :: args -> + (bin, args) + | [] -> + invalid_arg "Client.make_command: Empty binary path" + let spawn_command ?(env = String_map.empty) ?node ?hooks ?(admin = false) client command = + let (bin, args) = make_command ?node ~admin client command in let env = (* Set disclaimer to "Y" if unspecified, otherwise use given value *) String_map.update @@ -95,14 +108,16 @@ let spawn_command ?(env = String_map.empty) ?node ?hooks ?(admin = false) (fun o -> Option.value ~default:"Y" o |> Option.some) env in - Process.spawn - ~name:client.name - ~color:client.color - ~env - ?hooks - (if admin then client.admin_path else client.path) - @@ endpoint_arg ?node client @ mode_arg client @ base_dir_arg client - @ command + Process.spawn ~name:client.name ~color:client.color ~env ?hooks bin args + +let run_command_full ?admin client command = + let (bin, args) = make_command ?admin client command in + Process.run_and_read_all ~name:client.name ~color:client.color bin args + +let run_command_or_fail ?admin client command = + let* (s, o, e) = run_command_full ?admin client command in + if s then return (o, e) + else Test.fail "Client command failed: %s" (String.concat " " command) let url_encode str = let buffer = Buffer.create (String.length str * 3) in diff --git a/tezt/lib_tezos/client.mli b/tezt/lib_tezos/client.mli index 2e61105c937903ce8c52f53eaf39cfa2eb36c73f..a170873bb0d61c8a4e9e72dfebed11da8d391fa6 100644 --- a/tezt/lib_tezos/client.mli +++ b/tezt/lib_tezos/client.mli @@ -59,8 +59,8 @@ val base_dir : t -> string to a node. Most commands require a node to be specified (either with [create] or with the command itself). *) val create : - ?path:string -> - ?admin_path:string -> + ?path:string list -> + ?admin_path:string list -> ?name:string -> ?color:Log.Color.t -> ?base_dir:string -> @@ -70,8 +70,8 @@ val create : (** Create a client like [create] but do not assume [Client] as the mode. *) val create_with_mode : - ?path:string -> - ?admin_path:string -> + ?path:string list -> + ?admin_path:string list -> ?name:string -> ?color:Log.Color.t -> ?base_dir:string -> @@ -149,6 +149,17 @@ val shell_header : val spawn_shell_header : ?node:Node.t -> ?chain:string -> ?block:string -> t -> Process.t +(** {2 Generic Client Commands} *) + +(** Run a client command, and return [(success, stdout, stderr)]. *) +val run_command_full : + ?admin:bool -> t -> string list -> (bool * string * string) Lwt.t + +(** Run a client command, and return [(stdout, stderr)] if it succeeds, or + call {!Test.fail} if it doesn't. *) +val run_command_or_fail : + ?admin:bool -> t -> string list -> (string * string) Lwt.t + (** {2 Admin Client Commands} *) module Admin : sig @@ -398,8 +409,8 @@ val spawn_migrate_mockup : next_protocol:Protocol.t -> t -> Process.t (** Create a client with mode [Client] and import all secret keys listed in {!Constant.all_secret_keys}. *) val init : - ?path:string -> - ?admin_path:string -> + ?path:string list -> + ?admin_path:string list -> ?name:string -> ?color:Log.Color.t -> ?base_dir:string -> @@ -414,8 +425,8 @@ val init : keys. *) val init_mockup : - ?path:string -> - ?admin_path:string -> + ?path:string list -> + ?admin_path:string list -> ?name:string -> ?color:Log.Color.t -> ?base_dir:string -> diff --git a/tezt/lib_tezos/constant.ml b/tezt/lib_tezos/constant.ml index 5ebbbd28cd12bf3739e7d0c849f3dcf46da9b132..b98ad89818d18add022a27c487ad1eee5cec26eb 100644 --- a/tezt/lib_tezos/constant.ml +++ b/tezt/lib_tezos/constant.ml @@ -24,9 +24,9 @@ (* *) (*****************************************************************************) -let tezos_client = "./tezos-client" +let tezos_client = ["./tezos-client"] -let tezos_admin_client = "./tezos-admin-client" +let tezos_admin_client = ["./tezos-admin-client"] let tezos_node = "./tezos-node" diff --git a/tezt/tests/dune b/tezt/tests/dune index c2fc2fc185250524b1b9eea444be960230793ec6..645a1897d175c80debc26cc93119c9ff11e7609f 100644 --- a/tezt/tests/dune +++ b/tezt/tests/dune @@ -1,6 +1,7 @@ (executable (name main) (libraries tezt-tezos + cohttp-lwt-unix data-encoding tezos-base tezos-stdlib-unix) diff --git a/tezt/tests/main.ml b/tezt/tests/main.ml index d07deb6a82329643b63d2e201593db5b27aeaa2f..850c1beb8a3152312a1788c1b456e468c97ad09d 100644 --- a/tezt/tests/main.ml +++ b/tezt/tests/main.ml @@ -59,6 +59,7 @@ let () = They do not take a protocol as a parameter and thus need to be registered only once. *) Mockup.register_protocol_independent () ; Bootstrap.register_protocol_independent () ; + Metadata_commands.register_for_all_protocols () ; Cli_tezos.register_protocol_independent () ; (* Tests that are heavily protocol-dependent. Those modules define different tests for different protocols in their [register]. *) diff --git a/tezt/tests/metadata_commands.ml b/tezt/tests/metadata_commands.ml new file mode 100644 index 0000000000000000000000000000000000000000..9e3b57903cca0202bf5e238407cffa928a0aecca --- /dev/null +++ b/tezt/tests/metadata_commands.ml @@ -0,0 +1,689 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020, 2021 TQ Tezos *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module Http_server : sig + val start : + ?port:int -> + unit -> + < add_path : string -> [`OK of string] -> unit ; stop : unit > Lwt.t +end = struct + open Cohttp_lwt_unix.Server + + let start ?(port = 20302) () = + let paths = ref [] in + let condition = Lwt_condition.create () in + let callback _conn (req : Cohttp.Request.t) (_body : Cohttp_lwt.Body.t) = + let uri = Cohttp.Request.uri req in + match List.assoc_opt (Uri.path uri) !paths with + | Some (`OK s) -> + respond_string ~status:`OK ~body:s () + | None -> + respond_string ~status:`Not_found ~body:"Wrong path" () + in + let server = make ~callback () in + let mode = `TCP (`Port port) in + (* We use `Lwt.async` instead of Tezt.Base's because we don't want to wait + when a test fails. *) + Lwt.async (fun () -> + create server ~mode ~stop:(Lwt_condition.wait condition)) ; + let* () = Lwt_unix.sleep 1. in + return + (object + method stop = Lwt_condition.signal condition () + + method add_path p v = paths := (p, v) :: !paths + end) +end + +module Micheline_views = struct + open Ezjsonm + + let prim p l = dict [("prim", string p); ("args", `A l)] + + let nat = prim "nat" [] + + let mutez = prim "mutez" [] + + let timestamp = prim "timestamp" [] + + let prims = List.map (fun p -> prim p []) + + let view_with_code ?version ?(parameter = nat) ?(return_type = nat) name code + = + let open Ezjsonm in + dict + [ ("name", string name); + ( "implementations", + `A + [ dict + [ ( "michelsonStorageView", + dict + ( [ ("parameter", parameter); + ("returnType", return_type); + ("code", `A code) ] + @ + match version with + | None -> + [] + | Some s -> + [("version", string s)] ) ) ] ] ) ] +end + +let client_command = ["dune"; "exec"; "src/bin_client/main_client.exe"; "--"] + +let client_admin_command = + ["dune"; "exec"; "src/bin_client/main_admin.exe"; "--"] + +let metadata_commands proto which_one = + let tag = + match which_one with + | `Failures -> + "failures" + | `Basic -> + "basic" + | `Validation -> + "validation" + | `Views -> + "views" + | `Web_locations -> + "web_locations" + | `Contract_locations -> + "contract_locations" + in + let prototag = Protocol.tag proto in + Test.register + ~__FILE__ + ~title:(sf "Metadata-commands/%s/%s" tag prototag) + ~tags:[tag; prototag; "metadata_commands"] + @@ fun () -> + let* client = + Client.init_mockup + ~protocol:proto + ~path:client_command + ~admin_path:client_admin_command + () + in + Log.info "Mockup client initialized." ; + let* (bal, _) = + Client.run_command_or_fail client ["get"; "balance"; "for"; "bootstrap1"] + in + Log.info "balance: %s" bal ; + let originate ?(balance = 0) name michelson init = + let* _ = + Client.run_command_or_fail + client + [ "originate"; + "contract"; + name; + "transferring"; + Int.to_string balance; + "from"; + "bootstrap1"; + "running"; + michelson; + "--init"; + init; + "--burn-cap"; + "10"; + "--force" ] + in + return name + in + let contract_valid = + {tz| +parameter unit; +storage (pair nat (big_map %metadata string bytes)); +code { PUSH nat 42; FAILWITH; }; +|tz} + in + let contract_wrong_type = + {tz| +parameter unit; +storage (pair nat (big_map %metadata string string)); +code { PUSH nat 42; FAILWITH; }; +|tz} + in + let contract_two_metadatas = + {tz| +parameter unit; +storage (pair (pair nat (big_map %metadata string bytes)) + (big_map %metadata string bytes)); +code { PUSH nat 42; FAILWITH; }; +|tz} + in + let get_metadata_for_contract ?ipfs_gateway ?output_path ?output_format c = + let* (success, stdout, stderr) = + Client.run_command_full + client + ( Option.( + map (fun s -> ["--ipfs-gateway"; s]) ipfs_gateway + |> value ~default:[]) + @ ["get"; "metadata"; "for"; "contract"; c] + @ Option.( + map (fun s -> ["--output"; s]) output_path |> value ~default:[]) + @ Option.( + map (fun s -> ["--format"; s]) output_format |> value ~default:[]) + ) + in + Log.debug "Get-METADATA: CONTRACT: %s" c ; + Log.debug "RESULT: %b" success ; + Log.debug "STDOUT:\n%s" stdout ; + Log.debug "STDERR:\n%s" stderr ; + return (success, stdout, stderr) + in + let call_view ?output ?arg view contract = + let* (success, stdout, stderr) = + Client.run_command_full + client + ( ["query"; "off-chain-view"; view; "from"; contract] + @ ( match proto with + | Protocol.Alpha | Edo -> + [ (* We rely on the unparsing mode to check the results: *) + "--unparsing-mode"; + "Readable" ] ) + @ Option.(map (fun s -> ["--arg"; s]) arg |> value ~default:[]) + @ Option.(map (fun s -> ["--output"; s]) output |> value ~default:[]) + ) + in + Log.debug + "Call off-chain-view %s from %s -> %s" + view + contract + (if success then "OK" else "KO") ; + Log.debug "STDOUT:\n%s" stdout ; + Log.debug "STDERR:\n%s" stderr ; + return (success, stdout, stderr) + in + let wrong_contract ?match_output name michelson init = + let* c = originate name michelson init in + let* () = + let* (success, stdout, stderr) = get_metadata_for_contract c in + let* () = + if success then Test.fail "Should have failed: get-metdata for %s" name + else return () + in + let flattened out err = + out ^ err |> String.map (function '\n' -> ' ' | other -> other) + in + match match_output with + | None -> + return () + | Some s when flattened stdout stderr =~ rex s -> + return () + | Some oops -> + Test.fail + "Test %S because of regexp %S didn't match the output." + name + oops + in + return () + in + let michel_hex_encode s = "0x" ^ Hex.(of_string s |> show) in + let storage ?(the_nat = 0) l = + sf + "(Pair %d {%s})" + the_nat + (String.concat + " ; " + (List.map (fun (k, v) -> sf "Elt %S %s" k (michel_hex_encode v)) l)) + in + let empty_storage = storage [] in + let port = 20402 in + let ipfs_gateway = sf "http://127.0.0.1:%d/ipfs-local" port in + let optional_regexp_match_on_output errprefix ~out ~err = function + | None -> + return () + | Some rg -> + if String.map (function '\n' -> ' ' | c -> c) (out ^ err) =~ rex rg + then return () + else Test.fail "%s: does not match %S" errprefix rg + in + let test_location ?output_matches ?(returns = true) name ~loc = + let* _ = originate name contract_valid (storage [("", loc)]) in + let* (success, out, err) = get_metadata_for_contract ~ipfs_gateway name in + Log.debug "contract %S -> %b" name success ; + let* () = + if success = returns then return () + else Test.fail "get-metadata for %s returned %b" name success + in + optional_regexp_match_on_output + (Fmt.str "get-metadata for %S" name) + ~out + ~err + output_matches + in + match which_one with + | `Failures -> + if empty_storage <> "(Pair 0 {})" then + Test.fail "double-checking-empty-storage: %S" empty_storage ; + let* () = + wrong_contract + "valid-but-no-data" + contract_valid + empty_storage + ~match_output:"Did not find service" + in + let* () = + wrong_contract + "wrong-type-for-metadata" + contract_wrong_type + "(Pair 0 { Elt \"\" \"Hello world\" })" + ~match_output:"Fatal error:.*Cannot find metadata big-map" + in + let* () = + wrong_contract + "two-metadata-maps" + contract_two_metadatas + "(Pair (Pair 1 {}) {})" + ~match_output:"Fatal error:.*Found too many.*metadata big-maps" + in + return () + | `Basic -> + let test_get_metadata ?expect name init = + let* _ = originate name contract_valid init in + let output_path = Temp.file "metadata.json" in + let* (success, _, _) = + get_metadata_for_contract ~output_path ~output_format:"json" name + in + if not success then Test.fail "Test %S failed" name ; + match expect with + | None -> + return () + | Some e -> + let* content = + Lwt_io.chars_of_file output_path |> Lwt_stream.to_string + in + Log.info + "get_metadata_for_contract-output `%s`: %S" + output_path + content ; + let j = JSON.unannotate (JSON.parse ~origin:output_path content) in + if e = j then return () + else + Test.fail + "Test %S failed: expecting: %s, got %s" + name + (Ezjsonm.value_to_string ~minify:false e) + (Ezjsonm.value_to_string ~minify:false j) + in + let in_storage_involution name v = + let init = Ezjsonm.value_to_string ~minify:true v in + test_get_metadata + name + ~expect:v + (storage [("", "tezos-storage:main"); ("main", init)]) + in + let* () = in_storage_involution "valid-empty" Ezjsonm.(dict []) in + let* () = + in_storage_involution + "valid-version" + Ezjsonm.(dict [("version", string "v0.42-alpha")]) + in + let* () = + in_storage_involution + "valid-extras" + Ezjsonm.( + dict + [ ("version", string "v0.42-alpha"); + ( "extra-1", + dict + [ ("name", string "TheContract"); + ("description", string "This is a contract.") ] ) ]) + in + return () + | `Validation -> + let outs = ref [] in + let test_validate ?(should_fail = false) ?output_matches name storage = + let* _ = originate name contract_valid storage in + let* (success, out, err) = + get_metadata_for_contract ~output_format:"text" name + in + if (not should_fail) && not success then + Test.fail "Test %S failed: returned non-zero" name ; + let* () = + optional_regexp_match_on_output + (Fmt.str "validate-metadata for %S" name) + ~out + ~err + output_matches + in + outs := out :: !outs ; + Log.debug "OUT: %s" out ; + Log.debug "ERR: %s" err ; + return () + in + let test_validate_metadata ?should_fail ?output_matches name v = + let init = Ezjsonm.value_to_string ~minify:false v in + test_validate + ?should_fail + ?output_matches + name + (storage [("", "tezos-storage:back-in-here"); ("back-in-here", init)]) + in + let* () = + test_validate + ~should_fail:true + ~output_matches:"KT1blabla.*is *not.*address" + "wrong-kt1" + (storage [("", "tezos-storage://KT1blabla.mainnet/foo")]) + in + let* () = + test_validate + ~should_fail:true + ~output_matches:"Failed.*mainenet" + "wrong-network-net" + (storage + [ ( "", + "tezos-storage://T1XRT495WncnqNmqKn4tkuRiDJzEiR4N2C9.mainenet/foo" + ) ]) + in + let* () = + (* valid: "NetXkTgRw1rTezt" → we swap 2 chars: *) + test_validate + ~should_fail:true + ~output_matches:"Failed.*NetXkTgRwr1Tezt" + "wrong-network-chain-id" + (storage + [ ( "", + "tezos-storage://T1XRT495WncnqNmqKn4tkuRiDJzEiR4N2C9.NetXkTgRwr1Tezt/foo" + ) ]) + in + let* () = + test_validate_metadata + "validation-ok" + Ezjsonm.(dict [("version", string "one-word")]) + ~output_matches:"No errors nor warnings" + in + let* () = + test_validate_metadata + "validation-0" + Ezjsonm.( + dict + [ ("name", string "some\tname"); + ("version", string "with\nnew-line") ]) + ~output_matches:"Errors: None.*Unexpected *whitespace" + in + let* () = + test_validate_metadata + "validation-0" + Ezjsonm.(dict [("authors", list string ["just a name"])]) + ~output_matches:"Errors: None.*Wrong *format *for *author" + in + let open Micheline_views in + let* () = + let code = prims ["CAR"; "SELF"; "CAR"; "MUL"] in + test_validate_metadata + "validation-0" + Ezjsonm.( + dict + [ ( "views", + list (fun x -> x) [view_with_code "multiply-the-nat" code] ) + ]) + ~output_matches:"Errors: None.*SELF *instruction *not *followed.*CAR" + in + let* () = + let code = prims ["CAR"; "SELF"] in + test_validate_metadata + "validation-0" + Ezjsonm.( + dict + [ ( "views", + list + (fun x -> x) + [ view_with_code + ~version: + (* Valid version, no errors: *) + "PsddFKi32cMJ2qPjf43Qv5GDWLDPZb3T3bF6fLKiF5HtvHNU7aP" + "multiply-the-nat" + code ] ) ]) + ~output_matches: + "Errors: None.*SELF *instruction *not *followed.*nothing" + in + let* () = + let code = prims ["CAR"; "AMOUNT"; "CAR"; "MUL"] in + test_validate_metadata + "validation-0" + Ezjsonm.( + dict + [ ( "views", + list (fun x -> x) [view_with_code "multiply-the-nat" code] ) + ]) + ~should_fail:true + ~output_matches: + "Errors:.*Forbidden Michelson.*AMOUNT.*Warnings: None" + in + let* () = + let code = prims ["CAR"; "CAR"; "MUL"] in + test_validate_metadata + "validation-0" + Ezjsonm.( + dict + [ ( "views", + list + (fun x -> x) + [ view_with_code + ~version:"PtWrongWrong" + "multiply-the-nat" + code ] ) ]) + ~should_fail:true + ~output_matches: + "Errors:.*Michelson *version.*PtWrongWrong.*Warnings: None" + in + Log.debug + "Outputs:\n%s" + (List.rev_map (sf "-----\n%s") !outs |> String.concat "\n") ; + return () + | `Views -> + let metadata view = + Ezjsonm.( + dict + [ ("version", string "0.42.1-alpha"); + ("license", dict [("name", string "MIT")]); + ("interfaces", list string ["TZIP-42"; "TZIP-51 with sausages"]); + ( "authors", + list string ["Øne Úţff8 "] ); + ( "extra-field", + dict + [ ("name", string "TheContract"); + ("description", string "This is a test contract.") ] ); + ("views", list (fun x -> x) [view]) ]) + in + let test_view ?balance testname ~arg ~view ~output_matches = + let* _ = + originate + testname + ?balance + contract_valid + (storage + ~the_nat:13 + [ ("", "tezos-storage:here"); + ("here", Ezjsonm.value_to_string (metadata view)) ]) + in + let tmp = Temp.file "result.tz" in + let* (success, _, _) = call_view testname testname ~arg ~output:tmp in + if not success then Test.fail "Call-view %S failed" testname ; + let* content = Lwt_io.chars_of_file tmp |> Lwt_stream.to_string in + if content =~! output_matches then + Test.fail "off-chain-view-result: %S" content ; + return content + in + let* _ : string = + let identity_view = + let open Micheline_views in + let code = prims ["CAR"] in + view_with_code "identity" code + in + test_view + "identity" + ~arg:"42" + ~view:identity_view + ~output_matches:(Format.kasprintf rex "^%d[\\n]?$" 42) + in + let* _ : string = + let multiply_the_nat_view = + let open Micheline_views in + let code = prims ["DUP"; "CDAR"; "SWAP"; "CAR"; "MUL"] in + view_with_code "multiply-the-nat" code + in + test_view + "multiply-the-nat" + ~arg:"42" + ~view:multiply_the_nat_view + ~output_matches:(Format.kasprintf rex "^%d[\\n]?$" (13 * 42)) + in + let* _ : string = + let view_with_balance = + let open Micheline_views in + view_with_code + "basic-balance" + (prims ["DROP"; "BALANCE"]) + ~return_type:mutez + in + test_view + "basic-balance" + ~arg:"42" + ~balance:10 (* million mutez *) + ~view:view_with_balance + ~output_matches:(Format.kasprintf rex "^%d[\\n]?$" 10_000_000) + in + let* () = + let name = "view-with-self" in + let view_with_self = + let open Micheline_views in + view_with_code + name + (prims ["DROP"; "SELF"; "ADDRESS"]) + ~return_type:(prim "address" []) + in + let* res = + test_view + name + ~arg:"42" + ~balance:1 + ~view:view_with_self + ~output_matches:(Format.kasprintf rex "^\"KT1") + in + let* (show_output, _) = + Client.run_command_or_fail client ["show"; "known"; "contract"; name] + in + let addr = String.trim show_output in + if sf "%S\n" addr <> res then + Test.fail "%s: did not return %S but %S" name addr res ; + return () + in + return () + | `Web_locations -> + let* server = Http_server.start ~port () in + let loc0 = sf "http://127.0.0.1:%d/metadata-0.json" port in + let* () = + test_location + "missing-http" + ~output_matches:"Wrong HTTP status" + ~returns:false + ~loc:loc0 + in + server#add_path "/metadata-0.json" (`OK "{}") ; + let* () = + test_location "valid-http" ~output_matches:"\\{\\}" ~loc:loc0 + in + let* () = + let loc = sf "sha256://0x4242/%s" (Uri.pct_encode loc0) in + test_location + "invalid-sha256" + ~output_matches: + "SHA256-hash.*metadata.*does.*not.*match.*the.*expected" + ~loc + ~returns:false + in + let* () = + let ok_hash = + (* Get this from the error message of the previous test, + or from `printf '{}' | sha256sum` *) + "0x44136fa355b3678a1146ad16f7e8649e94fb4fc21fe77e8310c060f61caaff8a" + in + let loc = sf "sha256://%s/%s" ok_hash (Uri.pct_encode loc0) in + test_location + "valid-sha256" + ~output_matches:"\\{\\}" + ~loc + ~returns:true + in + let* () = + let cid = + "bafybeiemxf5abjwjbikoz4mc3a3dla6ual3jsgpdr4cjr3oz3evfyavhwq" + in + let path = "/m0.json" in + let loc = sf "ipfs://%s%s" cid path in + let* () = + test_location + "missing-ipfs" + ~loc + ~returns:false + ~output_matches:"Wrong HTTP status" + in + server#add_path + (sf "/ipfs-local/%s%s" cid path) + (`OK "{\"version\": \"v42\"}") ; + let* () = test_location "ok-ipfs" ~loc ~output_matches:"v42" in + return () + in + server#stop ; return () + | `Contract_locations -> + (* Metadata in a separate contract: *) + let test_other_contract ~key () = + let metadata = "{\"version\": \"v42\"}" in + let* _ = + originate "other-contract" contract_valid (storage [(key, metadata)]) + in + let* (show_output, _) = + Client.run_command_or_fail + client + ["show"; "known"; "contract"; "other-contract"] + in + let addr = String.trim show_output in + let loc = + sf "tezos-storage://%s/%s" addr (Uri.pct_encode key) + (* the key comes after the 1st slash *) + in + Log.debug "other-contract: %S" addr ; + let* () = test_location "valid-somewhere-else" ~loc in + return () + in + let* () = test_other_contract ~key:"one-word" () in + let* () = test_other_contract ~key:"/one-slash" () in + let* () = test_other_contract ~key:"//tree/slashes" () in + return () + +let register_for_all_protocols () = + ListLabels.( + iter + [ `Failures; + `Basic; + `Validation; + `Views; + `Web_locations; + `Contract_locations ] + ~f:(fun which -> + iter Protocol.all ~f:(fun proto -> metadata_commands proto which)))