├── dune-project ├── vendor ├── dune └── tezai-contract-metadata-manipulation │ ├── .ocamlformat │ ├── dune │ ├── .gitlab-ci.yml │ ├── README.md │ ├── dune-project │ ├── content_validation.mli │ ├── import.ml │ ├── LICENSE │ ├── tezai-contract-metadata-manipulation.opam │ ├── micheline_helpers.mli │ ├── content_validation.ml │ ├── michelson_bytes.ml │ └── micheline_helpers.ml ├── src ├── deploy-examples │ ├── dune │ ├── .ocamlformat │ └── main.ml └── client │ ├── .ocamlformat │ ├── message_html.ml │ ├── dune │ ├── network.ml │ ├── errors_html.ml │ ├── ipfs_gateways.ml │ ├── main.ml │ ├── michelson_bytes.ml │ ├── async_work.ml │ ├── meta_html.ml │ ├── text_editor.ml │ ├── settings_page.ml │ ├── michelson.ml │ ├── import.ml │ ├── tzcomet_jsonm.mli │ ├── query_nodes.ml │ └── state.ml ├── .ocamlformat ├── data └── metadata_example0.json ├── .gitignore ├── LICENSE ├── .github └── workflows │ └── main.yml ├── README.md └── please.sh /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | -------------------------------------------------------------------------------- /vendor/dune: -------------------------------------------------------------------------------- 1 | (vendored_dirs *) 2 | -------------------------------------------------------------------------------- /src/deploy-examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries fmt unix base hex ezjsonm)) 4 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.24.1 2 | profile=default 3 | exp-grouping=preserve 4 | parse-docstrings 5 | sequence-blank-line=compact 6 | -------------------------------------------------------------------------------- /src/client/.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.24.1 2 | profile=default 3 | exp-grouping=preserve 4 | parse-docstrings 5 | sequence-blank-line=compact 6 | -------------------------------------------------------------------------------- /src/deploy-examples/.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.24.1 2 | profile=default 3 | exp-grouping=preserve 4 | parse-docstrings 5 | sequence-blank-line=compact 6 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.24.1 2 | profile=default 3 | exp-grouping=preserve 4 | parse-docstrings 5 | sequence-blank-line=compact 6 | -------------------------------------------------------------------------------- /data/metadata_example0.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "example_piece_of_metadata", 3 | "description": "This is constructed just to be an example.", 4 | "interfaces": [ 5 | "TZIP-16 draft as of Tue, 15 Sep 2020 14:49:48 -0400" 6 | ], 7 | "purpose": [ 8 | "example", "tutorial" 9 | ] 10 | } 11 | -------------------------------------------------------------------------------- /src/client/message_html.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | open Meta_html 3 | 4 | let render _ m = 5 | let module M = Message in 6 | let rec msg = function 7 | | M.Text s -> t s 8 | | M.Inline_code c -> ct c 9 | | M.Code_block b -> pre (ct b) 10 | | M.List l -> List.fold ~init:(empty ()) ~f:(fun a b -> a % msg b) l 11 | in 12 | msg m 13 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tezai_contract_metadata_manipulation) 3 | (public_name tezai-contract-metadata-manipulation) 4 | (inline_tests) 5 | (preprocess 6 | (pps ppx_inline_test ppx_expect)) 7 | (libraries 8 | tezos-micheline 9 | tezai-contract-metadata 10 | tezai-michelson 11 | re 12 | fmt 13 | base 14 | tezai-base58-digest)) 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | # Merlin configuring file for Vim and Emacs 23 | .merlin 24 | 25 | # Dune generated files 26 | *.install 27 | 28 | # Local OPAM switch 29 | _opam/ 30 | 31 | # local-vendor build files 32 | /local-vendor/ 33 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | build: 2 | image: ocaml/opam:alpine-3.15-ocaml-4.13 3 | script: 4 | - sudo cp /usr/bin/opam-2.1 /usr/bin/opam 5 | - sudo apk update 6 | - opam pin add -n tezai-base58-digest https://gitlab.com/oxheadalpha/tezai-base58-digest.git 7 | - opam pin add -n tezai-michelson https://gitlab.com/oxheadalpha/tezai-michelson.git 8 | - opam pin add -n tezai-contract-metadata https://gitlab.com/oxheadalpha/tezai-contract-metadata.git 9 | - opam exec -- opam install --with-test --with-doc ./tezai-contract-metadata-manipulation.opam 10 | 11 | -------------------------------------------------------------------------------- /src/client/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (target index.html) 3 | (deps 4 | (:js ../client/main.bc.js)) 5 | (action 6 | (with-stdout-to 7 | index.html 8 | (progn 9 | (run lwd-bootstrap-generator index --title TZComet --script %{js}))))) 10 | 11 | (executable 12 | (name main) 13 | (modes js) 14 | ;;(js_of_ocaml (flags --no-inline)) 15 | (preprocess 16 | (pps js_of_ocaml-ppx)) 17 | (libraries 18 | zarith_stubs_js 19 | fmt 20 | base 21 | js_of_ocaml-lwt 22 | re.posix 23 | tezai-michelson 24 | tezai-contract-metadata-manipulation 25 | base64 26 | digestif.ocaml 27 | lwd 28 | tyxml-lwd 29 | lwd-bootstrap)) 30 | -------------------------------------------------------------------------------- /src/client/network.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | type t = [ `Mainnet | `Oxfordnet | `Nairobinet | `Ghostnet | `Sandbox ] 4 | 5 | let to_string : t -> string = function 6 | | `Mainnet -> "Mainnet" 7 | | `Nairobinet -> "Nairobinet" 8 | | `Oxfordnet -> "Oxfordnet" 9 | | `Ghostnet -> "Ghostnet" 10 | | `Sandbox -> "Sandbox" 11 | 12 | let better_call_dev_path : t -> string option = function 13 | | `Mainnet -> Some "mainnet" 14 | | `Nairobinet -> Some "nairobinet" 15 | | `Oxfordnet -> Some "oxfordnet" 16 | | `Ghostnet -> Some "ghostnet" 17 | | `Sandbox -> None 18 | 19 | let all : t list = [ `Mainnet; `Nairobinet; `Oxfordnet; `Ghostnet; `Sandbox ] 20 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/README.md: -------------------------------------------------------------------------------- 1 | # tezai-contract-metadata-manipulation 2 | 3 | > _Helper functions for TZIP-016/012/021 metadata_ 4 | 5 | This is a library which provides extra helper functions for types defined in tezai-contract-metadata. 6 | 7 | This project is mostly developed in a monorepo at . 8 | 9 | ## Install 10 | 11 | ```sh 12 | opam pin add -n tezai-base58-digest https://gitlab.com/oxheadalpha/tezai-base58-digest.git 13 | opam pin add -n tezai-michelson https://gitlab.com/oxheadalpha/tezai-michelson.git 14 | opam pin add -n tezai-contract-metadata https://gitlab.com/oxheadalpha/tezai-contract-metadata.git 15 | opam exec -- opam install --with-test --with-doc tezai-contract-metadata-manipulation.opam 16 | ``` 17 | 18 | -------------------------------------------------------------------------------- /src/client/errors_html.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | open Meta_html 3 | 4 | type handler = exn -> (Html_types.li_content Meta_html.t * exn list) option 5 | 6 | let exception_html ?(handlers : handler list = []) ctxt exn = 7 | let rec construct = function 8 | | Decorate_error.E { message; trace } -> 9 | let trace_part = 10 | match trace with 11 | | [] -> empty () 12 | | more -> 13 | let collapse = Bootstrap.Collapse.make () in 14 | Bootstrap.Collapse.fixed_width_reactive_button_with_div_below 15 | collapse ~width:"12em" ~kind:`Secondary 16 | ~button:(function 17 | | true -> t "Show Error Trace" | false -> t "Hide Error Trace") 18 | (fun () -> itemize (List.map more ~f:construct)) 19 | in 20 | Message_html.render ctxt message % trace_part 21 | | Failure s -> t "Failure:" %% t s 22 | | e -> ( 23 | match List.find_map handlers ~f:(fun f -> f e) with 24 | | Some (m, []) -> m 25 | | Some (m, more) -> m % itemize (List.map more ~f:construct) 26 | | None -> t "Exception:" % pre (Fmt.kstr ct "%a" Exn.pp e)) 27 | in 28 | bt "Error:" %% construct exn 29 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | (generate_opam_files true) 3 | (name tezai-contract-metadata-manipulation) 4 | (package 5 | (name tezai-contract-metadata-manipulation) 6 | (authors 7 | "Seb Mondet " 8 | "Mark Nichols " 9 | "Phil Saxton " 10 | "David Turner " 11 | ) 12 | (maintainers 13 | "Seb Mondet " 14 | "Mark Nichols " 15 | "Phil Saxton " 16 | ) 17 | (synopsis "Helper functions for TZIP-016/012/021 metadata") 18 | (description "This is a library which provides extra helper functions for types defined in tezai-contract-metadata.") 19 | (homepage "https://gitlab.com/oxheadalpha/tezai-contract-metadata-manipulation") 20 | (bug_reports "https://gitlab.com/oxheadalpha/tezai-contract-metadata-manipulation/-/issues") 21 | (license "MIT") 22 | (depends 23 | (tezos-micheline (= "8.3")) 24 | re 25 | base 26 | fmt 27 | (ppx_expect (>= "0.14.0")) 28 | (ppx_inline_test (>= "0.14.0")) 29 | tezai-base58-digest 30 | tezai-michelson 31 | tezai-contract-metadata 32 | ) 33 | ) 34 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/content_validation.mli: -------------------------------------------------------------------------------- 1 | module Error : sig 2 | type t = 3 | | Forbidden_michelson_instruction of { view : string; instruction : string } 4 | | Michelson_version_not_a_protocol_hash of { view : string; value : string } 5 | 6 | val pp : Caml.Format.formatter -> t -> unit 7 | end 8 | 9 | module Warning : sig 10 | type t = 11 | | Wrong_author_format of string 12 | | Unexpected_whitespace of { field : string; value : string } 13 | | Self_unaddressed of { view : string; instruction : string option } 14 | 15 | val pp : Caml.Format.formatter -> t -> unit 16 | end 17 | 18 | module Data : sig 19 | val author_re : Re.re lazy_t 20 | val forbidden_michelson_instructions : string list 21 | end 22 | 23 | val validate : 24 | ?protocol_hash_is_valid:(string -> bool) -> 25 | Tezai_contract_metadata.Metadata_contents.t -> 26 | Error.t list * Warning.t list 27 | (** Run the validation on a metadata instance. The default 28 | [protocol_hash_is_valid] is [(fun _ -> true)], so by default the error 29 | [Michelson_version_not_a_protocol_hash _] is not reported (for library 30 | dependency reasons). *) 31 | 32 | val pp : Caml.Format.formatter -> Error.t list * Warning.t list -> unit 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 -- 2022 Seb Mondet 4 | Copyright (c) 2020 -- 2022 Mark Nichols 5 | Copyright (c) 2020 -- 2022 Phil Saxton 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: [push, pull_request] 3 | jobs: 4 | run: 5 | name: Build 6 | runs-on: ${{ matrix.operating-system }} 7 | strategy: 8 | matrix: 9 | #operating-system: [ubuntu-latest] 10 | operating-system: [macos-latest, ubuntu-latest] #, windows-latest] 11 | ocaml-compiler: [ '4.12.0', '4.13.1' ] 12 | steps: 13 | - uses: actions/checkout@v2 14 | - name: Cache 15 | uses: actions/cache@v2 16 | with: 17 | # A directory to store and save the cache 18 | path: ~/.opam 19 | # An explicit key for restoring and saving the cache 20 | key: ${{ matrix.operating-system }}-${{ matrix.ocaml-compiler }}-${{ hashFiles('please.sh', '**/dune') }}-build 21 | - name: Set up OCaml ${{ matrix.ocaml-compiler }} 22 | uses: ocaml/setup-ocaml@v2 23 | with: 24 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 25 | - run: global_switch=true ./please.sh ensure setup 26 | - run: opam exec -- dune --version 27 | - run: ./please.sh ensure linting 28 | - run: ./please.sh build all 29 | - run: ./please.sh deploy website deploy/ 30 | - name: Archive deployed TZComet 31 | uses: actions/upload-artifact@v2 32 | with: 33 | name: deployed-website 34 | path: deploy/ 35 | 36 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/import.ml: -------------------------------------------------------------------------------- 1 | include Base 2 | 3 | module Message = struct 4 | type t = 5 | | Text of string 6 | | Inline_code of string 7 | | Code_block of string 8 | | List of t list 9 | 10 | let text s = Text s 11 | let int f i : t = f (Int.to_string_hum ~delimiter:'_' i) 12 | let kpp f pp x : t = Fmt.kstr f "%a" pp x 13 | let inline_code s = Inline_code s 14 | let code_block s = Code_block s 15 | let list l = List l 16 | let ( % ) a b = List [ a; b ] 17 | let ( %% ) a b = List [ a; text " "; b ] 18 | let parens tt = list [ text "("; tt; text ")" ] 19 | 20 | let rec pp ppf = 21 | let open Fmt in 22 | function 23 | | Text s -> pf ppf "%s" s 24 | | Inline_code s -> pf ppf "`%s`" s 25 | | Code_block s -> pf ppf "@.```@.%s@.```@." s 26 | | List l -> List.iter l ~f:(pp ppf) 27 | end 28 | 29 | module Decorate_error = struct 30 | exception E of { message : Message.t; trace : exn list } 31 | 32 | let raise ?(trace = []) message = raise (E { message; trace }) 33 | let reraise message ~f = Lwt.catch f (fun e -> raise message ~trace:[ e ]) 34 | 35 | let () = 36 | Caml.Printexc.register_printer (function 37 | | E { message; _ } -> 38 | Some (Fmt.str "Decorated-Error %a" Message.pp message) 39 | | _ -> None) 40 | end 41 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 -- 2022 Seb Mondet 4 | Copyright (c) 2020 -- 2022 Mark Nichols 5 | Copyright (c) 2020 -- 2022 Phil Saxton 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/tezai-contract-metadata-manipulation.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Helper functions for TZIP-016/012/021 metadata" 4 | description: 5 | "This is a library which provides extra helper functions for types defined in tezai-contract-metadata." 6 | maintainer: [ 7 | "Seb Mondet " 8 | "Mark Nichols " 9 | "Phil Saxton " 10 | ] 11 | authors: [ 12 | "Seb Mondet " 13 | "Mark Nichols " 14 | "Phil Saxton " 15 | "David Turner " 16 | ] 17 | license: "MIT" 18 | homepage: 19 | "https://gitlab.com/oxheadalpha/tezai-contract-metadata-manipulation" 20 | bug-reports: 21 | "https://gitlab.com/oxheadalpha/tezai-contract-metadata-manipulation/-/issues" 22 | depends: [ 23 | "dune" {>= "2.9"} 24 | "tezos-micheline" {= "8.3"} 25 | "re" 26 | "base" 27 | "fmt" 28 | "ppx_expect" {>= "0.14.0"} 29 | "ppx_inline_test" {>= "0.14.0"} 30 | "tezai-base58-digest" 31 | "tezai-michelson" 32 | "tezai-contract-metadata" 33 | "odoc" {with-doc} 34 | ] 35 | build: [ 36 | ["dune" "subst"] {dev} 37 | [ 38 | "dune" 39 | "build" 40 | "-p" 41 | name 42 | "-j" 43 | jobs 44 | "--promote-install-files=false" 45 | "@install" 46 | "@runtest" {with-test} 47 | "@doc" {with-doc} 48 | ] 49 | ["dune" "install" "-p" name "--create-install-files" name] 50 | ] 51 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # TZComet: Tezos Contract Metadata 2 | 3 |
7 | 8 | … currently running at  … 9 | 10 | 11 | Part of the development happens in a *“monorepo”*: 12 | [oxheadalpha/flextesa-tzcomet-monorepo](https://gitlab.com/oxheadalpha/flextesa-tzcomet-monorepo/-/tree/main). 13 | 14 | ## Build 15 | 16 | ./please.sh ensure setup # Creates an opam switch 17 | ./please.sh build all 18 | 19 | ⬑ if all goes well, last command should print out a link to open the app, like 20 | `file://$PWD/_build/default/website/index.html`. 21 | 22 | 23 | ## Note 24 | 25 | The module Tzcomet_jsonm was copied from: 26 | 27 | - repository: 28 | - branch: jsoo-friendly 29 | - commit: a092b96d20302ffa50c1f10c2ac6bf81c7cff9cf 30 | 31 | This fork of Jsonm fixes the stack overflow error that can occur when parsing large objects in JSOO. 32 | 33 | ## Deployment 34 | 35 | This of course, requires push access to 36 | [oxheadalpha/TZComet](https://github.com/oxheadalpha/TZComet/) for it to impact 37 | [tzcomet.io](https://tzcomet.io) (but one can make it happen in their own fork 38 | and it will be at `.github.io/TZComet`). 39 | 40 | 41 | First time, create a local `gh-pages` branch: 42 | 43 | git branch gh-pages -t origin/gh-pages 44 | 45 | To deploy the current working directory to `/staging`: 46 | 47 | ./please.sh deploy togithub 48 | # Current branch is now gh-pages 49 | git push origin gh-pages 50 | git checkout master # or back to where you were 51 | 52 | (this calls does trigger the build). 53 | 54 | To deploy `origin/master` to production: 55 | 56 | prod=true ./please.sh deploy togithub 57 | # And push like for /staging 58 | 59 | 60 | ## See Also 61 | 62 | - Agora [post](https://forum.tezosagora.org/t/contract-metadata-on-tezos/2258) 63 | introducing the specification. 64 | - The 65 | [TZIP-16](https://gitlab.com/tzip/tzip/-/blob/master/proposals/tzip-16/tzip-16.md) 66 | specification. 67 | -------------------------------------------------------------------------------- /src/client/ipfs_gateways.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | type t = { 4 | gateways : string list Reactive.var; 5 | current_index : int Reactive.var; 6 | } 7 | 8 | let default_gateways : string list = 9 | [ 10 | "https://ipfs.io/ipfs/"; 11 | "https://dweb.link/ipfs/" (* ; "https://cloudflare-ipfs.com/ipfs/" *); 12 | ] 13 | 14 | let create () = 15 | { gateways = Reactive.var default_gateways; current_index = Reactive.var 0 } 16 | 17 | let get (ctxt : < ipfs_gateways : t ; .. > Context.t) = ctxt#ipfs_gateways 18 | let gateways t = (get t).gateways 19 | let current_index t = (get t).current_index 20 | 21 | exception Bad_gateway_index of string 22 | 23 | let get_nth the_list idx = 24 | let count = List.length the_list in 25 | let error_str = 26 | Printf.sprintf "Trying to use index %d on a list of gateways of size %d" idx 27 | count 28 | in 29 | let new_gw = 30 | try List.nth_exn the_list idx 31 | with Invalid_argument _ -> raise (Bad_gateway_index error_str) 32 | in 33 | new_gw 34 | 35 | let current_gateway t = 36 | let the_list = Reactive.peek (get t).gateways in 37 | let idx = Reactive.peek (get t).current_index in 38 | get_nth the_list idx 39 | 40 | let try_next ctxt = 41 | let ipfs = get ctxt in 42 | let old_gw = current_gateway ctxt in 43 | let the_list = Reactive.peek ipfs.gateways in 44 | let idx = Reactive.peek ipfs.current_index in 45 | let count = List.length the_list in 46 | let new_idx = if phys_equal idx (count - 1) then 0 else idx + 1 in 47 | Reactive.set (current_index ctxt) new_idx; 48 | let new_gw = get_nth the_list new_idx in 49 | dbgf "Ipfs_gateways.try_next - rotating IPFS gateways: %S ----> %S" old_gw 50 | new_gw; 51 | new_gw 52 | 53 | let add ctxt gateway = 54 | Reactive.set (gateways ctxt) (gateway :: Reactive.peek (gateways ctxt)) 55 | 56 | let remove_gateway ctxt ~uri = 57 | let ipfs = get ctxt in 58 | let gws = Reactive.peek ipfs.gateways in 59 | let new_list = List.filter gws ~f:(fun u -> not (String.equal u uri)) in 60 | let new_len = List.length new_list in 61 | if phys_equal new_len 0 then false (* tried to remove them all *) 62 | else 63 | let prev_idx = Reactive.peek ipfs.current_index in 64 | if prev_idx >= new_len then Reactive.set (current_index ctxt) 0; 65 | Reactive.set (gateways ctxt) new_list; 66 | true 67 | -------------------------------------------------------------------------------- /src/client/main.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | let get_version () = 4 | let open Lwt.Infix in 5 | Js_of_ocaml_lwt.XmlHttpRequest.( 6 | get "./VERSION" >>= fun frame -> 7 | dbgf "version: %d" frame.code; 8 | if frame.code = 200 then Lwt.return (Some frame.content) 9 | else Lwt.return None) 10 | 11 | let lwd_onload _ = 12 | let open Tyxml_lwd in 13 | let open Js_of_ocaml in 14 | let base_div = Dom_html.getElementById "attach-ui" in 15 | base_div##.innerHTML := Js.string ""; 16 | Lwt.ignore_result 17 | Lwt.Infix.( 18 | get_version () >>= fun version_string -> 19 | let fragment = Js_of_ocaml.Url.Current.get_fragment () in 20 | let sys, `Extra_node_prefixes more_nodes, gui = 21 | State.Fragment.parse fragment 22 | in 23 | let nodes = Query_nodes.create () in 24 | let ipfs_gateways = Ipfs_gateways.create () in 25 | let fetcher = Contract_metadata.Uri.Fetcher.create () in 26 | let storage = Local_storage.create () in 27 | let window = Browser_window.create () in 28 | let state = 29 | object 30 | method system = sys 31 | method gui = gui 32 | method nodes = nodes 33 | method ipfs_gateways = ipfs_gateways 34 | method fetcher = fetcher 35 | method storage = storage 36 | method window = window 37 | method version_string = version_string 38 | end 39 | in 40 | Query_nodes.add_default_nodes state; 41 | List.iter more_nodes ~f:(fun prefix -> 42 | Query_nodes.add_node state 43 | (Query_nodes.Node.create ~network:`Sandbox prefix prefix)); 44 | let doc = Gui.root_document state in 45 | let root = Lwd.observe doc in 46 | Lwd.set_on_invalidate root (fun _ -> 47 | ignore 48 | (Dom_html.window##requestAnimationFrame 49 | (Js.wrap_callback (fun _ -> 50 | while Lwd.is_damaged root do 51 | ignore (Lwd.quick_sample root) 52 | done)))); 53 | List.iter ~f:(Dom.appendChild base_div) 54 | (Lwd_seq.to_list (Lwd.quick_sample root) : _ node list :> raw_node list); 55 | Lwt.return_unit); 56 | Js._false 57 | 58 | let gen_eight_byte_mults n = 59 | let eight = "AF00DFED" in 60 | let rec loop acc n = if n > 0 then loop (eight ^ acc) (n - 1) else acc in 61 | "0x" ^ loop "" n 62 | 63 | (* TODO: run this as a test *) 64 | let _parse_test () = 65 | let the_bytes = gen_eight_byte_mults 1000 in 66 | let test_json : string = 67 | let before = " {\"prim\": \"Pair\", \"args\": [{\"bytes\": \"" in 68 | let after = "\"}, {\"int\": \"40462\"}]}" in 69 | before ^ the_bytes ^ after 70 | in 71 | Stdlib.output_string Stdlib.stdout (test_json ^ "\n"); 72 | let _z_value = Ezjsonm.value_from_string test_json in 73 | Stdlib.output_string Stdlib.stdout ("Done." ^ "\n") 74 | 75 | let _ = 76 | dbgf "Hello Main!"; 77 | let open Js_of_ocaml in 78 | (Lwt.async_exception_hook := fun e -> dbgf "Async Exn: %s" (Exn.to_string e)); 79 | Dom_html.window##.onload := Dom_html.handler lwd_onload 80 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/micheline_helpers.mli: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* *) 3 | (* Open Source License *) 4 | (* Copyright (c) 2020 TQ Tezos *) 5 | (* *) 6 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 7 | (* copy of this software and associated documentation files (the "Software"),*) 8 | (* to deal in the Software without restriction, including without limitation *) 9 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 10 | (* and/or sell copies of the Software, and to permit persons to whom the *) 11 | (* Software is furnished to do so, subject to the following conditions: *) 12 | (* *) 13 | (* The above copyright notice and this permission notice shall be included *) 14 | (* in all copies or substantial portions of the Software. *) 15 | (* *) 16 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) 17 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 18 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 19 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) 20 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 21 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 22 | (* DEALINGS IN THE SOFTWARE. *) 23 | (* *) 24 | (*****************************************************************************) 25 | 26 | (** Contract-storage-parsing helper functions for the implementation of TZIP-16. *) 27 | 28 | val normalize_combs : 29 | primitive:string -> Tezai_michelson.Untyped.t -> Tezai_michelson.Untyped.t 30 | (** Attempt to do what normalization RPC should do for right combs. [~primitive] 31 | should be ["Pair"] for values, and ["pair"] for types (sequences are not 32 | implemented). *) 33 | 34 | val find_metadata_big_maps : 35 | storage_node:Tezai_michelson.Untyped.t -> 36 | type_node:Tezai_michelson.Untyped.t -> 37 | Z.t list 38 | (** Assuming that [storage_node] is the storage expression of a contract has 39 | type [type_node], find the identifier of metadata-big-map according to the 40 | TZIP-16 specification. *) 41 | 42 | val build_off_chain_view_contract : 43 | Tezai_contract_metadata.Metadata_contents.View.Implementation 44 | .Michelson_storage 45 | .t -> 46 | contract_balance:Z.t -> 47 | contract_address:string -> 48 | contract_storage_type:Tezai_michelson.Untyped.t -> 49 | contract_parameter_type:Tezai_michelson.Untyped.t -> 50 | view_parameters:Tezai_michelson.Untyped.t -> 51 | contract_storage:Tezai_michelson.Untyped.t -> 52 | [ `Contract of Tezai_michelson.Untyped.t ] 53 | * [ `Input of Tezai_michelson.Untyped.t ] 54 | * [ `Storage of Tezai_michelson.Untyped.t ] 55 | (** Build a contract for the [".../run_script"] RPC of the node. *) 56 | -------------------------------------------------------------------------------- /src/client/michelson_bytes.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | let primitives = Tezai_michelson.Untyped.primitives 4 | 5 | let expr_encoding = 6 | Tezos_micheline.Micheline.canonical_encoding_v1 ~variant:"michelson_v1" 7 | (* Data_encoding.Encoding.string *) 8 | (let open Data_encoding in 9 | def "michelson.v1.primitives" @@ string_enum primitives) 10 | 11 | module Hex_reimplementation = struct 12 | open Caml 13 | (** We rewrite some of `hex.ml` to improve error messages. *) 14 | 15 | let to_char ~position x y = 16 | let code pos c = 17 | match c with 18 | | '0' .. '9' -> Char.code c - 48 (* Char.code '0' *) 19 | | 'A' .. 'F' -> Char.code c - 55 (* Char.code 'A' + 10 *) 20 | | 'a' .. 'f' -> Char.code c - 87 (* Char.code 'a' + 10 *) 21 | | _ -> 22 | Decorate_error.raise 23 | Message.( 24 | t "Character “" 25 | % ct (Char.escaped c) 26 | % t "”" 27 | %% parens 28 | (int ct (Char.code c) 29 | % t ", " 30 | %% Fmt.kstr ct "0x%02x" (Char.code c)) 31 | %% t "at position" %% int ct pos 32 | %% t "is not valid Hexadecimal encoding.") 33 | in 34 | Char.chr ((code position x lsl 4) + code (position + 1) y) 35 | 36 | let to_helper ~empty_return ~create ~set (`Hex s) = 37 | if s = "" then empty_return 38 | else 39 | let n = String.length s in 40 | let buf = create (n / 2) in 41 | let rec aux i j = 42 | if i >= n then () 43 | else if j >= n then 44 | Decorate_error.raise 45 | Message.( 46 | t "Invalid hexadecimal string: length should be even, not" 47 | %% int ct n % t ".") 48 | else ( 49 | set buf (i / 2) (to_char ~position:j s.[i] s.[j]); 50 | aux (j + 1) (j + 2)) 51 | in 52 | aux 0 1; 53 | buf 54 | 55 | let to_bytes hex = 56 | to_helper ~empty_return:Bytes.empty ~create:Bytes.create ~set:Bytes.set hex 57 | end 58 | 59 | let parse_hex_bytes bytes = 60 | try 61 | let mich = 62 | Data_encoding.Binary.of_bytes_exn 63 | (* Tezos_micheline.Micheline.canonical_location_encoding *) 64 | expr_encoding 65 | (Hex_reimplementation.to_bytes (`Hex bytes)) 66 | in 67 | let json = 68 | Data_encoding.Json.construct expr_encoding 69 | (* Tezos_micheline.Micheline.canonical_location_encoding *) 70 | mich 71 | in 72 | Ok 73 | ( json, 74 | let open Tezos_micheline in 75 | Fmt.str "%a" Micheline_printer.print_expr 76 | (Micheline_printer.printable Base.Fn.id mich) ) 77 | with e -> 78 | let open Tezos_error_monad.Error_monad in 79 | Error [ Exn e ] 80 | 81 | let encode_michelson_string s = 82 | Data_encoding.Binary.to_bytes_exn expr_encoding 83 | Tezos_micheline.Micheline.(String (0, s) |> strip_locations) 84 | |> Bytes.to_string 85 | 86 | let encode_michelson_int z = 87 | Data_encoding.Binary.to_bytes_exn expr_encoding 88 | Tezos_micheline.Micheline.(Int (0, z) |> strip_locations) 89 | |> Bytes.to_string 90 | 91 | let example () = 92 | let bytes = "0707002a002a" in 93 | let to_display = 94 | try 95 | let mich = 96 | Data_encoding.Binary.of_bytes_exn 97 | (* Tezos_micheline.Micheline.canonical_location_encoding *) 98 | expr_encoding 99 | (Hex.to_bytes (`Hex bytes)) 100 | in 101 | let json = 102 | Data_encoding.Json.construct expr_encoding 103 | (* Tezos_micheline.Micheline.canonical_location_encoding *) 104 | mich 105 | in 106 | Ezjsonm.value_to_string ~minify:false json 107 | with 108 | | Data_encoding.Binary.Read_error e -> 109 | Fmt.str "readerror: %a" Data_encoding.Binary.pp_read_error e 110 | | e -> Fmt.str "exn: %a" Exn.pp e 111 | in 112 | to_display 113 | -------------------------------------------------------------------------------- /please.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | usage () { 6 | cat >&2 < 8 | 9 | EOF 10 | } 11 | 12 | say () { 13 | printf "please.sh: %s\n" "$*" >&2 14 | } 15 | 16 | 17 | ocamlformat_version=0.24.1 18 | ensure_setup () { 19 | if [ "$global_switch" = "true" ] || [ -d _opam ] ; then 20 | say 'Opam switch already there' 21 | else 22 | opam switch create tzcomet-413 \ 23 | --formula='"ocaml-base-compiler" {>= "4.13" & < "4.14"}' 24 | opam switch link tzcomet-413 . 25 | fi 26 | eval $(opam env) 27 | opam pin add -n digestif 0.9.0 28 | opam pin add -n ocamlformat "$ocamlformat_version" 29 | # zarith_stubs_js fails with later version of those 2: 30 | opam pin add -n zarith 1.11 31 | opam pin add -n zarith_stubs_js v0.14.1 32 | # The older compiler does not work with recent dune: 33 | opam pin add -n js_of_ocaml-compiler 4.0.0 34 | tezais="lwd-bootstrap lwd-bootstrap-generator tezai-base58-digest tezai-michelson tezai-contract-metadata tezai-contract-metadata-manipulation" 35 | for tezai in $tezais ; do 36 | opam pin add -n $tezai https://gitlab.com/oxheadalpha/$tezai.git 37 | done 38 | # see https://github.com/janestreet/zarith_stubs_js/pull/8 39 | opam install -y base fmt uri cmdliner ezjsonm \ 40 | ocamlformat uri merlin ppx_deriving angstrom \ 41 | ppx_inline_test lwt-canceler.0.3 zarith_stubs_js \ 42 | digestif tyxml tyxml-lwd \ 43 | js_of_ocaml-compiler js_of_ocaml-lwt 44 | opam install -y $tezais 45 | } 46 | 47 | 48 | eval $(opam env) 49 | 50 | root_path=${root:-.} 51 | dune_profile=${profile:-release} 52 | 53 | build_all () { 54 | eval $(opam env) 55 | dune build @check 56 | mkdir -p _build/website/ 57 | dune build --profile "$dune_profile" $root_path/src/client/main.bc.js 58 | dune build --profile "$dune_profile" $root_path/src/client/index.html 59 | cp _build/default/$root_path/src/client/index.html _build/website/ 60 | chmod 600 _build/website/* 61 | echo "Done: file://$PWD/_build/website/index.html" 62 | } 63 | build_ () { 64 | build_all 65 | } 66 | 67 | deploy_examples () { 68 | dune exec src/deploy-examples/main.exe "$@" 69 | } 70 | 71 | deploy_website () { 72 | build_all 73 | dst="$1" 74 | mkdir -p "$dst" 75 | cp _build/website/* "$dst/" 76 | chmod a+w "$dst/"* 77 | git describe --always HEAD > "$dst/VERSION" 78 | echo "Done → $dst" 79 | } 80 | 81 | deploy_togithub () { 82 | localpath="staging" 83 | if [ "$prod" = "true" ] ; then 84 | localpath="." 85 | else 86 | mkdir -p "$localpath" 87 | fi 88 | dst=$(mktemp -d -p /tmp comevitz-XXX) 89 | if [ "$prod" = "true" ] ; then 90 | git checkout origin/master 91 | fi 92 | ./please.sh deploy website "$dst" 93 | # First time: git checkout --orphan gh-pages 94 | git checkout gh-pages 95 | mv "$dst/"* "$localpath" 96 | ( 97 | cd "$localpath" 98 | git add index.html VERSION 99 | ) 100 | msg="(Staging)" 101 | if [ "$prod" = "true" ] ; then 102 | msg="(Production)" 103 | fi 104 | git commit -m "Deploy $(cat "$localpath"/VERSION) $msg" 105 | say "Current branch in gh-pages, it is not pushed." 106 | } 107 | 108 | 109 | ensure_ocamlformats () { 110 | command="${1:-cp}" 111 | tmp=$(mktemp /tmp/XXXXX.ocamlformat) 112 | cat > "$tmp" <&2 122 | cat "$tmp" | sed 's/^/ ||/' >&2 123 | echo "You may have to run './please.sh ensure ocamlformats'" >&2 124 | return 4 125 | } 126 | done 127 | } 128 | 129 | 130 | ensure_linting () { 131 | echo "OCamlFormat version: $(ocamlformat --version)" 132 | ensure_ocamlformats "diff --brief" 133 | dune build @src/fmt --auto-promote 134 | } 135 | 136 | { 137 | case "$1" in 138 | "" | "--help" | "help" | "usage" ) 139 | usage ;; 140 | "ensure" | "build" | "deploy" ) 141 | cmd="$1_$2" 142 | shift 2 143 | "$cmd" "$@" ;; 144 | * ) 145 | "$@" ;; 146 | esac 147 | } 148 | -------------------------------------------------------------------------------- /src/client/async_work.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | type log_item = Html_types.div_content_fun Meta_html.H5.elt 4 | type status = Empty | Work_in_progress | Done 5 | type 'a content = ('a, log_item) Result.t list 6 | 7 | type 'a t = { 8 | logs : log_item Reactive.Table.t; 9 | status : status Reactive.var; 10 | id : int; 11 | content : 'a content Reactive.var; 12 | } 13 | 14 | let _id = ref 0 15 | 16 | let empty () = 17 | let id = !_id in 18 | Caml.incr _id; 19 | { 20 | logs = Reactive.Table.make (); 21 | status = Reactive.var Empty; 22 | id; 23 | content = Reactive.var []; 24 | } 25 | 26 | let logs_div_id t = Fmt.str "logs-of-async-work-%d" t.id 27 | 28 | let reinit s = 29 | Reactive.Table.clear s.logs; 30 | Reactive.set s.content []; 31 | Reactive.set s.status Empty 32 | 33 | let log t item = 34 | Reactive.Table.append' t.logs item; 35 | Lwt.async 36 | Lwt.Infix.( 37 | fun () -> 38 | Js_of_ocaml.( 39 | Js_of_ocaml_lwt.Lwt_js.sleep 0.1 >>= fun () -> 40 | let divid = logs_div_id t in 41 | dbgf "Trying to scroll down %s" divid; 42 | (match Dom_html.getElementById_opt divid with 43 | | Some e -> e##.scrollTop := 100000 44 | | None -> dbgf "Cannot find: %s" divid); 45 | Lwt.return_unit)); 46 | () 47 | 48 | let wip t = Reactive.set t.status Work_in_progress 49 | let wip_add_ok t ok = Reactive.set t.content (Ok ok :: Reactive.peek t.content) 50 | 51 | let wip_add_error t err = 52 | Reactive.set t.content (Error err :: Reactive.peek t.content) 53 | 54 | let ok t o = 55 | Reactive.set t.status Done; 56 | Reactive.set t.content [ Ok o ] 57 | 58 | let error t o = 59 | Reactive.set t.status Done; 60 | Reactive.set t.content [ Error o ] 61 | 62 | let finish t = Reactive.set t.status Done 63 | 64 | let busy { status; _ } = 65 | Reactive.( 66 | get status |> map ~f:(function Work_in_progress -> true | _ -> false)) 67 | 68 | let peek_busy { status; _ } = 69 | Reactive.(peek status |> function Work_in_progress -> true | _ -> false) 70 | 71 | let is_empty { status; _ } = 72 | Reactive.(get status |> map ~f:(function Empty -> true | _ -> false)) 73 | 74 | let async_catch : 75 | 'a t -> 76 | exn_to_html:(exn -> log_item) -> 77 | (mkexn:(log_item -> exn) -> unit -> unit Lwt.t) -> 78 | unit = 79 | fun wip ~exn_to_html f -> 80 | let open Lwt in 81 | let exception Work_failed of log_item in 82 | async (fun () -> 83 | catch 84 | (fun () -> f ~mkexn:(fun x -> Work_failed x) ()) 85 | (function 86 | | Work_failed l -> 87 | error wip l; 88 | return () 89 | | exn -> 90 | error wip (exn_to_html exn); 91 | return ())) 92 | 93 | let default_show_error e = 94 | let open Meta_html in 95 | Bootstrap.bordered ~kind:`Danger (div e) 96 | 97 | let render ?(done_empty = Meta_html.empty) ?(show_error = default_show_error) 98 | work_status ~f = 99 | let open Meta_html in 100 | let show_logs ?(wip = false) () = 101 | let make_logs_map _ x = H5.li [ x ] in 102 | let logs = Reactive.Table.concat_map ~map:make_logs_map work_status.logs in 103 | div 104 | ~a: 105 | [ 106 | H5.a_style (Lwd.pure "max-height: 20em; overflow: auto"); 107 | H5.a_id (Lwd.pure (logs_div_id work_status)); 108 | ] 109 | (Bootstrap.terminal_logs 110 | (H5.ul 111 | (if wip then 112 | [ logs; H5.li [ Bootstrap.spinner ~kind:`Info (t "Working …") ] ] 113 | else [ logs ]))) 114 | in 115 | let collapsing_logs () = 116 | let collapse = Bootstrap.Collapse.make () in 117 | Bootstrap.Collapse.fixed_width_reactive_button_with_div_below collapse 118 | ~width:"12em" ~kind:`Secondary 119 | ~button:(function true -> t "Show Logs" | false -> t "Collapse Logs") 120 | (fun () -> show_logs ~wip:false ()) 121 | in 122 | let content ~wip = 123 | Reactive.bind_var work_status.content ~f:(function 124 | | [] -> if wip then empty () else done_empty () 125 | | l -> 126 | (if wip then 127 | div 128 | (it "Work in progress …" 129 | %% Bootstrap.spinner ~kind:`Info (t "Working …")) 130 | else empty ()) 131 | % list 132 | (List.rev_map l ~f:(function 133 | | Ok o -> div (f o) 134 | | Error e -> show_error e))) 135 | in 136 | Reactive.bind_var work_status.status ~f:(function 137 | | Empty -> empty () 138 | | Work_in_progress -> content ~wip:true %% show_logs ~wip:true () 139 | | Done -> content ~wip:false %% collapsing_logs ()) 140 | -------------------------------------------------------------------------------- /src/client/meta_html.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | include Lwd_bootstrap.Mono_html 3 | module Bootstrap = Lwd_bootstrap.Bootstrap 4 | 5 | module Example = struct 6 | let e0 () = t "Hello" %% it "World" 7 | 8 | let e1 () = 9 | let button_calls = Reactive.var 0 in 10 | p (e0 ()) 11 | % Bootstrap.container_fluid 12 | (p (t "This is in a bootstrap" %% ct "container-fluid.") 13 | % p 14 | (Bootstrap.button ~kind:`Primary 15 | ~action:(fun () -> 16 | Reactive.set button_calls (Reactive.peek button_calls + 1)) 17 | (Reactive.bind_var button_calls ~f:(fun count -> 18 | H5.span 19 | [ 20 | Fmt.kstr 21 | (if Stdlib.( mod ) count 2 = 0 then it else bt) 22 | "Click %d" count; 23 | ]))) 24 | % p 25 | (Bootstrap.label `Danger 26 | (Reactive.bind_var button_calls ~f:(fun count -> 27 | Fmt.kstr t "Button above clicked %d time%s." count 28 | (if count = 1 then "" else "s")))) 29 | % p (t "A dropdown menu:") 30 | % Bootstrap.Dropdown_menu.( 31 | button 32 | (t "This is a" %% ct "Dropdown" %% t "menu") 33 | [ 34 | item (t "The First") ~action:(fun () -> 35 | dbgf "Hello from the first"); 36 | header (t "This is a dropdown" %% it "header"); 37 | item (t "The Second") ~action:(fun () -> 38 | dbgf "Hellow from the second"); 39 | ]) 40 | % p (t "A Nav-bar …") 41 | % Bootstrap.Navigation_bar.( 42 | make 43 | ~brand:(it "Examples of Meta_html") 44 | [ 45 | item (t "One") 46 | ~action:(fun () -> dbgf "one from nav bar") 47 | ~fragment:(Reactive.pure "page-one"); 48 | item ~active:(Reactive.pure false) (t "One-inactive") 49 | ~action:(fun () -> assert false); 50 | ]) 51 | % 52 | let hello = Reactive.var "is it me …" in 53 | let checkboxed = Reactive.var false in 54 | let submissions = Reactive.var [] in 55 | p (t "And now some forms") 56 | % Bootstrap.Form.( 57 | make 58 | [ 59 | input 60 | (Reactive.Bidirectional.of_var hello) 61 | ~label:(t "Say Hello"); 62 | check_box ~label:(t "Check this box") 63 | (Reactive.Bidirectional.of_var checkboxed); 64 | submit_button (t "Submit This!") (fun () -> 65 | Reactive.set submissions 66 | ((Reactive.peek hello, Reactive.peek checkboxed) 67 | :: Reactive.peek submissions)); 68 | ]) 69 | % p 70 | (t "Form results:" 71 | %% Reactive.bind_var hello ~f:(fun v -> t "Hello:" %% ct v) 72 | % t ", checkbox is " 73 | %% Reactive.bind_var checkboxed ~f:(function 74 | | false -> bt "not" 75 | | true -> empty ()) 76 | %% t "checked.") 77 | % itemize 78 | [ 79 | t "Some item"; 80 | t "Some other item"; 81 | t "truc" %% it "bidule" %% bt "chouette"; 82 | t "Form submissions:" 83 | %% Reactive.bind_var submissions ~f:(fun subs -> 84 | itemize ~numbered:true 85 | (List.rev_map subs ~f:(fun (h, c) -> 86 | t "Submission:" %% ct h % t "," 87 | %% if c then it "checked" else it "unchecked"))); 88 | ] 89 | % 90 | let content = Reactive.var "content" in 91 | H5.div 92 | [ 93 | (p (t "more input experiemnt" %% Reactive.bind_var content ~f:ct) 94 | %% H5.( 95 | input 96 | ~a: 97 | [ 98 | a_input_type (Reactive.pure `Text); 99 | a_value (Reactive.pure "hello"); 100 | a_oninput 101 | (Tyxml_lwd.Lwdom.attr 102 | Js_of_ocaml.( 103 | fun ev -> 104 | Js.Opt.iter ev##.target (fun input -> 105 | Js.Opt.iter (Dom_html.CoerceTo.input input) 106 | (fun input -> 107 | let v = input##.value |> Js.to_string in 108 | dbgf "TA inputs: %d bytes: %S" 109 | (String.length v) v; 110 | Reactive.set content v)); 111 | false)); 112 | ] 113 | ())); 114 | ]) 115 | end 116 | -------------------------------------------------------------------------------- /src/client/text_editor.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | let code_mirror = "https://cdnjs.cloudflare.com/ajax/libs/codemirror/5.39.2" 4 | 5 | type status = Non_initialized | Initialized 6 | 7 | type t = { 8 | id : string; 9 | language : string; 10 | code : string Reactive.Bidirectional.t; 11 | status : status Reactive.var; 12 | mutable text_area : Html_types.div Meta_html.t option; 13 | } 14 | 15 | let create ?(language = "mllike") id ~code = 16 | { 17 | id; 18 | language; 19 | code; 20 | text_area = None; 21 | status = Reactive.var Non_initialized; 22 | } 23 | 24 | let ensure te = 25 | match Reactive.peek te.status with 26 | | Initialized -> () 27 | | Non_initialized -> 28 | dbgf "Initializing %S" te.id; 29 | let (_ : unit) = 30 | Fmt.kstr Js_of_ocaml.Js.Unsafe.eval_string 31 | {js| 32 | // Create new link Element 33 | var link = document.createElement('link'); 34 | link.rel = 'stylesheet'; 35 | link.type = 'text/css'; 36 | link.href = '%s/codemirror.css'; 37 | // Get HTML head element to append 38 | // link element to it 39 | document.getElementsByTagName('HEAD')[0].appendChild(link); 40 | // Now the JS: 41 | var main_script = document.createElement('script'); 42 | main_script.src = '%s/codemirror.min.js'; 43 | document.head.appendChild(main_script); 44 | main_script.onload = function () { 45 | var lang_script = document.createElement('script'); 46 | lang_script.src = '%s/mode/%s/%s.min.js'; 47 | document.head.appendChild(lang_script); 48 | lang_script.onload = function () { 49 | var editor = CodeMirror.fromTextArea(document.getElementById(%S), 50 | { 51 | mode: %S, 52 | onChange: function(cm){ 53 | console.log("Cm save" + cm); 54 | cm.save(); 55 | document.getElementById(%S).change() 56 | }, 57 | lineWrapping: true, 58 | lineNumbers: true 59 | }); 60 | window.%s = editor; 61 | editor.on('change', editor => { 62 | editor.save(); 63 | var evt = document.createEvent("HTMLEvents"); 64 | evt.initEvent("change", false, true); 65 | document.getElementById(%S) 66 | .dispatchEvent(evt); 67 | }); 68 | /* See https://codemirror.net/demo/indentwrap.html */ 69 | var charWidth = editor.defaultCharWidth(), basePadding = 4; 70 | editor.on("renderLine", function(cm, line, elt) { 71 | var off = (2 + CodeMirror.countColumn(line.text, null, cm.getOption("tabSize"))) * charWidth; 72 | elt.style.textIndent = "-" + off + "px"; 73 | elt.style.paddingLeft = (basePadding + off) + "px"; 74 | }); 75 | editor.refresh(); 76 | }}; 77 | |js} 78 | code_mirror code_mirror code_mirror te.language te.language te.id 79 | te.language te.id te.id te.id 80 | in 81 | Reactive.set te.status Initialized 82 | 83 | let text_area te = 84 | match te.text_area with Some s -> s | None -> Fmt.failwith "TODO" 85 | 86 | (* 87 | let open RD in 88 | let css = 89 | {css| 90 | .editorcontainer { height: 50% } 91 | @media (min-width: 992px) { 92 | .editorcontainer { height: 90% } 93 | } 94 | .CodeMirror { height: auto } 95 | |css} 96 | in 97 | let area = 98 | div 99 | [ style [txt css] 100 | ; div 101 | ~a:[a_class ["editorcontainer"]] 102 | [ textarea 103 | ~a: 104 | [ a_id te.id; a_class ["form-control"] 105 | ; a_style "font-family: monospace"; a_rows 80 106 | ; a_onchange 107 | Js_of_ocaml.( 108 | fun ev -> 109 | Js.Opt.iter ev##.target (fun input -> 110 | Js.Opt.iter (Dom_html.CoerceTo.textarea input) 111 | (fun input -> 112 | let v = input##.value |> Js.to_string in 113 | dbgf "TA inputs: %d bytes" (String.length v) ; 114 | Var.set te.code v)) ; 115 | false) ] 116 | (txt (Var.value te.code)) ] ] in 117 | te.text_area <- Some area ; 118 | area 119 | 120 | let editor_command_button te ~text command_name = 121 | let open RD in 122 | button [txt text] 123 | ~a: 124 | [ a_class ["btn"; "btn-secondary"] 125 | ; a_onclick 126 | Js_of_ocaml.( 127 | fun _ -> 128 | let _ = 129 | Js.Unsafe.meth_call 130 | (Js.Unsafe.get Dom_html.window (Js.string te.id)) 131 | "execCommand" 132 | [|Js.string command_name |> Js.Unsafe.inject|] in 133 | let _ = 134 | Js.Unsafe.meth_call 135 | (Js.Unsafe.get Dom_html.window (Js.string te.id)) 136 | "focus" [||] in 137 | true) ] 138 | 139 | *) 140 | let set_code te ~code = 141 | Reactive.Bidirectional.set te.code code; 142 | let _ = 143 | let open Js_of_ocaml in 144 | Js.Unsafe.meth_call 145 | (Js.Unsafe.get Dom_html.window (Js.string te.id)) 146 | "setValue" 147 | [| Js.string code |> Js.Unsafe.inject |] 148 | in 149 | () 150 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/content_validation.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | module Error = struct 4 | type t = 5 | | Forbidden_michelson_instruction of { view : string; instruction : string } 6 | | Michelson_version_not_a_protocol_hash of { view : string; value : string } 7 | 8 | let pp ppf = 9 | let open Fmt in 10 | let textf f = kstr (fun s -> (box text) ppf s) f in 11 | function 12 | | Forbidden_michelson_instruction { view; instruction } -> 13 | textf "Forbidden Michelson instruction %S in view %S" instruction view 14 | | Michelson_version_not_a_protocol_hash { view; value } -> 15 | textf "Michelson version %S in view %S is not a protocol hash" value 16 | view 17 | end 18 | 19 | module Warning = struct 20 | type t = 21 | | Wrong_author_format of string 22 | | Unexpected_whitespace of { field : string; value : string } 23 | | Self_unaddressed of { view : string; instruction : string option } 24 | 25 | let pp ppf = 26 | let open Fmt in 27 | let textf f = kstr (fun s -> (box text) ppf s) f in 28 | function 29 | | Wrong_author_format auth -> textf "Wrong format for author field: %S" auth 30 | | Unexpected_whitespace { field; value } -> 31 | textf "Unexpected whitespace character(s) in field %S = %S" field value 32 | | Self_unaddressed { view; instruction } -> 33 | textf "SELF instruction not followed by ADDRESS (%s) in view %S" 34 | (Option.value instruction ~default:"by nothing") 35 | view 36 | end 37 | 38 | module Data = struct 39 | let author_re = lazy Re.Posix.(re "^[^\\<\\>]*<[^ ]+>$" |> compile) 40 | 41 | let forbidden_michelson_instructions = 42 | [ 43 | "AMOUNT"; 44 | "CREATE_CONTRACT"; 45 | "SENDER"; 46 | "SET_DELEGATE"; 47 | "SOURCE"; 48 | "TRANSFER_TOKENS"; 49 | ] 50 | end 51 | 52 | open Tezai_contract_metadata.Metadata_contents 53 | open Data 54 | 55 | let validate ?(protocol_hash_is_valid = fun _ -> true) (metadata : t) = 56 | let errors = ref [] in 57 | let warnings = ref [] in 58 | let error e = errors := e :: !errors in 59 | let warning e = warnings := e :: !warnings in 60 | let nl_or_tab = function '\n' | '\t' -> true | _ -> false in 61 | let nl_or_tab_or_sp = function '\n' | '\t' | ' ' -> true | _ -> false in 62 | let check_for_whitespace ?(whitespace = nl_or_tab) field value = 63 | if Base.String.exists value ~f:whitespace then 64 | warning Warning.(Unexpected_whitespace { field; value }) 65 | in 66 | let check_author = function 67 | | s when not (Re.execp (Lazy.force author_re) s) -> 68 | warning Warning.(Wrong_author_format s) 69 | | _ -> () 70 | in 71 | List.iter 72 | ~f:(fun a -> 73 | check_author a; 74 | check_for_whitespace "author" a) 75 | metadata.authors; 76 | Option.iter ~f:(check_for_whitespace "name") metadata.name; 77 | Option.iter ~f:(check_for_whitespace "version") metadata.version; 78 | let check_view (v : View.t) = 79 | let implementation (i : View.Implementation.t) = 80 | let open View.Implementation in 81 | match i with 82 | | Michelson_storage { code = Michelson_blob mich_code; version; _ } -> ( 83 | Option.iter 84 | ~f:(fun value -> 85 | if protocol_hash_is_valid value then () 86 | else 87 | error 88 | (Error.Michelson_version_not_a_protocol_hash 89 | { view = v.name; value })) 90 | version; 91 | let open Tezos_micheline.Micheline in 92 | let node = root mich_code in 93 | let rec iter = function 94 | | Int _ | String _ | Bytes _ -> `Other "literal" 95 | | Prim (_loc, p, args, _annots) -> ( 96 | if 97 | List.mem forbidden_michelson_instructions p 98 | ~equal:String.equal 99 | then 100 | error 101 | (Error.Forbidden_michelson_instruction 102 | { view = v.name; instruction = p }); 103 | let _ = List.map ~f:iter args in 104 | match p with 105 | | "SELF" -> `Self 106 | | "ADDRESS" -> `Address 107 | | _ -> `Other p) 108 | | Seq (_loc, l) -> 109 | let selves = List.map ~f:iter l in 110 | List.fold 111 | (selves : [ `Address | `Other of string | `Self ] list) 112 | ~init: 113 | (`Other "none" : [ `Address | `Other of string | `Self ]) 114 | ~f:(fun prev cur -> 115 | match (prev, cur) with 116 | | `Other _, _ -> cur 117 | | `Self, `Address -> cur 118 | | `Self, _ -> 119 | warning 120 | Warning.( 121 | Self_unaddressed 122 | { 123 | view = v.name; 124 | instruction = 125 | (match cur with 126 | | `Self -> Some "SELF" 127 | | `Other p -> Some p 128 | | `Address -> assert false); 129 | }); 130 | cur 131 | | `Address, _ -> cur) 132 | in 133 | match iter node with 134 | | `Self -> 135 | warning 136 | Warning.(Self_unaddressed { view = v.name; instruction = None }) 137 | | _ -> ()) 138 | | Rest_api_query _ -> () 139 | in 140 | check_for_whitespace "view.name" v.name ~whitespace:nl_or_tab_or_sp; 141 | List.iter ~f:implementation v.implementations 142 | in 143 | List.iter ~f:check_view metadata.views; 144 | (List.rev !errors, List.rev !warnings) 145 | 146 | let pp ppf = 147 | let open Fmt in 148 | function 149 | | [], [] -> pf ppf "No errors nor warnings." 150 | | errs, warns -> 151 | let pp_events prompt pp = 152 | let itemize ppf = function 153 | | [] -> const string "None" ppf () 154 | | more -> (cut ++ list ~sep:cut (const string "* " ++ pp)) ppf more 155 | in 156 | vbox ~indent:2 (const string prompt ++ itemize) 157 | in 158 | vbox 159 | (const (pp_events "Errors: " Error.pp) errs 160 | ++ cut 161 | ++ const (pp_events "Warnings: " Warning.pp) warns) 162 | ppf () 163 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/michelson_bytes.ml: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* *) 3 | (* Open Source License *) 4 | (* Copyright (c) 2020 TQ Tezos *) 5 | (* *) 6 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 7 | (* copy of this software and associated documentation files (the "Software"),*) 8 | (* to deal in the Software without restriction, including without limitation *) 9 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 10 | (* and/or sell copies of the Software, and to permit persons to whom the *) 11 | (* Software is furnished to do so, subject to the following conditions: *) 12 | (* *) 13 | (* The above copyright notice and this permission notice shall be included *) 14 | (* in all copies or substantial portions of the Software. *) 15 | (* *) 16 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) 17 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 18 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 19 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) 20 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 21 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 22 | (* DEALINGS IN THE SOFTWARE. *) 23 | (* *) 24 | (*****************************************************************************) 25 | 26 | open! Import 27 | 28 | module Hex_reimplementation = struct 29 | open Caml 30 | (** We rewrite some of `hex.ml` to improve error messages. *) 31 | 32 | let to_char ~position x y = 33 | let code pos c = 34 | match c with 35 | | '0' .. '9' -> Char.code c - 48 (* Char.code '0' *) 36 | | 'A' .. 'F' -> Char.code c - 55 (* Char.code 'A' + 10 *) 37 | | 'a' .. 'f' -> Char.code c - 87 (* Char.code 'a' + 10 *) 38 | | _ -> 39 | Decorate_error.raise 40 | Message.( 41 | text "Character “" 42 | % inline_code (Char.escaped c) 43 | % text "”" 44 | %% parens 45 | (int inline_code (Char.code c) 46 | % text ", " 47 | %% Fmt.kstr inline_code "0x%02x" (Char.code c)) 48 | %% text "at position" %% int inline_code pos 49 | %% text "is not valid Hexadecimal encoding.") 50 | in 51 | Char.chr ((code position x lsl 4) + code (position + 1) y) 52 | 53 | let to_helper ~empty_return ~create ~set (`Hex s) = 54 | if s = "" then empty_return 55 | else 56 | let n = String.length s in 57 | let buf = create (n / 2) in 58 | let rec aux i j = 59 | if i >= n then () 60 | else if j >= n then 61 | Decorate_error.raise 62 | Message.( 63 | text "Invalid hexadecimal string: length should be even, not" 64 | %% int inline_code n % text ".") 65 | else ( 66 | set buf (i / 2) (to_char ~position:j s.[i] s.[j]); 67 | aux (j + 1) (j + 2)) 68 | in 69 | aux 0 1; 70 | buf 71 | 72 | let to_bytes hex = 73 | to_helper ~empty_return:Bytes.empty ~create:Bytes.create ~set:Bytes.set hex 74 | end 75 | 76 | let parse_hex_bytes bytes = 77 | try 78 | let mich = 79 | Data_encoding.Binary.of_bytes_exn 80 | (* Tezos_micheline.Micheline.canonical_location_encoding *) 81 | Tezai_michelson.Untyped.expr_encoding 82 | (Hex_reimplementation.to_bytes (`Hex bytes)) 83 | in 84 | let json = 85 | Data_encoding.Json.construct Tezai_michelson.Untyped.expr_encoding 86 | (* Tezos_micheline.Micheline.canonical_location_encoding *) 87 | mich 88 | in 89 | Ok 90 | ( json, 91 | let open Tezos_micheline in 92 | Fmt.str "%a" Micheline_printer.print_expr 93 | (Micheline_printer.printable Base.Fn.id mich) ) 94 | with e -> 95 | let open Tezos_error_monad.Error_monad in 96 | Error [ Exn e ] 97 | 98 | let pack_node_expression e = 99 | Data_encoding.Binary.to_bytes_exn Tezai_michelson.Untyped.expr_encoding 100 | (Tezos_micheline.Micheline.strip_locations e) 101 | |> Bytes.to_string 102 | 103 | let encode_michelson_string s = 104 | Data_encoding.Binary.to_bytes_exn Tezai_michelson.Untyped.expr_encoding 105 | Tezos_micheline.Micheline.(String (0, s) |> strip_locations) 106 | |> Bytes.to_string 107 | 108 | let encode_michelson_int i = 109 | Data_encoding.Binary.to_bytes_exn Tezai_michelson.Untyped.expr_encoding 110 | Tezos_micheline.Micheline.(Int (0, i) |> strip_locations) 111 | |> Bytes.to_string 112 | 113 | let b58_script_id_hash_of_michelson_string s = 114 | Tezai_base58_digest.Identifier.Script_expr_hash.( 115 | hash_string ("\x05" ^ encode_michelson_string s) |> encode) 116 | 117 | let b58_script_id_hash_of_michelson_int s = 118 | Tezai_base58_digest.Identifier.Script_expr_hash.( 119 | hash_string ("\x05" ^ encode_michelson_int s) |> encode) 120 | 121 | let%expect_test _ = 122 | let p f v = Caml.Printf.printf "%S\n%!" (f v) in 123 | let ps = p b58_script_id_hash_of_michelson_string in 124 | let pi i = p b58_script_id_hash_of_michelson_int (Z.of_int i) in 125 | ps "" (* Check against `tezos-client hash data '""' of type string` *); 126 | [%expect {| "expru5X1yxJG6ezR2uHMotwMLNmSzQyh5t1vUnhjx4cS6Pv9qE1Sdo" |}]; 127 | ps "hello"; 128 | [%expect {| "exprtsjEVVZk3Gm82U9wEs8kvwRiQwUT7zipJwvCeFMNsApe2tQ15s" |}]; 129 | pi 0; 130 | [%expect {| "exprtZBwZUeYYYfUs9B9Rg2ywHezVHnCCnmF9WsDQVrs582dSK63dC" |}]; 131 | pi (-1); 132 | [%expect {| "expru57wdzZCHCeGnKwUzxCJjG1HjveGXp1CCusScXEMq9kbidSvDG" |}]; 133 | pi (-10_000); 134 | [%expect {| "expruboESrygwvfT6TdLDL6JWZ1RSyGxKV3szmVs6bgMWXbGnrToHi" |}]; 135 | pi 10_000; 136 | [%expect {| "exprvLmTaiHBSiSgMnh1prUQA6wK2pGcmxHzTAkzX6Ym8b2Kjj1QHL" |}]; 137 | pi 1; 138 | [%expect {| "expru2dKqDfZG8hu4wNGkiyunvq2hdSKuVYtcKta7BWP6Q18oNxKjS" |}]; 139 | () 140 | 141 | let example () = 142 | let bytes = "0707002a002a" in 143 | let to_display = 144 | try 145 | let mich = 146 | Data_encoding.Binary.of_bytes_exn 147 | (* Tezos_micheline.Micheline.canonical_location_encoding *) 148 | Tezai_michelson.Untyped.expr_encoding 149 | (Hex.to_bytes (`Hex bytes)) 150 | in 151 | let json = 152 | Data_encoding.Json.construct Tezai_michelson.Untyped.expr_encoding 153 | (* Tezos_micheline.Micheline.canonical_location_encoding *) 154 | mich 155 | in 156 | Ezjsonm.value_to_string ~minify:false json 157 | with 158 | | Data_encoding.Binary.Read_error e -> 159 | Fmt.str "readerror: %a" Data_encoding.Binary.pp_read_error e 160 | | e -> Fmt.str "exn: %a" Base.Exn.pp e 161 | in 162 | to_display 163 | -------------------------------------------------------------------------------- /vendor/tezai-contract-metadata-manipulation/micheline_helpers.ml: -------------------------------------------------------------------------------- 1 | (*****************************************************************************) 2 | (* *) 3 | (* Open Source License *) 4 | (* Copyright (c) 2020 TQ Tezos *) 5 | (* *) 6 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 7 | (* copy of this software and associated documentation files (the "Software"),*) 8 | (* to deal in the Software without restriction, including without limitation *) 9 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 10 | (* and/or sell copies of the Software, and to permit persons to whom the *) 11 | (* Software is furnished to do so, subject to the following conditions: *) 12 | (* *) 13 | (* The above copyright notice and this permission notice shall be included *) 14 | (* in all copies or substantial portions of the Software. *) 15 | (* *) 16 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) 17 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 18 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 19 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) 20 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 21 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 22 | (* DEALINGS IN THE SOFTWARE. *) 23 | (* *) 24 | (*****************************************************************************) 25 | 26 | (* 27 | let get_script_field_exn string_micheline field = 28 | let open Micheline in 29 | let type_opt = 30 | match root string_micheline with 31 | | Seq (_, l) -> 32 | Base.List.find_map l ~f:(function 33 | | Prim (_, f, [t], _) when f = field -> Some t 34 | | _ -> None ) 35 | | _ -> None in 36 | match type_opt with 37 | | None -> Fmt.failwith "Cannot find the %S field for the contract" field 38 | | Some s -> s 39 | 40 | let get_storage_type_exn string_micheline = 41 | get_script_field_exn string_micheline "storage" 42 | 43 | let get_parameter_type_exn string_micheline = 44 | get_script_field_exn string_micheline "parameter" 45 | 46 | let pp_arbitrary_micheline ppf e = 47 | let module P = Micheline_printer in 48 | P.print_expr ppf 49 | (Micheline.map_node (fun _ -> {P.comment= None}) (fun x -> x) e) 50 | *) 51 | 52 | let rec normalize_combs ~primitive m = 53 | let open Tezai_michelson.Untyped.M in 54 | let continue = normalize_combs ~primitive in 55 | let is_prim p = String.equal p primitive in 56 | match m with 57 | | Prim (loc, p, [ l; r ], ann) when is_prim p -> 58 | Prim (loc, p, [ continue l; continue r ], ann) 59 | | Prim (loc, p, one :: more, ann) when is_prim p -> 60 | let right = Prim (loc, p, List.map continue more, []) |> continue in 61 | Prim (loc, p, [ continue one; right ], ann) 62 | | other -> other 63 | 64 | let%expect_test _ = 65 | let test c = 66 | let m = Tezai_michelson.Untyped.C.concrete c in 67 | Fmt.pr "%a\n%!" Tezai_michelson.Untyped.pp 68 | (normalize_combs ~primitive:"Pair" m) 69 | in 70 | test "(Pair 2 3)"; 71 | [%expect {| (Pair 2 3) |}]; 72 | test "(Pair 2 3 4)"; 73 | [%expect {| (Pair 2 (Pair 3 4)) |}]; 74 | test "(Pair 2 (Pair 3 4))"; 75 | [%expect {| (Pair 2 (Pair 3 4)) |}]; 76 | test "(Pair 2 (Pair 1 2 3 4))"; 77 | [%expect {| (Pair 2 (Pair 1 (Pair 2 (Pair 3 4)))) |}]; 78 | test "(Pair 2 (Junk 1 2 3 4))"; 79 | [%expect {| (Pair 2 (Junk 1 2 3 4)) |}]; 80 | test "(Pair (Pair %hello 2 3) (Pair 1 2 3) 4)"; 81 | [%expect {| (Pair (Pair %hello 2 3) (Pair (Pair 1 (Pair 2 3)) 4)) |}]; 82 | () 83 | 84 | let rec find_metadata_big_maps ~storage_node ~type_node = 85 | let open Tezai_michelson.Untyped.M in 86 | let go (storage_node, type_node) = 87 | find_metadata_big_maps ~storage_node ~type_node 88 | in 89 | match (storage_node, type_node) with 90 | | Prim (_, "Pair", [ l; r ], _), Prim (_, "pair", [ lt; rt ], _) -> 91 | go (l, lt) @ go (r, rt) 92 | | ( Int (_, z), 93 | Prim 94 | ( _, 95 | "big_map", 96 | [ Prim (_, "string", [], _); Prim (_, "bytes", [], _) ], 97 | [ "%metadata" ] ) ) -> 98 | [ z ] 99 | | Int (_, _z), _ -> [] 100 | | String (_, _s), _ -> [] 101 | | Bytes (_, _b), _ -> [] 102 | | Prim (_, _prim, _args, _annot), _t -> [] 103 | | Seq (_, _l), _t -> [] 104 | 105 | let build_off_chain_view_contract view ~contract_balance ~contract_address 106 | ~contract_storage_type ~contract_parameter_type ~view_parameters 107 | ~contract_storage = 108 | let open Tezai_contract_metadata in 109 | let open Metadata_contents.View in 110 | let open Metadata_contents.Michelson_blob in 111 | let open Implementation.Michelson_storage in 112 | let open Tezai_michelson.Untyped.M in 113 | let getm = function 114 | | Michelson_blob m -> Tezai_michelson.Untyped.of_canonical_micheline m 115 | in 116 | let open Tezai_michelson.Untyped.C in 117 | let parameter, input = 118 | match Option.map getm view.parameter with 119 | | Some m -> 120 | ( prim "pair" [ m; contract_storage_type ], 121 | prim "Pair" [ view_parameters; contract_storage ] ) 122 | | None -> (contract_storage_type, contract_storage) 123 | in 124 | let storage = getm view.return_type in 125 | let code = getm view.code in 126 | let rec fix_code c = 127 | let continue = List.map (fun c -> fix_code c) in 128 | match c with 129 | | (Int _ | String _ | Bytes _) as lit -> 130 | Tezai_michelson.Untyped.of_micheline_node lit 131 | | Prim (_loc, "SELF", [], annotations) -> 132 | seq 133 | [ 134 | prim "PUSH" [ prim "address" []; string contract_address ]; 135 | prim ~annotations "CONTRACT" [ contract_parameter_type ]; 136 | prim "IF_NONE" 137 | [ seq [ prim "UNIT" []; prim "FAILWITH" [] ]; seq [] ]; 138 | ] 139 | | Prim (_loc, "BALANCE", [], annotations) -> 140 | prim "PUSH" [ prim "mutez" []; int contract_balance ] ~annotations 141 | | Prim (_, name, args, annotations) -> 142 | prim name (continue args) ~annotations 143 | | Seq (_, l) -> seq (continue l) 144 | in 145 | let rec remove_annotations c = 146 | let continue = List.map (fun c -> remove_annotations c) in 147 | match c with 148 | | (Int _ | String _ | Bytes _) as lit -> 149 | Tezai_michelson.Untyped.of_micheline_node lit 150 | | Prim (_, name, args, _annotations) -> 151 | prim name (continue args) ~annotations:[] 152 | | Seq (_, l) -> seq (continue l) 153 | in 154 | ( `Contract 155 | (seq 156 | [ 157 | prim "parameter" [ parameter ]; 158 | prim "storage" [ prim "option" [ remove_annotations storage ] ]; 159 | prim "code" 160 | [ 161 | seq 162 | [ 163 | prim "CAR" [] (* We drop the storage (= None). *); 164 | fix_code code; 165 | prim "SOME" []; 166 | prim "NIL" [ prim "operation" [] ]; 167 | prim "PAIR" []; 168 | ]; 169 | ]; 170 | ]), 171 | `Input input, 172 | `Storage (prim "None" []) ) 173 | -------------------------------------------------------------------------------- /src/client/settings_page.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | let nodes_form ctxt = 4 | let open Meta_html in 5 | Bootstrap.Table.simple 6 | ~header_row: 7 | [ 8 | t "Name"; 9 | t "Network"; 10 | t "URI-Prefix"; 11 | t "Status"; 12 | t "Latest Ping" 13 | %% Reactive.bind 14 | (Query_nodes.loop_status ctxt) 15 | ~f: 16 | (let m s = i (parens (t s)) in 17 | function 18 | | `Not_started -> m "ping-loop not started" 19 | | `In_progress -> m "ping-loop in progress" 20 | | `Sleeping -> m "ping-loop sleeping"); 21 | t ""; 22 | ] 23 | (let row l = H5.tr (List.map ~f:td l) in 24 | let node_status = 25 | let m kind s = Bootstrap.color kind (Bootstrap.monospace (t s)) in 26 | Query_nodes.Node_status.( 27 | function 28 | | Uninitialized -> m `Warning "Uninitialized" 29 | | Non_responsive e -> 30 | let collapse = Bootstrap.Collapse.make () in 31 | m `Danger "Non-responsive" 32 | % Bootstrap.Collapse.fixed_width_reactive_button_with_div_below 33 | collapse ~width:"12em" ~kind:`Secondary 34 | ~button:(function 35 | | true -> t "Show Error" | false -> t "Hide Error") 36 | (fun () -> Errors_html.exception_html ctxt e) 37 | | Ready metadata -> 38 | let extra_info = 39 | try 40 | let dict = Ezjsonm.(value_from_string metadata |> get_dict) in 41 | let field l f = 42 | try List.Assoc.find_exn l ~equal:String.equal f 43 | with _ -> Fmt.failwith "Missing field: %S" f 44 | in 45 | let protocol = field dict "protocol" |> Ezjsonm.get_string in 46 | let level = 47 | let l = 48 | (try field dict "level" 49 | with _ -> field dict "level_info" (* Granada version *)) 50 | |> Ezjsonm.get_dict 51 | in 52 | let level = field l "level" |> Ezjsonm.get_int in 53 | level 54 | in 55 | t "[" 56 | % Tezos_html.protocol protocol 57 | % t "," 58 | %% Fmt.kstr t "Level: %d" level 59 | % t "]" 60 | with e -> 61 | let collapse = Bootstrap.Collapse.make () in 62 | Bootstrap.Collapse.fixed_width_reactive_button_with_div_below 63 | collapse ~width:"12em" ~kind:`Secondary 64 | ~button:(function 65 | | true -> t "Failed to parse metadata" 66 | | false -> t "Hide Error") 67 | (fun () -> 68 | pre (code (t metadata)) 69 | %% Errors_html.exception_html ctxt e) 70 | in 71 | m `Success "Ready" %% extra_info) 72 | in 73 | let ping_date date = 74 | if Float.(date < 10.) then (* Construction sign: *) t "🚧" 75 | else 76 | let date_string = 77 | (new%js Js_of_ocaml.Js.date_fromTimeValue (1000. *. date))##toISOString 78 | |> Js_of_ocaml__Js.to_string 79 | in 80 | Bootstrap.monospace (t date_string) 81 | in 82 | let row_of_node n = 83 | row 84 | Query_nodes.Node. 85 | [ 86 | (match n.info_url with 87 | | None -> it n.name 88 | | Some target -> link ~target (it n.name)); 89 | Tezos_html.network n.network; 90 | ct n.prefix; 91 | Reactive.bind (status n) ~f:(fun (_, s) -> node_status s); 92 | Reactive.bind (status n) ~f:(fun (f, _) -> ping_date f); 93 | Bootstrap.button ~outline:true ~size:`Small ~kind:`Danger 94 | (t "Remove 💣") ~action:(fun () -> 95 | Query_nodes.remove_node ctxt ~name:n.name); 96 | ] 97 | in 98 | let last_row = 99 | let name = Reactive.var "" in 100 | let nameb = Reactive.Bidirectional.of_var name in 101 | let network = Reactive.var `Sandbox in 102 | let prefix = Reactive.var "" in 103 | let prefixb = Reactive.Bidirectional.of_var prefix in 104 | row 105 | [ 106 | input_bidirectional nameb 107 | ~a: 108 | [ 109 | H5.a_placeholder (Reactive.pure "Name"); 110 | classes [ "form-control" ]; 111 | ]; 112 | input_bidirectional prefixb 113 | ~a: 114 | [ 115 | H5.a_placeholder (Reactive.pure "URL-Prefix"); 116 | classes [ "form-control" ]; 117 | ]; 118 | Bootstrap.Dropdown_menu.( 119 | let items = 120 | List.map Network.all ~f:(fun net -> 121 | item (Tezos_html.network net) ~action:(fun () -> 122 | Reactive.set network net)) 123 | in 124 | button 125 | (Reactive.get network 126 | |> Reactive.bind ~f:(fun net -> 127 | t "Network:" %% Tezos_html.network net)) 128 | items); 129 | Bootstrap.button (t "⇐ Add/replace node (by name)") ~kind:`Secondary 130 | ~action:(fun () -> 131 | Query_nodes.add_node ctxt 132 | (Query_nodes.Node.create (Reactive.peek name) 133 | ~network:(Reactive.peek network) (Reactive.peek prefix)); 134 | Reactive.Bidirectional.set nameb ""; 135 | Reactive.Bidirectional.set prefixb ""; 136 | ()); 137 | Bootstrap.button (t "⇑ Ping'em'all") ~kind:`Secondary 138 | ~action:(fun () -> 139 | Query_nodes.Update_status_loop.ensure ctxt; 140 | Query_nodes.Update_status_loop.wake_up ctxt); 141 | ] 142 | in 143 | Reactive.bind (Query_nodes.get_nodes ctxt ~map:row_of_node) 144 | ~f:(fun nodes -> list nodes) 145 | % last_row) 146 | 147 | let render ctxt = 148 | let open Meta_html in 149 | let timeout_valid_and_changed = Reactive.var None in 150 | let timeout = 151 | Reactive.Bidirectional.make 152 | (System.http_timeout_peek ctxt |> Fmt.str "%f" |> Reactive.pure) 153 | (fun x -> 154 | match Float.of_string x with 155 | | f -> 156 | System.set_http_timeout ctxt f; 157 | Reactive.set timeout_valid_and_changed 158 | (Some (t "Timeout set to " % Fmt.kstr ct "%f" f)) 159 | | exception _ -> 160 | Reactive.set timeout_valid_and_changed 161 | (Some 162 | (Bootstrap.color `Danger 163 | (t "Timeout cannot be set to" 164 | %% ct x 165 | % t ", it should a valid floating-point number.")))) 166 | in 167 | h2 (t "Settings") 168 | % Bootstrap.Form.( 169 | make 170 | [ 171 | check_box 172 | (State.dev_mode_bidirectional ctxt) 173 | ~label:(t "Dev-mode enabled") 174 | ~help: 175 | (t 176 | "Shows things that regular users should not see and \ 177 | artificially slows down the application."); 178 | check_box 179 | (State.check_micheline_indentation_bidirectional ctxt) 180 | ~label:(t "Check Micheline Indentation") 181 | ~help: 182 | (t 183 | "Make the Micheline parser (in the Editor) also check for \ 184 | proper indentation like" 185 | %% ct "tezos-client" %% t "does."); 186 | check_box 187 | (State.always_show_multimedia_bidirectional ctxt) 188 | ~label: 189 | (t "Always show all multimedia, without NSFW warning-button.") 190 | ~help: 191 | (t "The Token-Viewer knows about some multimedia that is tagged" 192 | %% it "“safe-for-all-audiences,”" 193 | %% t 194 | "and hides everything else behind a show/hide button. Check \ 195 | this box to disable this and just show everything wherever \ 196 | it comes from."); 197 | input 198 | ~placeholder:(Reactive.pure "Number of seconds (with decimals).") 199 | ~help: 200 | (Reactive.bind_var timeout_valid_and_changed ~f:(function 201 | | None -> 202 | t 203 | "How long to wait for nodes and gateways to give/accept \ 204 | data." 205 | | Some msg -> msg)) 206 | ~label:(t "HTTP-Call Timeout") timeout; 207 | ]) 208 | % h3 (t "Tezos Nodes") 209 | % nodes_form ctxt 210 | -------------------------------------------------------------------------------- /src/client/michelson.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | let micheline_of_json s = 4 | dbgf "micheline_of_json : %d bytes" (String.length s); 5 | let json = 6 | match Ezjsonm.value_from_string s with 7 | | `O (("code", code) :: _) -> code 8 | | other -> other 9 | in 10 | dbgf "micheline_of_json: done parsing"; 11 | Tezai_michelson.Untyped.of_json json 12 | 13 | let micheline_node_to_string node = 14 | Tezai_michelson.Untyped.of_micheline_node node 15 | |> Tezai_michelson.Concrete_syntax.to_string 16 | 17 | module Partial_type = struct 18 | module Structure = struct 19 | type type_kind = 20 | | Any 21 | | Nat 22 | | Mutez 23 | | Bytes 24 | | Address 25 | | Bool 26 | | String 27 | | List of type_kind 28 | | Map of type_kind * type_kind 29 | 30 | type leaf = string Reactive.var 31 | 32 | type t = 33 | | Leaf of { 34 | raw : string Tezos_micheline.Micheline.canonical; 35 | kind : type_kind; 36 | v : leaf; 37 | description : (string * string) option; 38 | } 39 | | Pair of { left : t; right : t } 40 | end 41 | 42 | type t = { 43 | original : string Tezos_micheline.Micheline.canonical; 44 | structure : Structure.t; 45 | } 46 | 47 | open Structure 48 | open! Tezai_contract_metadata.Metadata_contents.View.Implementation 49 | open! Tezai_contract_metadata.Metadata_contents.Michelson_blob 50 | 51 | let of_type ?(annotations = []) (Michelson_blob m) = 52 | let view_annots = annotations in 53 | let open Tezos_micheline.Micheline in 54 | let describe annot = 55 | List.find view_annots ~f:(fun (k, _) -> 56 | List.mem annot k ~equal:String.equal) 57 | in 58 | let rec go tp = 59 | let raw = strip_locations tp in 60 | let leaf ?annot kind = 61 | let description = Option.bind ~f:describe annot in 62 | Leaf { raw; kind; v = Reactive.var ""; description } 63 | in 64 | match tp with 65 | | Prim (_, "nat", [], annot) -> leaf Nat ~annot 66 | | Prim (_, "mutez", [], annot) -> leaf Mutez ~annot 67 | | Prim (_, "bytes", [], annot) -> leaf Bytes ~annot 68 | | Prim (_, "string", [], annot) -> leaf String ~annot 69 | | Prim (_, "address", [], annot) -> leaf Address ~annot 70 | | Prim (_, "bool", [], annot) -> leaf Bool ~annot 71 | | Prim (_, "pair", [ l; r ], _) -> Pair { left = go l; right = go r } 72 | | Prim (_, "list", [ Prim (_, "nat", [], _) ], annot) -> 73 | leaf (List Nat) ~annot 74 | | Prim 75 | ( _, 76 | "map", 77 | [ Prim (_, "string", [], _); Prim (_, "bytes", [], _) ], 78 | annot ) -> 79 | leaf (Map (String, Bytes)) ~annot 80 | | Prim (_, _, _, annot) -> leaf Any ~annot 81 | | _ -> leaf Any 82 | in 83 | { original = m; structure = go (root m) } 84 | 85 | let rec fill_structure_with_value mf node = 86 | let open Tezos_micheline.Micheline in 87 | let mich_node nod = 88 | Tezai_michelson.( 89 | Concrete_syntax.to_string (Untyped.of_micheline_node nod)) 90 | in 91 | match (mf, node) with 92 | | Leaf leaf, nn -> Reactive.set leaf.v (mich_node nn) 93 | | Pair { left; right }, Prim (_, "Pair", [ l; r ], _) -> 94 | fill_structure_with_value left l; 95 | fill_structure_with_value right r 96 | | Pair _, other -> 97 | Decorate_error.( 98 | raise 99 | Message.( 100 | t "Type mismatch" %% ct (mich_node other) %% t "is not a pair.")) 101 | 102 | let fill_with_value mf node = fill_structure_with_value mf.structure node 103 | 104 | let peek m = 105 | let rec pk = function 106 | | Leaf l -> Reactive.peek l.v 107 | | Pair { left; right } -> Fmt.str "(Pair %s %s)" (pk left) (pk right) 108 | in 109 | pk m.structure 110 | 111 | let validate_micheline m = 112 | match 113 | Tezai_michelson.Concrete_syntax.parse_exn ~check_indentation:false 114 | ~check_primitives:true m 115 | with 116 | | (_ : Tezai_michelson.Untyped.t) -> true 117 | | exception _ -> false 118 | 119 | let rec validate_structure = function 120 | | Leaf { kind = Nat | Mutez; v; _ } -> 121 | Reactive.( 122 | get v 123 | |> map ~f:(function 124 | | "" -> false 125 | | s -> ( 126 | match Z.of_string s with _ -> true | exception _ -> false))) 127 | | Leaf { kind = Bytes; v; _ } -> 128 | Reactive.( 129 | get v 130 | |> map ~f:(function 131 | | "" -> false 132 | | s -> ( 133 | match String.chop_prefix (String.strip s) ~prefix:"0x" with 134 | | None -> false 135 | | Some s -> ( 136 | match Hex.to_string (`Hex s) with 137 | | _ -> true 138 | | exception _ -> false)))) 139 | | Leaf lf -> Reactive.(get lf.v |> map ~f:validate_micheline) 140 | | Pair { left; right } -> 141 | Reactive.( 142 | map2 ~f:( && ) (validate_structure left) (validate_structure right)) 143 | 144 | let is_valid pt = validate_structure pt.structure 145 | 146 | open Meta_html 147 | 148 | let validity_error = function 149 | | Nat -> t "Invalid natural number." 150 | | Mutez -> t "Invalid μꜩ value." 151 | | Bytes -> t "Invalid bytes value." 152 | | String -> t "Invalid string value." 153 | | Address -> t "Invalid address." 154 | | Bool -> t "Invalid boolean." 155 | | Any | List _ | Map _ -> t "Invalid Micheline syntax." 156 | 157 | let to_form_items mf = 158 | let open Meta_html in 159 | let open Bootstrap.Form in 160 | let type_expr m = 161 | Fmt.kstr ct "%s" 162 | Tezai_michelson.( 163 | Concrete_syntax.to_string (Untyped.of_canonical_micheline m)) 164 | (* micheline_canonical_to_string m) *) 165 | in 166 | let rec go = function 167 | | Pair { left; right } -> go left @ go right 168 | | Leaf leaf as leaf_structure -> 169 | [ 170 | input 171 | ~label: 172 | (match leaf.description with 173 | | None -> 174 | t "The parameter of type" %% type_expr leaf.raw % t "." 175 | | Some (an, s) -> 176 | t "The parameter called " % ct an %% t "of type" 177 | %% type_expr leaf.raw % t ":" %% it s) 178 | ~help: 179 | Reactive.( 180 | bind (validate_structure leaf_structure) ~f:(function 181 | | true -> Bootstrap.color `Success (t "OK") 182 | | false -> 183 | Bootstrap.color `Danger (validity_error leaf.kind))) 184 | ~placeholder:(Reactive.pure "Some decent Michelson right here") 185 | (Reactive.Bidirectional.of_var leaf.v); 186 | ] 187 | in 188 | go mf.structure 189 | 190 | let bytes_guesses input = 191 | try 192 | let raw, default_value = 193 | match input with 194 | | `Zero_x bytes -> 195 | let hex = String.chop_prefix_exn bytes ~prefix:"0x" in 196 | (Hex.to_string (`Hex hex), `Just_hex hex) 197 | | `Raw_string s -> 198 | let (`Hex hex) = Hex.of_string s in 199 | (s, `Just_hex hex) 200 | in 201 | let json () = `Json (Ezjsonm.value_from_string raw) in 202 | let utf8 () = 203 | let maxperline = 204 | let nl = Uchar.of_char '\n' in 205 | let folder (count, max_per_line) _ = function 206 | | `Uchar n when Uchar.equal n nl -> (0, max count max_per_line) 207 | | `Uchar _ -> (count + 1, max_per_line) 208 | | `Malformed _ -> Fmt.failwith "nop" 209 | in 210 | let c, m = Uutf.String.fold_utf_8 folder (0, 0) raw in 211 | max c m 212 | in 213 | let lines = 214 | match raw with "" -> [] | _ -> String.split ~on:'\n' raw 215 | in 216 | `Valid_utf_8 (maxperline, lines) 217 | in 218 | let bool () = `Bool (Bool.of_string raw) in 219 | let number () = `Number (Float.of_string raw) in 220 | let one_line_not_weird () = 221 | String.for_all raw ~f:(function '\n' | '\t' -> false | _ -> true) 222 | in 223 | let any_prefix l = 224 | List.exists l ~f:(fun prefix -> String.is_prefix raw ~prefix) 225 | in 226 | let web_uri () = 227 | if 228 | any_prefix [ "https://"; "http://"; "ftp://" ] 229 | && one_line_not_weird () 230 | then `Web_uri raw 231 | else failwith "not web uri :)" 232 | in 233 | let tzip16_uri () = 234 | if 235 | any_prefix [ "tezos-storage://"; "ipfs://"; "sha256://" ] 236 | && one_line_not_weird () 237 | then `Tzip16_uri raw 238 | else failwith "not tzip16 uri :)" 239 | in 240 | match 241 | List.find_map [ bool; number; web_uri; tzip16_uri; json; utf8 ] 242 | ~f:(fun f -> try Some (f ()) with _ -> None) 243 | with 244 | | Some s -> s 245 | | None -> default_value 246 | with _ -> `Dont_know 247 | 248 | let micheline_string_bytes_map_exn node = 249 | let open Tezos_micheline.Micheline in 250 | let nope = Decorate_error.raise in 251 | match node with 252 | | Seq (l, map) -> ( 253 | match map with 254 | | [] -> [] 255 | | Prim (_, "Elt", [ String (_, s); Bytes (_, b) ], _) :: more -> 256 | List.fold more 257 | ~init:[ (s, Bytes.to_string b) ] 258 | ~f: 259 | (fun prev -> function 260 | | Prim (_, "Elt", [ String (_, s); Bytes (_, b) ], _) -> 261 | (s, Bytes.to_string b) :: prev 262 | | other -> 263 | nope 264 | Message.( 265 | t "Michelson-map element has wrong structure:" 266 | %% ct (micheline_node_to_string other))) 267 | | other -> 268 | nope 269 | Message.( 270 | t "Metadata result has wrong structure:" 271 | %% ct (micheline_node_to_string (Seq (l, other))))) 272 | | other -> 273 | nope 274 | Message.( 275 | t "Expecting Michelson-map but got" 276 | %% ct (micheline_node_to_string other)) 277 | 278 | let desc ?(default = empty ()) description = 279 | Option.value_map description ~default ~f:(fun (k, v) -> 280 | t ":" %% it v %% parens (ct k)) 281 | 282 | let show_bytes_result ~tzip16_uri ?description content = 283 | let show_content name f = 284 | let collapse = Bootstrap.Collapse.make () in 285 | Bootstrap.Collapse.fixed_width_reactive_button_with_div_below collapse 286 | ~width:"12em" ~kind:`Secondary 287 | ~button:(function 288 | | true -> t "Show" %% t name | false -> t "Hide" %% t name) 289 | f 290 | in 291 | let utf8_line_threshold = 78 in 292 | let show_summary = function 293 | | `Zero_x content -> 294 | ct (content |> bytes_summary ~threshold:30 ~left:15 ~right:15) 295 | | `Raw_string content -> 296 | let (`Hex hex) = Hex.of_string content in 297 | ct ("0x" ^ hex |> bytes_summary ~threshold:24 ~left:10 ~right:10) 298 | in 299 | [ 300 | (show_summary content % desc description 301 | %% 302 | match bytes_guesses content with 303 | | `Just_hex hex -> 304 | show_content "Hex Dump" (fun () -> 305 | pre (ct (Hex.hexdump_s (`Hex hex)))) 306 | | `Number f -> 307 | t "→ The number" 308 | %% it (Float.to_string_hum ~delimiter:' ' ~strip_zero:true f) 309 | | `Bool b -> t "→ The boolean" %% it (Bool.to_string b) 310 | | `Web_uri wuri -> t "→" %% url it wuri 311 | | `Tzip16_uri wuri -> t "→" %% tzip16_uri wuri 312 | | `Json v -> 313 | t "→" 314 | %% Bootstrap.color `Success (t "It is valid JSON!") 315 | %% show_content "Indented JSON" (fun () -> 316 | pre (ct (Ezjsonm.value_to_string ~minify:false v))) 317 | | `Valid_utf_8 (maxperline, [ one ]) 318 | when maxperline <= utf8_line_threshold -> 319 | t "→" %% t one %% parens (Bootstrap.color `Success (t "Valid UTF-8")) 320 | | `Valid_utf_8 (maxperline, lines) -> 321 | t "→" 322 | %% Bootstrap.color `Success 323 | (let lnnb = List.length lines in 324 | match lnnb with 325 | | 0 -> t "It's just empty." 326 | | _ -> 327 | Fmt.kstr t 328 | "It is valid UTF-8 text, %d line%s %d characters!" lnnb 329 | (if lnnb <> 1 then "s, each ≤" else ",") 330 | maxperline) 331 | %% 332 | if maxperline = 0 then empty () 333 | else 334 | show_content "Text" (fun () -> 335 | div 336 | (let sep () = H5.br () in 337 | List.fold lines ~init:(empty ()) ~f:(fun p l -> 338 | p % sep () % t l))) 339 | | `Dont_know -> parens (t "Can't identify")); 340 | ] 341 | 342 | let render ~tzip16_uri mf = 343 | let default content description_opt = 344 | [ ct content % desc description_opt ] 345 | in 346 | let rec structure = function 347 | | Leaf ({ kind = Bytes; _ } as leaf) -> 348 | let content = Reactive.peek leaf.v in 349 | show_bytes_result ~tzip16_uri (`Zero_x content) 350 | ?description:leaf.description 351 | | Leaf { kind = Map (String, Bytes); v; description; _ } -> ( 352 | let content = Reactive.peek v in 353 | match 354 | Tezai_michelson.Concrete_syntax.parse_exn ~check_primitives:false 355 | ~check_indentation:false content 356 | with 357 | | node -> ( 358 | try 359 | let map = micheline_string_bytes_map_exn node in 360 | [ 361 | t "Map" 362 | %% parens (ct "string → bytes") 363 | % desc description % t ":" 364 | % itemize 365 | (List.map map ~f:(fun (k, v) -> 366 | Fmt.kstr ct "%S" k %% t "→" 367 | % list 368 | (show_bytes_result ~tzip16_uri (`Raw_string v)))); 369 | ] 370 | with _ -> default content description) 371 | | exception _ -> default content description) 372 | | Leaf leaf -> default (Reactive.peek leaf.v) leaf.description 373 | | Pair { left; right } -> structure left @ structure right 374 | in 375 | structure mf.structure 376 | end 377 | -------------------------------------------------------------------------------- /src/client/import.ml: -------------------------------------------------------------------------------- 1 | include Base 2 | 3 | let dbg fmt = Fmt.pf Fmt.stdout "@[tzcomet-debug: %a@]%!" fmt () 4 | let dbgf fmt = Fmt.(kstr (fun s -> dbg (const string s))) fmt 5 | 6 | let rec oxfordize_list l ~map ~sep ~last_sep = 7 | match l with 8 | | [] -> [] 9 | | [ one ] -> [ map one ] 10 | | [ one; two ] -> [ map one; last_sep (); map two ] 11 | | one :: more -> map one :: sep () :: oxfordize_list more ~map ~sep ~last_sep 12 | 13 | let ellipsize_string ?(ellipsis = " …") s ~max_length = 14 | if String.length s <= max_length then s 15 | else String.prefix s max_length ^ ellipsis 16 | 17 | let bytes_summary ?(threshold = 25) ?(left = 10) ?(right = 10) bytes = 18 | match String.length bytes with 19 | | m when m < threshold -> bytes 20 | | m -> 21 | Fmt.str "%s…%s" 22 | (String.sub bytes ~pos:0 ~len:left) 23 | (String.sub bytes ~pos:(m - right) ~len:right) 24 | 25 | module Context = struct 26 | type 'a t = 'a constraint 'a = < .. > 27 | end 28 | 29 | module Reactive = Lwd_bootstrap.Reactive 30 | 31 | module Message = struct 32 | type t = 33 | | Text of string 34 | | Inline_code of string 35 | | Code_block of string 36 | | List of t list 37 | 38 | let t s = Text s 39 | let int f i : t = f (Int.to_string_hum ~delimiter:'_' i) 40 | let kpp f pp x : t = Fmt.kstr f "%a" pp x 41 | let ct s = Inline_code s 42 | let code_block s = Code_block s 43 | let list l = List l 44 | let ( % ) a b = List [ a; b ] 45 | let ( %% ) a b = List [ a; t " "; b ] 46 | let parens tt = list [ t "("; tt; t ")" ] 47 | 48 | let rec pp ppf = 49 | let open Fmt in 50 | function 51 | | Text s -> pf ppf "%s" s 52 | | Inline_code s -> pf ppf "`%s`" s 53 | | Code_block s -> pf ppf "@.```@.%s@.```@." s 54 | | List l -> List.iter l ~f:(pp ppf) 55 | end 56 | 57 | module Decorate_error = struct 58 | exception E of { message : Message.t; trace : exn list } 59 | 60 | let raise ?(trace = []) message = raise (E { message; trace }) 61 | let reraise message ~f = Lwt.catch f (fun e -> raise message ~trace:[ e ]) 62 | 63 | let () = 64 | Caml.Printexc.register_printer (function 65 | | E { message; _ } -> 66 | Some (Fmt.str "Decorated-Error %a" Message.pp message) 67 | | _ -> None) 68 | end 69 | 70 | module System = struct 71 | type t = { dev_mode : bool Reactive.var; http_timeout : float Reactive.var } 72 | 73 | let create ?(dev_mode = false) () = 74 | { dev_mode = Reactive.var dev_mode; http_timeout = Reactive.var 5. } 75 | 76 | let get (state : < system : t ; .. > Context.t) = state#system 77 | 78 | let set_dev_mode c v = 79 | dbgf "system: setting dev_mode to %b" v; 80 | Reactive.set (get c).dev_mode v 81 | 82 | let dev_mode c = Reactive.get (get c).dev_mode 83 | 84 | let dev_mode_bidirectional state = 85 | (get state).dev_mode |> Reactive.Bidirectional.of_var 86 | 87 | let if_dev c f = if Reactive.peek (get c).dev_mode then f () else () 88 | let set_http_timeout c v = Reactive.set (get c).http_timeout v 89 | let http_timeout c = Reactive.get (get c).http_timeout 90 | let http_timeout_peek c = Reactive.peek (get c).http_timeout 91 | 92 | let http_timeout_bidirectional c = 93 | Reactive.Bidirectional.of_var (get c).http_timeout 94 | 95 | let slow_step ctxt = 96 | if Reactive.peek (get ctxt).dev_mode then Js_of_ocaml_lwt.Lwt_js.sleep 0.5 97 | else Lwt.return () 98 | 99 | let with_timeout ctxt ~f ~raise = 100 | let open Lwt.Infix in 101 | let timeout = http_timeout_peek ctxt in 102 | Lwt.pick 103 | [ 104 | f (); (Js_of_ocaml_lwt.Lwt_js.sleep timeout >>= fun () -> raise timeout); 105 | ] 106 | 107 | let now () = (new%js Js_of_ocaml.Js.date_now)##valueOf /. 1000. 108 | let time_zero = now () 109 | let program_time () = now () -. time_zero 110 | end 111 | 112 | module Browser_window = struct 113 | type width_state = [ `Thin | `Wide ] 114 | type t = { width : width_state option Reactive.var } 115 | 116 | open Js_of_ocaml 117 | 118 | let create ?(threshold = 992) () = 119 | let find_out () = 120 | let w = Dom_html.window##.innerWidth in 121 | if w >= threshold then Some `Wide else Some `Thin 122 | in 123 | let width = Reactive.var (find_out ()) in 124 | Dom_html.window##.onresize := 125 | Dom_html.handler (fun _ -> 126 | let current = Reactive.peek width in 127 | let new_one = find_out () in 128 | if Poly.(current <> new_one) then Reactive.set width new_one; 129 | Js._true); 130 | { width } 131 | 132 | let get (c : < window : t ; .. > Context.t) = c#window 133 | let width c = (get c).width |> Reactive.get 134 | end 135 | 136 | module Local_storage : sig 137 | type t 138 | 139 | val create : unit -> t 140 | val get : < storage : t ; .. > Context.t -> t 141 | val available : < storage : t ; .. > Context.t -> bool 142 | val read_file : < storage : t ; .. > Context.t -> string -> string option 143 | 144 | val write_file : 145 | < storage : t ; .. > Context.t -> string -> content:string -> unit 146 | 147 | val remove_file : < storage : t ; .. > Context.t -> string -> unit 148 | end = struct 149 | open Js_of_ocaml 150 | 151 | type t = Js_of_ocaml.Dom_html.storage Js_of_ocaml.Js.t option 152 | 153 | let create () : t = 154 | Js.Optdef.case 155 | Dom_html.window##.localStorage 156 | (fun () -> 157 | dbgf "Local_storage: nope"; 158 | None) 159 | (fun x -> 160 | dbgf "Local_storage: YES length: %d" x##.length; 161 | Some x) 162 | 163 | let get (c : < storage : t ; .. > Context.t) = c#storage 164 | let available c = get c |> Option.is_some 165 | 166 | let read_file ctxt path = 167 | get ctxt 168 | |> Option.bind ~f:(fun sto -> 169 | Js.Opt.to_option (sto##getItem (Js.string path)) 170 | |> Option.map ~f:Js.to_string) 171 | 172 | let write_file ctxt path ~content = 173 | get ctxt 174 | |> Option.iter ~f:(fun sto -> 175 | sto##setItem (Js.string path) (Js.string content)) 176 | 177 | let remove_file ctxt path = 178 | get ctxt |> Option.iter ~f:(fun sto -> sto##removeItem (Js.string path)) 179 | end 180 | 181 | module Ezjsonm = struct 182 | include Ezjsonm 183 | 184 | module Stack_reimplementation = struct 185 | exception Escape of ((int * int) * (int * int)) * Tzcomet_jsonm.error 186 | 187 | let json_of_src src = 188 | let d = Tzcomet_jsonm.decoder src in 189 | let dec () = 190 | match Tzcomet_jsonm.decode d with 191 | | `Lexeme l -> l 192 | | `Error e -> raise (Escape (Tzcomet_jsonm.decoded_range d, e)) 193 | | `End | `Await -> assert false 194 | in 195 | let pp_value ppf v = Fmt.pf ppf "%s" (Ezjsonm.value_to_string v) in 196 | let module Stack_type = struct 197 | type t = 198 | [ `A of Ezjsonm.value List.t 199 | | `Bool of bool 200 | | `Float of float 201 | | `In_array of Ezjsonm.value list 202 | | `In_object of string option * (string * Ezjsonm.value) list 203 | | `Null 204 | | `O of (string * Ezjsonm.value) list 205 | | `String of string ] 206 | end in 207 | let pp_stack = 208 | let open Fmt in 209 | list ~sep:(any " :: ") (fun ppf -> function 210 | | `In_object (m, l) -> 211 | pf ppf "(in-obj %a %a)" (Dump.option string) m 212 | (list (pair ~sep:(any ":") string pp_value)) 213 | l 214 | | `In_array l -> pf ppf "(in-array %a)" (list pp_value) l 215 | | #Ezjsonm.value as v -> pp_value ppf v) 216 | in 217 | let stack = ref [] in 218 | let fail_stack fmt = 219 | Fmt.kstr 220 | (fun m -> 221 | let (a, b), (c, d) = Tzcomet_jsonm.decoded_range d in 222 | Fmt.failwith "%s [%d,%d - %d,%d stack: %a]" m a b c d pp_stack 223 | !stack) 224 | fmt 225 | in 226 | let rec go () = 227 | let stack_value (v : [< Ezjsonm.value ]) = 228 | match !stack with 229 | | `In_array l :: more -> stack := `In_array (v :: l) :: more 230 | | `In_object (Some n, l) :: more -> 231 | stack := `In_object (None, (n, v) :: l) :: more 232 | | [] -> stack := [ (v :> Stack_type.t) ] 233 | | _other -> fail_stack "wrong stack" 234 | in 235 | let pop () = 236 | match !stack with 237 | | _ :: more -> stack := more 238 | | [] -> fail_stack "cannot remove element from stack" 239 | in 240 | (match dec () with 241 | | `Os -> stack := `In_object (None, []) :: !stack 242 | | `Oe -> ( 243 | match !stack with 244 | | `In_object (Some _, _) :: _more -> fail_stack "name not none" 245 | | `In_object (None, l) :: _more -> 246 | pop (); 247 | stack_value (`O (List.rev l)) 248 | | _other -> 249 | fail_stack "wrong stack, expecting in-object to close object") 250 | | `As -> stack := `In_array [] :: !stack 251 | | `Ae -> ( 252 | match !stack with 253 | | `In_array l :: _more -> 254 | pop (); 255 | stack_value (`A (List.rev l)) 256 | | _ -> fail_stack "array end not in array") 257 | | `Name n -> ( 258 | match !stack with 259 | | `In_object (None, l) :: more -> 260 | stack := `In_object (Some n, l) :: more 261 | | _other -> 262 | fail_stack "wrong stack, expecting in-object for field-name") 263 | | (`Bool _ | `Null | `Float _ | `String _) as v -> stack_value v); 264 | match !stack with 265 | | `In_array _ :: _ | `In_object _ :: _ -> go () 266 | | [ (#Ezjsonm.value as one) ] -> one 267 | | [] -> fail_stack "stack is empty" 268 | | _ :: _ :: _ -> go () 269 | in 270 | try `JSON (go ()) with Escape (r, e) -> `Error (r, e) 271 | 272 | let value_to_dst ?(minify = true) dst json = 273 | let encoder = Tzcomet_jsonm.encoder ~minify dst in 274 | let encode l = ignore (Tzcomet_jsonm.encode encoder (`Lexeme l)) in 275 | let rec go = function 276 | | [] -> () 277 | | `Value ((`Bool _ | `Null | `Float _ | `String _) as v) :: more -> 278 | encode v; 279 | go more 280 | | `Value (`O l) :: more -> 281 | encode `Os; 282 | go (`Object l :: more) 283 | | `Value (`A l) :: more -> 284 | encode `As; 285 | go (`Array l :: more) 286 | | `Object [] :: more -> 287 | encode `Oe; 288 | go more 289 | | `Object ((k, v) :: o) :: more -> 290 | encode (`Name k); 291 | go (`Value v :: `Object o :: more) 292 | | `Array [] :: more -> 293 | encode `Ae; 294 | go more 295 | | `Array (v :: aa) :: more -> go (`Value v :: `Array aa :: more) 296 | in 297 | go [ `Value json ]; 298 | ignore (Tzcomet_jsonm.encode encoder `End) 299 | end 300 | 301 | open Stack_reimplementation 302 | 303 | let value_to_buffer ?minify buf json = value_to_dst ?minify (`Buffer buf) json 304 | 305 | let value_to_string ?minify json = 306 | let buf = Buffer.create 1024 in 307 | value_to_buffer ?minify buf json; 308 | Buffer.contents buf 309 | 310 | let value_from_string s = 311 | match json_of_src (`String s) with 312 | | `JSON j -> j 313 | | `Error (((line, col), (eline, ecol)), err) -> 314 | dbgf "Error l-%d c-%d -- l-%d c-%d" line col eline ecol; 315 | Decorate_error.raise 316 | Message.( 317 | (* Adapted from 318 | https://github.com/dbuenzli/jsonm/blob/master/src/jsonm.ml *) 319 | let control_char u = Fmt.kstr ct "U+%04X" u in 320 | let uchar u = 321 | let module Uchar = Caml.Uchar in 322 | if Uchar.to_int u <= 0x1F (* most control chars *) then 323 | control_char (Uchar.to_int u) 324 | else 325 | let b = Buffer.create 4 in 326 | Uutf.Buffer.add_utf_8 b u; 327 | Fmt.kstr t "“%s” (=" (Buffer.contents b) 328 | %% control_char (Uchar.to_int u) 329 | % t ")" 330 | in 331 | let err_message = 332 | let pp = Fmt.kstr in 333 | let ppf = t in 334 | match err with 335 | | `Illegal_BOM -> 336 | pp ppf 337 | "Illegal initial Byte-Order-Mark (BOM) in character stream." 338 | | `Illegal_escape r -> ( 339 | pp ppf "Illegal escape:" 340 | %% 341 | match r with 342 | | `Not_hex_uchar u -> uchar u %% t "is not a hex-digit" 343 | | `Not_esc_uchar u -> 344 | uchar u %% t "is not an escape character" 345 | | `Lone_lo_surrogate p -> 346 | control_char p %% t "lone low surrogate" 347 | | `Lone_hi_surrogate p -> 348 | control_char p %% t "lone high surrogate" 349 | | `Not_lo_surrogate p -> 350 | control_char p %% t "not a low surrogate") 351 | | `Illegal_string_uchar u -> 352 | t "Illegal character in JSON string:" %% uchar u 353 | | `Illegal_bytes bs -> 354 | let l = String.length bs in 355 | let (`Hex hx) = Hex.of_string bs in 356 | t "Illegal bytes in character stream (" 357 | % Fmt.kstr ct "0x%s" hx % t ", length:" %% int ct l % t ")" 358 | | `Illegal_number n -> t "Illegal number:" %% ct n 359 | | `Illegal_literal l -> t "Illegal literal:" %% ct l 360 | | `Unclosed r -> ( 361 | t "Unclosed" 362 | %% 363 | match r with 364 | | `As -> t "array" 365 | | `Os -> t "object" 366 | | `String -> t "string" 367 | | `Comment -> t "comment") 368 | | `Expected r -> ( 369 | let value_sep = t "value separator" %% parens (ct ",") in 370 | let tor = t "or" in 371 | let array_end = t "end of array" %% parens (ct "]") in 372 | let object_end = t "end of object" %% parens (ct "}") in 373 | let field_name = t "field name" %% parens (ct "\"…\"") in 374 | t "Expected " 375 | %% 376 | match r with 377 | | `Comment -> t "JavaScript comment" 378 | | `Value -> t "JSON value" 379 | | `Name -> field_name 380 | | `Name_sep -> t "field-name separator" %% parens (ct ":") 381 | | `Aval true -> t "JSON-value" %% tor %% array_end 382 | | `Aval false -> value_sep %% tor %% array_end 383 | | `Omem true -> field_name %% tor %% object_end 384 | | `Omem false -> value_sep %% tor %% object_end 385 | | `Json -> t "JSON value" 386 | | `Eoi -> t "end of input") 387 | in 388 | t "JSON Parsing: at line" %% int ct line %% t ", column" 389 | %% int ct col % t ":" %% err_message % t ".") 390 | | exception e -> Fmt.failwith "JSON Parising error: exception %a" Exn.pp e 391 | end 392 | 393 | module Blob = struct 394 | module Format = struct 395 | type t = [ `Image | `Video | `Appx | `Html ] * string 396 | 397 | let gif = (`Image, "gif") 398 | let jpeg = (`Image, "jpeg") 399 | let png = (`Image, "png") 400 | let mp4 = (`Video, "mp4") 401 | let appx = (`Appx, "x-directory") 402 | 403 | let of_mime_exn = function 404 | | image when String.is_prefix image ~prefix:"image/" -> 405 | (`Image, String.chop_prefix_exn image ~prefix:"image/") 406 | | vid when String.is_prefix vid ~prefix:"video/" -> 407 | (`Video, String.chop_prefix_exn vid ~prefix:"video/") 408 | | app_x when String.equal app_x "application/x-directory" -> 409 | (`Appx, String.chop_prefix_exn app_x ~prefix:"application/") 410 | | html when String.equal html "text/html" -> 411 | (`Html, String.chop_prefix_exn html ~prefix:"text/") 412 | | other -> Fmt.failwith "Unknown MIME type: %S" other 413 | 414 | let to_mime = function 415 | | `Image, f -> "image/" ^ f 416 | | `Video, f -> "video/" ^ f 417 | | `Appx, f -> "application/" ^ f 418 | | `Html, f -> "text/" ^ f 419 | end 420 | 421 | let guess_format s : Format.t option = 422 | (* https://stackoverflow.com/questions/55869/determine-file-type-of-an-image 423 | https://en.wikipedia.org/wiki/JPEG *) 424 | let open Format in 425 | let prefixes = 426 | [ 427 | ("\255\216\255", jpeg); 428 | ("\137\080\078\071", png); 429 | ("GIF", gif); 430 | ("\x00\x00\x00\x20ftypmp42", mp4); 431 | ] 432 | in 433 | List.find_map prefixes ~f:(fun (prefix, fmt) -> 434 | if String.is_prefix s ~prefix then Some fmt else None) 435 | end 436 | -------------------------------------------------------------------------------- /src/deploy-examples/main.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | let dbgf fmt = Fmt.kstr (fun s -> Fmt.epr "deploy-examples: %s\n%!" s) fmt 4 | 5 | module Env = struct 6 | let with_default v default = 7 | match Caml.Sys.getenv_opt v with None -> default | Some v -> v 8 | 9 | let or_fail v = 10 | try Caml.Sys.getenv v 11 | with _ -> Fmt.failwith "Missing required environment variable %S" v 12 | 13 | let tezos_client () = with_default "tezos_client_bin" "octez-client" 14 | let funder () = or_fail "funder_account" 15 | end 16 | 17 | module System = struct 18 | let cmd s = 19 | match Caml.Sys.command s with 20 | | 0 -> () 21 | | n -> Fmt.failwith "Command %S returned %d" s n 22 | 23 | let escape = Caml.Filename.quote 24 | let exec l = cmd (String.concat ~sep:" " (List.map l ~f:escape)) 25 | 26 | let exec_and_redirect_stdout ~stdout l = 27 | Fmt.kstr cmd "%s >> %s" 28 | (String.concat ~sep:" " (List.map l ~f:escape)) 29 | (escape stdout) 30 | 31 | let append_to_file ~file s = 32 | Fmt.kstr cmd "printf '%%s' %s >> %s" (escape s) (escape file) 33 | 34 | let read_lines p = 35 | let open Caml in 36 | let o = open_in p in 37 | let r = ref [] in 38 | try 39 | while true do 40 | r := input_line o :: !r 41 | done; 42 | assert false 43 | with _ -> 44 | close_in o; 45 | List.rev !r 46 | 47 | let cmd_to_string_list cmd = 48 | let open Caml in 49 | let i = 50 | Unix.open_process_in (String.concat " " (List.map Filename.quote cmd)) 51 | in 52 | let rec loop acc = 53 | try loop (input_line i :: acc) with _ -> List.rev acc 54 | in 55 | let res = loop [] in 56 | let status = Unix.close_process_in i in 57 | match status with 58 | | Unix.WEXITED 0 -> res 59 | | _ -> 60 | Fmt.failwith "Command %a returned non-zero" Fmt.Dump.(list string) cmd 61 | end 62 | 63 | let tezos_client args = Env.tezos_client () :: args 64 | 65 | let originate ?(balance = 0) ?(description = "") ~source ~init ~name ~logfile () 66 | = 67 | let cmd = 68 | tezos_client 69 | [ 70 | "--wait"; 71 | "0"; 72 | "originate"; 73 | "contract"; 74 | name; 75 | "transferring"; 76 | Int.to_string balance; 77 | "from"; 78 | Env.funder (); 79 | "running"; 80 | source; 81 | "--burn-cap"; 82 | "100"; 83 | "--init"; 84 | init; 85 | "--force"; 86 | ] 87 | in 88 | System.exec cmd; 89 | System.append_to_file ~file:logfile (Fmt.str "## Contract `%s`\n\n" name); 90 | System.append_to_file ~file:logfile (Fmt.str "- Init: `%s`\n- Address: " init); 91 | System.exec_and_redirect_stdout ~stdout:logfile 92 | (tezos_client [ "show"; "known"; "contract"; name ]); 93 | System.append_to_file ~file:logfile (Fmt.str "\n%s\n\n" description); 94 | System.cmd_to_string_list (tezos_client [ "show"; "known"; "contract"; name ]) 95 | |> String.concat ~sep:"" 96 | 97 | let contract () = 98 | {tz| 99 | parameter unit; 100 | storage (pair nat (big_map %metadata string bytes)); 101 | code { PUSH nat 42; FAILWITH; }; 102 | |tz} 103 | 104 | module Micheline_views = struct 105 | open Ezjsonm 106 | 107 | let prim ?(annotations = []) p l = 108 | dict [ ("prim", string p); ("args", `A l); ("annots", strings annotations) ] 109 | 110 | let int i = dict [ ("int", string (Int.to_string i)) ] 111 | let michstring s = dict [ ("string", string s) ] 112 | 113 | let michbytes b = 114 | let (`Hex hex) = Hex.of_string b in 115 | dict [ ("bytes", string hex) ] 116 | 117 | let seq l = list Fn.id l 118 | let nat = prim "nat" [] 119 | let mutez = prim "mutez" [] 120 | let timestamp = prim "timestamp" [] 121 | let prims = List.map ~f:(fun p -> prim p []) 122 | let or_empty opt f = Option.value_map opt ~default:[] ~f 123 | 124 | let view ?description ?pure name implementations = 125 | dict 126 | (or_empty pure (fun b -> [ ("pure", bool b) ]) 127 | @ [ ("name", string name) ] 128 | @ or_empty description (fun d -> [ ("description", string d) ]) 129 | @ [ ("implementations", `A implementations) ]) 130 | 131 | let storage_view_implementation ?version ?parameter ?(return_type = nat) 132 | ?(annotations = []) code = 133 | dict 134 | [ 135 | ( "michelsonStorageView", 136 | dict 137 | (Option.value_map parameter ~default:[] ~f:(fun p -> 138 | [ ("parameter", p) ]) 139 | @ [ ("returnType", return_type); ("code", `A code) ] 140 | @ (match annotations with 141 | | [] -> [] 142 | | more -> 143 | [ 144 | ( "annotations", 145 | list 146 | (fun (k, v) -> 147 | dict [ ("name", string k); ("description", string v) ]) 148 | more ); 149 | ]) 150 | @ 151 | match version with 152 | | None -> [] 153 | | Some s -> [ ("version", string s) ]) ); 154 | ] 155 | 156 | let view_with_code ?description ?pure ?version ?parameter ?return_type 157 | ?(annotations = []) name code = 158 | view ?description ?pure name 159 | [ 160 | storage_view_implementation ?version ?parameter ?return_type 161 | ~annotations code; 162 | ] 163 | end 164 | 165 | let all ?(dry_run = false) ?(print = true) ?only ~logfile () = 166 | let originated = ref [] in 167 | let add name description kt1 = 168 | originated := (name, description, kt1) :: !originated 169 | in 170 | let originate ~description ~logfile ~name ~source ~init () = 171 | match only with 172 | | Some l when not (List.mem l name ~equal:String.equal) -> () 173 | | None | Some _ -> 174 | let kt1 = 175 | match dry_run with 176 | | false -> ( 177 | try originate ~description ~logfile ~name ~source ~init () 178 | with e -> 179 | dbgf "Origination of %s failed: %a" name Exn.pp e; 180 | Fmt.str "KT1Failedooooo%03d" (List.length !originated)) 181 | | true -> 182 | dbgf "DRY-RUN: origination of %s" name; 183 | Fmt.str "KT1FakeFakeooo%03d" (List.length !originated) 184 | in 185 | add name description kt1 186 | in 187 | let simple name description ?(the_nat = 7) bm = 188 | let source = contract () in 189 | let to_hex s = 190 | Fmt.str "0x%s" 191 | (let (`Hex x) = Hex.of_string s in 192 | x) 193 | in 194 | let init = 195 | Fmt.str "(Pair %d {%s})" the_nat 196 | (String.concat ~sep:" ; " 197 | (List.map bm ~f:(fun (k, v) -> Fmt.str "Elt %S %s" k (to_hex v)))) 198 | in 199 | originate ~description ~logfile ~name ~source ~init () 200 | in 201 | let root uri = ("", uri) in 202 | let self_host name description json = 203 | simple name description 204 | (* (Fmt.str "Self-hosted JSON.\n\n%s\n\n```json\n%s\n```\n\n" description 205 | (Ezjsonm.value_to_string ~minify:false json)) *) 206 | [ 207 | root "tezos-storage:contents"; ("contents", Ezjsonm.value_to_string json); 208 | ] 209 | in 210 | let self_describe name description more_fields = 211 | self_host name description 212 | Ezjsonm.( 213 | dict 214 | ([ 215 | ("description", string description); 216 | ("version", string "tzcomet-example v0.0.42"); 217 | ] 218 | @ more_fields)) 219 | in 220 | let open Micheline_views in 221 | let basics = 222 | Ezjsonm. 223 | [ 224 | ( "license", 225 | dict [ ("name", string "MIT"); ("details", string "The MIT License") ] 226 | ); 227 | ("homepage", string "https://github.com/oxheadalpha/TZComet"); 228 | ( "source", 229 | dict 230 | [ 231 | ("tools", list string [ "TZComet"; "deploy-examples/main.exe" ]); 232 | ( "location", 233 | string 234 | "https://github.com/oxheadalpha/TZComet/blob/48fed5db6bd367cae0e7a5ef3ec415e6cf76b30b/src/deploy-examples/main.ml#L147" 235 | ); 236 | ] ); 237 | ( "errors", 238 | list Fn.id 239 | [ 240 | dict 241 | [ 242 | ("error", dict [ ("int", string "42") ]); 243 | ("expansion", dict [ ("string", string "Hello I'm error 42") ]); 244 | ]; 245 | dict 246 | [ 247 | ("error", dict [ ("int", string "42") ]); 248 | ( "expansion", 249 | dict 250 | [ 251 | ( "bytes", 252 | string 253 | "7175656c7175652063686f7365206e276120706173206d61726368c3a9" 254 | ); 255 | ] ); 256 | ("languages", strings [ "fr" ]); 257 | ]; 258 | dict [ ("view", string "does-not-exist") ]; 259 | dict 260 | [ 261 | ("view", string "multiply-the-nat-in-storage"); 262 | ("languages", strings []); 263 | ]; 264 | ] ); 265 | ] 266 | in 267 | let empty_view_01 = 268 | view 269 | ~description: 270 | "This view has no implementations …\n\nWhich is indeed useless." 271 | "an-empty-useless-view" [] 272 | in 273 | let view_with_too_much_code = 274 | view 275 | ~description: 276 | "This view has a bunch of implementations …\n\n\ 277 | They are all meaningless." "an-empty-useless-view" 278 | [ 279 | storage_view_implementation ~return_type:nat 280 | (prims [ "DUP"; "DUP"; "DUP"; "DUP"; "DUP"; "DUP"; "PAIR" ] 281 | @ [ prim "DIP" (prims (List.init 50 ~f:(Fn.const "PAIR"))) ]); 282 | storage_view_implementation ~return_type:nat 283 | (prims [ "DUP"; "DUP"; "DUP"; "DUP"; "DUP"; "DUP"; "PAIR" ] 284 | @ [ 285 | prim "DIP" 286 | (prims (List.init 50 ~f:(Fn.const "PAIR")) 287 | @ [ prim "DIP" (prims (List.init 50 ~f:(Fn.const "PAIR"))) ]); 288 | ]); 289 | ] 290 | in 291 | let failwith_01 = 292 | view_with_code 293 | ~return_type:(prim "int" ~annotations:[ "%negative_even_number" ] []) 294 | ~parameter:(prim "int" ~annotations:[ "%the_decisive_argument" ] []) 295 | "multiply-negative-number-or-call-failwith" 296 | ~annotations: 297 | [ 298 | ( "%the_decisive_argument", 299 | "The integer argument if >0 this will fail." ); 300 | ( "%negative_even_number", 301 | "The result, if any, is twice the argument \ 302 | (%the_decisive_argument)." ); 303 | ] 304 | [ 305 | prim "CAR" []; 306 | prim "DUP" []; 307 | prim "PUSH" [ prim "int" []; int 0 ]; 308 | prim "COMPARE" []; 309 | prim "LT" []; 310 | prim "IF" 311 | [ 312 | seq [ prim "FAILWITH" [] ]; 313 | seq [ prim "PUSH" [ prim "int" []; int 2 ]; prim "MUL" [] ]; 314 | ]; 315 | ] 316 | in 317 | let identity_01 = 318 | let big_type ann2 = 319 | prim "pair" 320 | [ 321 | prim "nat" ~annotations:[ "%arg_zero" ] []; 322 | prim "pair" 323 | [ 324 | prim "string" ~annotations:[ ann2 ] []; 325 | prim "mutez" ~annotations:[ "%arg_two" ] []; 326 | ]; 327 | ] 328 | in 329 | let parameter = big_type "%arg_one" in 330 | let return_type = big_type "%arg_one_result" in 331 | view_with_code ~parameter "the-identity" ~return_type 332 | ~annotations: 333 | [ 334 | ("%arg_zero", "This is obvioulsy ignored."); 335 | ("%arg_one", "This is also ignored, but different."); 336 | ("%arg_one_result", "This is %arg_one on the resulting side."); 337 | ( "%arg_two", 338 | "This is also ignored, but with a lot of data\n\n\ 339 | Lorem ipsuming and all." ); 340 | ] 341 | [ prim "CAR" [] ] 342 | in 343 | let multiply_the_nat = 344 | (* let code = prims ["CAR"; "SELF"; "CAR"; "MUL"] in *) 345 | let code = prims [ "DUP"; "CDR"; "CAR"; "SWAP"; "CAR"; "MUL" ] in 346 | view_with_code ~pure:true ~parameter:nat "multiply-the-nat-in-storage" code 347 | ~description: 348 | "This one is pure, it multiplies the natural number given as argument \ 349 | with the one in storage." 350 | in 351 | let call_balance = 352 | let code = prims [ "DROP"; "BALANCE" ] in 353 | view_with_code ~return_type:mutez "just-call-balance" code 354 | in 355 | let call_self_address = 356 | let code = prims [ "DROP"; "SELF"; "ADDRESS" ] in 357 | view_with_code "get-contract-address" code 358 | ~return_type:(prim "address" [] ~annotations:[ "%ret" ]) 359 | ~annotations: 360 | [ 361 | ( "%ret", 362 | "The address of the (any) contract, re-obtained in Michelson." ); 363 | ] 364 | in 365 | let unit_to_bytes name value = 366 | let code = 367 | [ prim "DROP" []; prim "PUSH" [ prim "bytes" []; michbytes value ] ] 368 | in 369 | view_with_code name code 370 | ~return_type:(prim "bytes" [] ~annotations:[ "%returnedBytes" ]) 371 | ~annotations:[ ("%returnedBytes", "A bytes constant.") ] 372 | in 373 | let basics_and_views l = Ezjsonm.(basics @ [ ("views", list Fn.id l) ]) in 374 | let many () = 375 | originate ~logfile ~description:"Empty contract" ~name:"de0" 376 | ~source:(contract ()) ~init:"(Pair 2 {})" (); 377 | simple "empty_metadata" "The missing metadata one." []; 378 | simple "wrong_uri" "Has a URI that points nowhere." 379 | [ root "tezos-storage:onekey" ]; 380 | self_host "empty_but_valid" "Empty, but valid metadata." Ezjsonm.(dict []); 381 | self_host "just_version" "Has just a version string." 382 | Ezjsonm.(dict [ ("version", string "tzcomet-example v0.0.42") ]); 383 | self_describe "with_basics" "This contract has few more fields." basics; 384 | self_describe "one_off_chain_view" 385 | "This contract has a one off-chain-view which is actually reused for the \ 386 | error-translation." 387 | (basics_and_views [ multiply_the_nat ]); 388 | self_describe "bunch_of_views" 389 | "This contract has a bunch of off-chain-views." 390 | (basics_and_views 391 | [ 392 | empty_view_01; 393 | failwith_01; 394 | multiply_the_nat; 395 | call_balance; 396 | identity_01; 397 | view_with_too_much_code; 398 | call_self_address; 399 | ]); 400 | simple "invalid_uri" "Has a URI that is invalid." 401 | [ root "tezos-storage:onekey/with/slash" ]; 402 | self_host "invalid_version_field" 403 | "Points to invalid metadata (wrong version field)." 404 | Ezjsonm.(dict [ ("version", list string [ "tzcomet-example v0.0.42" ]) ]); 405 | self_describe "views_return_bytes" 406 | "This contract has bytes-returning off-chain-views." 407 | (basics_and_views 408 | [ 409 | unit_to_bytes "empty-bytes" ""; 410 | unit_to_bytes "some-json" 411 | Ezjsonm.( 412 | value_to_string ~minify:true 413 | (dict 414 | [ 415 | ("hello", string "world"); 416 | ( "more", 417 | dict 418 | [ 419 | ("lorem", int 42); 420 | ("ipsum", strings [ ""; "one"; "2" ]); 421 | ] ); 422 | ])); 423 | unit_to_bytes "some-text" 424 | {text| 425 | Here is some text. 426 | Лорем ипсум долор сит амет, алияуид инцоррупте тхеопхрастус еу сеа, ин 427 | еум солута оптион дефинитионем. Ат меа симул оффициис молестиае, еос 428 | яуаеяуе инвидунт цонвенире ид. Ат солеат волутпат вел. Сед еи инермис 429 | веритус 430 | 431 | 직전대통령이 없을 때에는 대통령이 지명한다, 그 정치적 중립성은 432 | 준수된다. 국가는 법률이 정하는 바에 의하여 정당운영에 필요한 자금을 433 | 보조할 수 있다, 군사법원의 조직·권한 및 재판관의 자격은 법률로 정한다. 434 | |text}; 435 | unit_to_bytes "200-random-characters" 436 | (String.init 200 ~f:(fun _ -> Random.char ())); 437 | unit_to_bytes "1000-random-characters" 438 | (String.init 1000 ~f:(fun _ -> Random.char ())); 439 | ]); 440 | () 441 | in 442 | many (); 443 | let all = List.rev !originated in 444 | if print then 445 | List.iter all ~f:(fun (n, d, k) -> 446 | Fmt.pr "\nlet %s = %S in\nkt1 %s %S;\n" n k n d); 447 | all 448 | 449 | let () = 450 | let usage () = Fmt.epr "usage: %s \n%!" Caml.Sys.argv.(0) in 451 | let logfile = "/tmp/originations.md" in 452 | let dry_run = 453 | try String.equal (Caml.Sys.getenv "dryrun") "true" with _ -> false 454 | in 455 | match Array.to_list Caml.Sys.argv |> List.tl_exn with 456 | | [ "all" ] -> Fn.ignore (all () ~logfile ~dry_run) 457 | | [ "list" ] -> 458 | let l = all () ~logfile ~dry_run:true ~print:false in 459 | List.iter l ~f:(fun (n, d, _) -> Fmt.pr "- `%s`: %s\n%!" n d) 460 | | "only" :: these -> Fn.ignore (all () ~logfile ~dry_run ~only:these) 461 | | other :: _ -> 462 | Fmt.epr "Unknown command: %S!\n%!" other; 463 | usage (); 464 | Caml.exit 2 465 | | [] -> 466 | Fmt.epr "Missing command\n%!"; 467 | usage (); 468 | Caml.exit 2 469 | -------------------------------------------------------------------------------- /src/client/tzcomet_jsonm.mli: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2012 The jsonm programmers. All rights reserved. *) 2 | (* Distributed under the ISC license, see terms at the end of the file. *) 3 | 4 | (** Non-blocking streaming JSON codec. 5 | 6 | [Jsonm] is a non-blocking streaming codec to {{!section:decode} decode} and 7 | {{!section:encode} encode} the {{:http://tools.ietf.org/html/rfc7159} JSON} 8 | data format. It can process JSON text without blocking on IO and without a 9 | complete in-memory representation of the data. 10 | 11 | The {{!Uncut} uncut codec} also processes whitespace and (non-standard) JSON 12 | with JavaScript comments. 13 | 14 | Consult the {{!datamodel} data model}, {{!limitations} limitations} and 15 | {{!examples} examples} of use. 16 | 17 | {3 References} 18 | 19 | - T. Bray Ed. 20 | {e {{:http://tools.ietf.org/html/rfc7159} The JavaScript Object Notation 21 | (JSON) Data Interchange Format}, 2014} *) 22 | 23 | (** {1:datamodel JSON data model} *) 24 | 25 | type lexeme = 26 | [ `Null 27 | | `Bool of bool 28 | | `String of string 29 | | `Float of float 30 | | `Name of string 31 | | `As 32 | | `Ae 33 | | `Os 34 | | `Oe ] 35 | (** The type for JSON lexemes. [`As] and [`Ae] start and end arrays and [`Os] 36 | and [`Oe] start and end objects. [`Name] is for the member names of objects. 37 | 38 | A {e well-formed} sequence of lexemes belongs to the language of the [json] 39 | grammar: 40 | 41 | {[ 42 | json = value 43 | object = `Os *member `Oe 44 | member = (`Name s) value 45 | array = `As *value `Ae 46 | value = `Null / `Bool b / `Float f / `String s / object / array 47 | ]} 48 | 49 | A {{!section:decode} decoder} returns only well-formed sequences of lexemes 50 | or [`Error]s are returned. The {{:http://tools.ietf.org/html/rfc3629} 51 | UTF-8}, {{:http://tools.ietf.org/html/rfc2781} UTF-16}, UTF-16LE and 52 | UTF-16BE encoding schemes are supported. The strings of decoded [`Name] and 53 | [`String] lexemes are however always UTF-8 encoded. In these strings, 54 | characters originally escaped in the input are in their unescaped 55 | representation. 56 | 57 | An {{!section:encode} encoder} accepts only well-formed sequences of lexemes 58 | or [Invalid_argument] is raised. Only the UTF-8 encoding scheme is 59 | supported. The strings of encoded [`Name] and [`String] lexemes are assumed 60 | to be immutable and must be UTF-8 encoded, this is {b not} checked by the 61 | module. In these strings, the delimiter characters [U+0022] and [U+005C] 62 | (['"'], ['\']) aswell as the control characters [U+0000-U+001F] are 63 | automatically escaped by the encoders, as mandated by the standard. *) 64 | 65 | val pp_lexeme : Format.formatter -> [< lexeme ] -> unit 66 | (** [pp_lexeme ppf l] prints a unspecified non-JSON representation of [l] on 67 | [ppf]. *) 68 | 69 | (** {1:decode Decode} *) 70 | 71 | type error = 72 | [ `Illegal_BOM 73 | | `Illegal_escape of 74 | [ `Not_hex_uchar of Uchar.t 75 | | `Not_esc_uchar of Uchar.t 76 | | `Not_lo_surrogate of int 77 | | `Lone_lo_surrogate of int 78 | | `Lone_hi_surrogate of int ] 79 | | `Illegal_string_uchar of Uchar.t 80 | | `Illegal_bytes of string 81 | | `Illegal_literal of string 82 | | `Illegal_number of string 83 | | `Unclosed of [ `As | `Os | `String | `Comment ] 84 | | `Expected of 85 | [ `Comment 86 | | `Value 87 | | `Name 88 | | `Name_sep 89 | | `Json 90 | | `Eoi 91 | | `Aval of bool (* [true] if first array value *) 92 | | `Omem of bool (* [true] if first object member *) ] ] 93 | 94 | (** The type for decoding errors. *) 95 | 96 | val pp_error : Format.formatter -> [< error ] -> unit 97 | (** [pp_error e] prints an unspecified UTF-8 representation of [e] on [ppf]. *) 98 | 99 | type encoding = [ `UTF_8 | `UTF_16 | `UTF_16BE | `UTF_16LE ] 100 | (** The type for Unicode encoding schemes. *) 101 | 102 | type src = [ `Channel of in_channel | `String of string | `Manual ] 103 | (** The type for input sources. With a [`Manual] source the client must provide 104 | input with {!Manual.src}. *) 105 | 106 | type decoder 107 | (** The type for JSON decoders. *) 108 | 109 | val decoder : ?encoding:[< encoding ] -> [< src ] -> decoder 110 | (** [decoder encoding src] is a JSON decoder that inputs from [src]. [encoding] 111 | specifies the character encoding of the data. If unspecified the encoding is 112 | guessed as {{:http://tools.ietf.org/html/rfc4627#section-3} suggested} by 113 | the old RFC4627 standard. *) 114 | 115 | val decode : decoder -> [> `Await | `Lexeme of lexeme | `End | `Error of error ] 116 | (** [decode d] is: 117 | 118 | - [`Await] if [d] has a [`Manual] source and awaits for more input. The 119 | client must use {!Manual.src} to provide it. 120 | - [`Lexeme l] if a lexeme [l] was decoded. 121 | - [`End] if the end of input was reached. 122 | - [`Error e] if a decoding error occured. If the client is interested in a 123 | best-effort decoding it can still continue to decode after an error (see 124 | {!errorrecovery}) although the resulting sequence of [`Lexeme]s is 125 | undefined and may not be well-formed. 126 | 127 | The {!Uncut.pp_decode} function can be used to inspect decode results. 128 | 129 | {b Note.} Repeated invocation always eventually returns [`End], even in case 130 | of errors. *) 131 | 132 | val decoded_range : decoder -> (int * int) * (int * int) 133 | (** [decoded_range d] is the range of characters spanning the last [`Lexeme] or 134 | [`Error] (or [`White] or [`Comment] for an {!Uncut.decode}) decoded by [d]. 135 | A pair of line and column numbers respectively one and zero based. *) 136 | 137 | val decoder_encoding : decoder -> encoding 138 | (** [decoder_encoding d] is [d]'s encoding. 139 | 140 | {b Warning.} If the decoder guesses the encoding, rely on this value only 141 | after the first [`Lexeme] was decoded. *) 142 | 143 | val decoder_src : decoder -> src 144 | (** [decoder_src d] is [d]'s input source. *) 145 | 146 | (** {1:encode Encode} *) 147 | 148 | type dst = [ `Channel of out_channel | `Buffer of Buffer.t | `Manual ] 149 | (** The type for output destinations. With a [`Manual] destination the client 150 | must provide output storage with {!Manual.dst}. *) 151 | 152 | type encoder 153 | (** The type for JSON encoders. *) 154 | 155 | val encoder : ?minify:bool -> [< dst ] -> encoder 156 | (** [encoder minify dst] is an encoder that outputs to [dst]. If [minify] is 157 | [true] (default) the output is made as compact as possible, otherwise the 158 | output is indented. If you want better control on whitespace use 159 | [minify = true] and {!Uncut.encode}. *) 160 | 161 | val encode : 162 | encoder -> [< `Await | `End | `Lexeme of lexeme ] -> [ `Ok | `Partial ] 163 | (** [encode e v] is: 164 | 165 | - [`Partial] iff [e] has a [`Manual] destination and needs more output 166 | storage. The client must use {!Manual.dst} to provide a new buffer and 167 | then call {!encode} with [`Await] until [`Ok] is returned. 168 | - [`Ok] when the encoder is ready to encode a new [`Lexeme] or [`End]. 169 | 170 | For [`Manual] destinations, encoding [`End] always returns [`Partial], the 171 | client should as usual use {!Manual.dst} and continue with [`Await] until 172 | [`Ok] is returned at which point {!Manual.dst_rem} [e] is guaranteed to be 173 | the size of the last provided buffer (i.e. nothing was written). 174 | 175 | {b Raises.} [Invalid_argument] if a non {{!datamodel} well-formed} sequence 176 | of lexemes is encoded or if [`Lexeme] or [`End] is encoded after a 177 | [`Partial] encode. *) 178 | 179 | val encoder_dst : encoder -> dst 180 | (** [encoder_dst e] is [e]'s output destination. *) 181 | 182 | val encoder_minify : encoder -> bool 183 | (** [encoder_minify e] is [true] if [e]'s output is minified. *) 184 | 185 | (** {1:manual Manual sources and destinations} *) 186 | 187 | (** Manual input sources and output destinations. 188 | 189 | {b Warning.} Use only with [`Manual] decoders and encoders. *) 190 | module Manual : sig 191 | val src : decoder -> Bytes.t -> int -> int -> unit 192 | (** [src d s j l] provides [d] with [l] bytes to read, starting at [j] in [s]. 193 | This byte range is read by calls to {!decode} until [`Await] is returned. 194 | To signal the end of input call the function with [l = 0]. *) 195 | 196 | val dst : encoder -> Bytes.t -> int -> int -> unit 197 | (** [dst e s j l] provides [e] with [l] bytes to write, starting at [j] in 198 | [s]. This byte range is written by calls to {!encode} with [e] until 199 | [`Partial] is returned. Use {!dst_rem} to know the remaining number of 200 | non-written free bytes in [s]. *) 201 | 202 | val dst_rem : encoder -> int 203 | (** [dst_rem e] is the remaining number of non-written, free bytes in the last 204 | buffer provided with {!dst}. *) 205 | end 206 | 207 | (** {1:uncut Uncut codec} *) 208 | 209 | (** Codec with comments and whitespace. 210 | 211 | The uncut codec also processes whitespace and JavaScript comments. The 212 | latter is non-standard JSON, fail on [`Comment] decoding if you want to 213 | process whitespace but stick to the standard. 214 | 215 | The uncut codec preserves as much of the original input as possible. Perfect 216 | round-trip with [Jsonm] is however impossible for the following reasons: 217 | 218 | - Escapes unescaped by the decoder may not be escaped or escaped differently 219 | by the encoder. 220 | - The encoder automatically inserts name separator [':'] and value 221 | separators [","]. If you just reencode the sequence of decodes, whitespace 222 | and comments may (harmlessly, but significantly) commute with these 223 | separators. 224 | - Internally the encoder uses [U+000A] (['\n']) for newlines. 225 | - [`Float] lexemes may be rewritten differently by the encoder. *) 226 | module Uncut : sig 227 | (** {1:uncutdatamodel Uncut data model} 228 | 229 | The uncut data model is the same as the regular {{!datamodel} data model}, 230 | except that before or after any lexeme you may decode/encode one or more: 231 | 232 | - [`White w], representing JSON whitespace [w]. On input the sequence CR 233 | ([U+000D]) and CRLF (<[U+000A], [U+000A]>) are normalized to [U+000A]. 234 | The string [w] must be a sequence of [U+0020], [U+0009], [U+000A] or 235 | [U+000D] characters ([' '], ['\t'], ['\n'], ['\r']). 236 | - [`Comment (`S, c)], representing a JavaScript single line comment [c]. 237 | [c] is the comment's content without the starting [//] and the ending 238 | newline. The string [c] must not contain any newline. 239 | - [`Comment (`M, c)], representing a JavaScript multi-line comment [c]. 240 | [c] is the comment's content without the starting [/*] and the ending 241 | [*/]. The string [c] must not contain the sequence [*/]. 242 | 243 | {b Warning.} {!Uncut.encode} does not check the above constraints on [w] 244 | and [c]. *) 245 | 246 | (** {1 Decode} *) 247 | 248 | val decode : 249 | decoder -> 250 | [ `Await 251 | | `Lexeme of lexeme 252 | | `White of string 253 | | `Comment of [ `S | `M ] * string 254 | | `End 255 | | `Error of error ] 256 | (** [decode d] is like {!Jsonm.decode} but for the {{!uncutdatamodel} uncut 257 | data model}. *) 258 | 259 | val pp_decode : 260 | Format.formatter -> 261 | [< `Await 262 | | `Lexeme of lexeme 263 | | `White of string 264 | | `Comment of [ `S | `M ] * string 265 | | `End 266 | | `Error of error ] -> 267 | unit 268 | (** [pp_decode ppf v] prints an unspecified representation of [v] on [ppf]. *) 269 | 270 | (** {1 Encode} *) 271 | 272 | val encode : 273 | encoder -> 274 | [< `Await 275 | | `Lexeme of lexeme 276 | | `White of string 277 | | `Comment of [ `S | `M ] * string 278 | | `End ] -> 279 | [ `Ok | `Partial ] 280 | (** [encode] is like {!Jsonm.encode} but for the {{!uncutdatamodel} uncut data 281 | model}. 282 | 283 | {b IMPORTANT.} Never encode [`Comment] for the web, it is non-standard and 284 | breaks interoperability. *) 285 | end 286 | 287 | (** {1:limitations Limitations} 288 | 289 | {2 Decode} 290 | 291 | Decoders parse valid JSON with the following limitations: 292 | 293 | - JSON numbers are represented with OCaml [float] values. This means that it 294 | can only represent integers exactly in the in the interval 295 | \[-2{^ 53};2{^ 53}\]. This is equivalent to the contraints JavaScript has. 296 | - A superset of JSON numbers is parsed. After having seen a minus or a 297 | digit, including zero, {!Stdlib.float_of_string}, is used. In particular 298 | this parses number with leading zeros, which are specifically prohibited 299 | by the standard. 300 | - Strings returned by [`String], [`Name], [`White] and [`Comment] are 301 | limited by {!Sys.max_string_length}. There is no built-in protection 302 | against the fact that the internal OCaml [Buffer.t] value may raise 303 | [Failure] on {!Jsonm.decode}. This should however only be a problem on 304 | 32-bits platforms if your strings are greater than 16Mo. 305 | 306 | Position tracking assumes that each decoded Unicode scalar value has a 307 | column width of 1. The same assumption may not be made by the display 308 | program (e.g. for [emacs]' compilation mode you need to set 309 | [compilation-error-screen-columns] to [nil]). 310 | 311 | The newlines LF ([U+000A]), CR ([U+000D]), and CRLF are all normalized to LF 312 | internally. This may have an impact in some corner [`Error] cases. For 313 | example the invalid escape sequence [] in a string will be 314 | reported as being [`Illegal_escape (`Not_esc_uchar 315 | 0x000A)]. 316 | 317 | {2 Encode} 318 | 319 | Encoders produce valid JSON provided the {e client} ensures that the 320 | following holds. 321 | 322 | - All the strings given to the encoder must be valid UTF-8 and immutable. 323 | Characters that need to be escaped are automatically escaped by [Jsonm]. 324 | - [`Float] lexemes must not be, {!Stdlib.nan}, {!Stdlib.infinity} or 325 | {!Stdlib.neg_infinity}. They are encoded with the format string ["%.16g"], 326 | this allows to roundtrip all the integers that can be precisely 327 | represented in OCaml [float] values, i.e. the integers in the interval 328 | \[-2{^ 53};2{^ 53}\]. This is equivalent to the constraints JavaScript 329 | has. 330 | - If the {{!Uncut} uncut} codec is used [`White] must be made of 331 | {{!Uncut.uncutdatamodel} JSON whitespace} and [`Comment] must never be 332 | encoded. *) 333 | 334 | (** {1:errorrecovery Error recovery} 335 | 336 | After a decoding error, if best-effort decoding is performed. The following 337 | happens before continuing: 338 | 339 | - [`Illegal_BOM], the initial 340 | {{:http://unicode.org/glossary/#byte_order_mark} BOM} is skipped. 341 | - [`Illegal_bytes], [`Illegal_escape], [`Illegal_string_uchar], a Unicode 342 | {{:http://unicode.org/glossary/#replacement_character} replacement 343 | character} ([U+FFFD]) is substituted to the illegal sequence. 344 | - [`Illegal_literal], [`Illegal_number] the corresponding [`Lexeme] is 345 | skipped. 346 | - [`Expected r], input is discarded until a synchronyzing lexeme that 347 | depends on [r] is found. 348 | - [`Unclosed], the end of input is reached, further decodes will be [`End] *) 349 | 350 | (** {1:examples Examples} 351 | 352 | {2:filter Trip} 353 | 354 | The result of [trip src dst] has the JSON from [src] written on [dst]. 355 | 356 | {[ 357 | let trip ?encoding ?minify 358 | (src : [ `Channel of in_channel | `String of string ]) 359 | (dst : [ `Channel of out_channel | `Buffer of Buffer.t ]) = 360 | let rec loop d e = 361 | match Jsonm.decode d with 362 | | `Lexeme _ as v -> 363 | ignore (Jsonm.encode e v); 364 | loop d e 365 | | `End -> 366 | ignore (Jsonm.encode e `End); 367 | `Ok 368 | | `Error err -> `Error (Jsonm.decoded_range d, err) 369 | | `Await -> assert false 370 | in 371 | let d = Jsonm.decoder ?encoding src in 372 | let e = Jsonm.encoder ?minify dst in 373 | loop d e 374 | ]} 375 | 376 | Using the [`Manual] interface, [trip_fd] does the same but between Unix file 377 | descriptors. 378 | 379 | {[ 380 | let trip_fd ?encoding ?minify (fdi : Unix.file_descr) 381 | (fdo : Unix.file_descr) = 382 | let rec encode fd s e v = 383 | match Jsonm.encode e v with 384 | | `Ok -> () 385 | | `Partial -> 386 | let rec unix_write fd s j l = 387 | let rec write fd s j l = 388 | try Unix.single_write fd s j l 389 | with Unix.Unix_error (Unix.EINTR, _, _) -> write fd s j l 390 | in 391 | let wc = write fd s j l in 392 | if wc < l then unix_write fd s (j + wc) (l - wc) else () 393 | in 394 | unix_write fd s 0 (Bytes.length s - Jsonm.Manual.dst_rem e); 395 | Jsonm.Manual.dst e s 0 (Bytes.length s); 396 | encode fd s e `Await 397 | in 398 | let rec loop fdi fdo ds es d e = 399 | match Jsonm.decode d with 400 | | `Lexeme _ as v -> 401 | encode fdo es e v; 402 | loop fdi fdo ds es d e 403 | | `End -> 404 | encode fdo es e `End; 405 | `Ok 406 | | `Error err -> `Error (Jsonm.decoded_range d, err) 407 | | `Await -> 408 | let rec unix_read fd s j l = 409 | try Unix.read fd s j l 410 | with Unix.Unix_error (Unix.EINTR, _, _) -> unix_read fd s j l 411 | in 412 | let rc = unix_read fdi ds 0 (Bytes.length ds) in 413 | Jsonm.Manual.src d ds 0 rc; 414 | loop fdi fdo ds es d e 415 | in 416 | let ds = Bytes.create 65536 (* UNIX_BUFFER_SIZE in 4.0.0 *) in 417 | let es = Bytes.create 65536 (* UNIX_BUFFER_SIZE in 4.0.0 *) in 418 | let d = Jsonm.decoder ?encoding `Manual in 419 | let e = Jsonm.encoder ?minify `Manual in 420 | Jsonm.Manual.dst e es 0 (Bytes.length es); 421 | loop fdi fdo ds es d e 422 | ]} 423 | 424 | {2:memsel Member selection} 425 | 426 | The result of [memsel names src] is the list of string values of members of 427 | [src] that have their name in [names]. In this example, decoding errors are 428 | silently ignored. 429 | 430 | {[ 431 | let memsel ?encoding names 432 | (src : [ `Channel of in_channel | `String of string ]) = 433 | let rec loop acc names d = 434 | match Jsonm.decode d with 435 | | `Lexeme (`Name n) when List.mem n names -> begin 436 | match Jsonm.decode d with 437 | | `Lexeme (`String s) -> loop (s :: acc) names d 438 | | _ -> loop acc names d 439 | end 440 | | `Lexeme _ | `Error _ -> loop acc names d 441 | | `End -> List.rev acc 442 | | `Await -> assert false 443 | in 444 | loop [] names (Jsonm.decoder ?encoding src) 445 | ]} 446 | 447 | {2:tree Generic JSON representation} 448 | 449 | A generic OCaml representation of JSON text is the following one. 450 | 451 | {[ 452 | type json = 453 | [ `Null 454 | | `Bool of bool 455 | | `Float of float 456 | | `String of string 457 | | `A of json list 458 | | `O of (string * json) list ] 459 | ]} 460 | 461 | The result of [json_of_src src] is the JSON text from [src] in this 462 | representation. The function is tail recursive. 463 | 464 | {[ 465 | exception Escape of ((int * int) * (int * int)) * Jsonm.error 466 | 467 | let json_of_src ?encoding 468 | (src : [ `Channel of in_channel | `String of string ]) = 469 | let dec d = 470 | match Jsonm.decode d with 471 | | `Lexeme l -> l 472 | | `Error e -> raise (Escape (Jsonm.decoded_range d, e)) 473 | | `End | `Await -> assert false 474 | in 475 | let rec value v k d = 476 | match v with 477 | | `Os -> obj [] k d 478 | | `As -> arr [] k d 479 | | (`Null | `Bool _ | `String _ | `Float _) as v -> k v d 480 | | _ -> assert false 481 | and arr vs k d = 482 | match dec d with 483 | | `Ae -> k (`A (List.rev vs)) d 484 | | v -> value v (fun v -> arr (v :: vs) k) d 485 | and obj ms k d = 486 | match dec d with 487 | | `Oe -> k (`O (List.rev ms)) d 488 | | `Name n -> value (dec d) (fun v -> obj ((n, v) :: ms) k) d 489 | | _ -> assert false 490 | in 491 | let d = Jsonm.decoder ?encoding src in 492 | try `JSON (value (dec d) (fun v _ -> v) d) 493 | with Escape (r, e) -> `Error (r, e) 494 | ]} 495 | 496 | The result of [json_to_dst dst json] has the JSON text [json] written on 497 | [dst]. The function is tail recursive. 498 | 499 | {[ 500 | let json_to_dst ~minify 501 | (dst : [ `Channel of out_channel | `Buffer of Buffer.t ]) 502 | (json : json) = 503 | let enc e l = ignore (Jsonm.encode e (`Lexeme l)) in 504 | let rec value v k e = 505 | match v with 506 | | `A vs -> arr vs k e 507 | | `O ms -> obj ms k e 508 | | (`Null | `Bool _ | `Float _ | `String _) as v -> 509 | enc e v; 510 | k e 511 | and arr vs k e = 512 | enc e `As; 513 | arr_vs vs k e 514 | and arr_vs vs k e = 515 | match vs with 516 | | v :: vs' -> value v (arr_vs vs' k) e 517 | | [] -> 518 | enc e `Ae; 519 | k e 520 | and obj ms k e = 521 | enc e `Os; 522 | obj_ms ms k e 523 | and obj_ms ms k e = 524 | match ms with 525 | | (n, v) :: ms -> 526 | enc e (`Name n); 527 | value v (obj_ms ms k) e 528 | | [] -> 529 | enc e `Oe; 530 | k e 531 | in 532 | let e = Jsonm.encoder ~minify dst in 533 | let finish e = ignore (Jsonm.encode e `End) in 534 | value json finish e 535 | ]} *) 536 | 537 | (* Copyright (c) 2012 The jsonm programmers *) 538 | 539 | (* Permission to use, copy, modify, and/or distribute this software for any *) 540 | (* purpose with or without fee is hereby granted, provided that the above *) 541 | (* copyright notice and this permission notice appear in all copies. *) 542 | 543 | (* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES *) 544 | (* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF *) 545 | (* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR *) 546 | (* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES *) 547 | (* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN *) 548 | (* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF *) 549 | (* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 550 | -------------------------------------------------------------------------------- /src/client/query_nodes.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | module Node_status = struct 4 | type t = Uninitialized | Non_responsive of exn | Ready of string 5 | end 6 | 7 | open Node_status 8 | 9 | module Rpc_cache = struct 10 | module Hashtbl = Caml.Hashtbl 11 | 12 | type t = (string, float * string) Hashtbl.t 13 | 14 | let create () : t = Hashtbl.create 42 15 | 16 | let add (t : t) ~rpc ~response = 17 | let now = System.program_time () in 18 | dbgf "CACHE-ADD: %s (%.0f)" rpc now; 19 | Hashtbl.add t rpc (now, response) 20 | 21 | let get (t : t) ~rpc = 22 | let now = System.program_time () in 23 | let best_ts = ref 0. in 24 | let best = ref None in 25 | let filter r (ts, v) = 26 | if Float.(!best_ts < ts) && String.equal rpc r then ( 27 | best_ts := ts; 28 | best := Some v); 29 | if Float.(ts + 120. < now) then None else Some (ts, v) 30 | in 31 | Hashtbl.filter_map_inplace filter t; 32 | let age = now -. !best_ts in 33 | dbgf "CACHE-GET:\n %s\n → now: %.0f\n → age: %.0f\n → %s" rpc now age 34 | (if Option.is_none !best then "MISS" else "HIT"); 35 | (age, !best) 36 | end 37 | 38 | module Node = struct 39 | type t = { 40 | name : string; 41 | prefix : string; 42 | status : (float * Node_status.t) Reactive.var; 43 | rpc_cache : Rpc_cache.t; 44 | network : Network.t; 45 | info_url : string option; 46 | } 47 | 48 | let create ~network ?info_url name prefix = 49 | { 50 | name; 51 | prefix; 52 | status = Reactive.var (0., Uninitialized); 53 | rpc_cache = Rpc_cache.create (); 54 | network; 55 | info_url; 56 | } 57 | 58 | let status n = Reactive.get n.status 59 | 60 | let rpc_get ctxt node path = 61 | let open Lwt in 62 | let uri = Fmt.str "%s/%s" node.prefix path in 63 | let fail msg = 64 | Decorate_error.raise 65 | Message.( 66 | t "Calling" %% ct "HTTP-GET" %% ct path %% t "on node" %% ct node.name 67 | %% msg) 68 | in 69 | let actually_get () = 70 | System.with_timeout ctxt 71 | ~f: 72 | Js_of_ocaml_lwt.XmlHttpRequest.( 73 | fun () -> 74 | get uri >>= fun frame -> 75 | dbgf "%s %s code: %d" node.prefix path frame.code; 76 | match frame.code with 77 | | 200 -> 78 | Rpc_cache.add node.rpc_cache ~rpc:path ~response:frame.content; 79 | return frame.content 80 | | other -> 81 | fail Message.(t "failed with code" %% Fmt.kstr ct "%d" other)) 82 | ~raise:(fun timeout -> 83 | dbgf "Node-%S GET %s → TIMEOUT" node.name path; 84 | fail Message.(Fmt.kstr t "timeouted (%.03f seconds)" timeout)) 85 | in 86 | match Rpc_cache.get node.rpc_cache ~rpc:path with 87 | | _, None -> actually_get () 88 | | age, Some _ when Float.(age > 120.) -> actually_get () 89 | | _, Some s -> Lwt.return s 90 | 91 | let rpc_post ctxt node ~body path = 92 | let open Lwt in 93 | let uri = Fmt.str "%s/%s" node.prefix path in 94 | let fail msg = 95 | Decorate_error.raise 96 | Message.( 97 | t "Calling" %% ct "HTTP-POST" %% ct path %% t "on node" 98 | %% ct node.name %% t "with" %% code_block body %% msg) 99 | in 100 | System.with_timeout ctxt 101 | ~f: 102 | Js_of_ocaml_lwt.XmlHttpRequest.( 103 | fun () -> 104 | perform ~contents:(`String body) ~content_type:"application/json" 105 | (Option.value_exn ~message:"uri-of-string" 106 | (Js_of_ocaml.Url.url_of_string uri)) 107 | >>= fun frame -> 108 | dbgf "%s %s code: %d" node.prefix path frame.code; 109 | match frame.code with 110 | | 200 -> return frame.content 111 | | other -> 112 | dbgf "CONTENT: %s" frame.content; 113 | fail 114 | Message.( 115 | Fmt.kstr t "failed with with return code %d:" other 116 | %% code_block 117 | (try 118 | Ezjsonm.value_from_string frame.content 119 | |> Ezjsonm.value_to_string ~minify:false 120 | with _ -> frame.content))) 121 | ~raise:(fun timeout -> 122 | fail Message.(Fmt.kstr t "timeouted (%f seconds)." timeout)) 123 | 124 | let ping ctxt node = 125 | let open Lwt.Infix in 126 | Lwt.catch 127 | (fun () -> 128 | rpc_get ctxt node "/chains/main/blocks/head/metadata" 129 | >>= fun metadata -> Lwt.return (Ready metadata)) 130 | (fun e -> Lwt.return (Non_responsive e)) 131 | 132 | let get_storage state_handle node ~address ~log = 133 | Lwt.catch 134 | (fun () -> 135 | Fmt.kstr 136 | (rpc_post state_handle node 137 | ~body: 138 | Ezjsonm.( 139 | dict [ ("unparsing_mode", string "Optimized_legacy") ] 140 | |> value_to_string)) 141 | "/chains/main/blocks/head/context/contracts/%s/storage/normalized" 142 | address) 143 | (fun _ -> 144 | log "Node does not handle /normalized"; 145 | Fmt.kstr 146 | (rpc_get state_handle node) 147 | "/chains/main/blocks/head/context/contracts/%s/storage" address) 148 | 149 | module Contract = struct 150 | type t = { 151 | storage_node : Tezai_michelson.Untyped.t; 152 | type_node : Tezai_michelson.Untyped.t; 153 | metadata_big_map : Z.t; 154 | } 155 | 156 | let make ~storage_node ~type_node ~metadata_big_map = 157 | { storage_node; type_node; metadata_big_map } 158 | end 159 | 160 | let metadata_big_map state_handle node ~address ~log = 161 | let open Lwt in 162 | get_storage state_handle node ~address ~log >>= fun storage_string -> 163 | let get = rpc_get state_handle node in 164 | let log fmt = Fmt.kstr log fmt in 165 | log "Got raw storage: %s" storage_string; 166 | let mich_storage = 167 | Tezai_michelson.Untyped.of_json (Ezjsonm.value_from_string storage_string) 168 | in 169 | log "As concrete: %a" Tezai_michelson.Untyped.pp mich_storage; 170 | System.slow_step state_handle >>= fun () -> 171 | Fmt.kstr get "/chains/main/blocks/head/context/contracts/%s/script" address 172 | >>= fun script_string -> 173 | log "Got raw script: %s…" (ellipsize_string script_string ~max_length:30); 174 | let mich_storage_type = 175 | let mich = 176 | match Ezjsonm.value_from_string script_string with 177 | | `O (("code", code) :: _) -> Tezai_michelson.Untyped.of_json code 178 | | _ -> assert false 179 | in 180 | Tezai_michelson.Untyped_contract.get_storage_type_exn mich 181 | in 182 | log "Storage type: %a" Tezai_michelson.Untyped.pp mich_storage_type; 183 | System.slow_step state_handle >>= fun () -> 184 | let bgs = 185 | let module Help = Tezai_contract_metadata_manipulation.Micheline_helpers 186 | in 187 | let type_node = 188 | Help.normalize_combs ~primitive:"pair" mich_storage_type 189 | in 190 | let storage_node = Help.normalize_combs ~primitive:"Pair" mich_storage in 191 | Help.find_metadata_big_maps ~storage_node ~type_node 192 | in 193 | match bgs with 194 | | [] -> Fmt.failwith "Contract has no valid %%metadata big-map!" 195 | | _ :: _ :: _ -> 196 | Fmt.failwith "Contract has too many %%metadata big-maps: %s" 197 | (oxfordize_list bgs ~map:Z.to_string 198 | ~sep:(fun () -> ",") 199 | ~last_sep:(fun () -> ", and ") 200 | |> String.concat ~sep:"") 201 | | [ metadata_big_map ] -> 202 | return 203 | Contract.( 204 | make ~metadata_big_map ~storage_node:mich_storage 205 | ~type_node:mich_storage_type) 206 | 207 | let bytes_value_of_big_map_at_string ctxt node ~big_map_id ~key ~log = 208 | let open Lwt in 209 | let hash_string = 210 | Tezai_contract_metadata_manipulation.Michelson_bytes 211 | .b58_script_id_hash_of_michelson_string key 212 | in 213 | Decorate_error.( 214 | reraise 215 | Message.( 216 | t "Cannot find any value in the big-map" 217 | %% ct (Z.to_string big_map_id) 218 | %% t "at the key" %% ct key %% t "(hash: " % ct hash_string % t ").") 219 | ~f:(fun () -> 220 | Fmt.kstr (rpc_get ctxt node) 221 | "/chains/main/blocks/head/context/big_maps/%s/%s" 222 | (Z.to_string big_map_id) hash_string)) 223 | >>= fun bytes_raw_value -> 224 | Fmt.kstr log "bytes raw value: %s" 225 | (ellipsize_string bytes_raw_value ~max_length:30); 226 | let content = 227 | (* The code below was throwing a stack-overflow: *) 228 | (* match Ezjsonm.value_from_string bytes_raw_value with 229 | | `O [("bytes", `String b)] -> Hex.to_string (`Hex b) 230 | | _ -> Fmt.failwith "Cannot find bytes in %s" bytes_raw_value 231 | | exception e -> *) 232 | let v = 233 | Js_of_ocaml.Json.unsafe_input (Js_of_ocaml.Js.string bytes_raw_value) 234 | in 235 | dbgf "v: %s" v##.bytes; 236 | Hex.to_string (`Hex v##.bytes) 237 | in 238 | return content 239 | 240 | let micheline_value_of_big_map_at_nat ctxt node ~big_map_id ~key ~log = 241 | let open Lwt in 242 | let hash_string = 243 | Tezai_contract_metadata_manipulation.Michelson_bytes 244 | .b58_script_id_hash_of_michelson_int key 245 | in 246 | Decorate_error.( 247 | reraise 248 | Message.( 249 | t "Cannot find any value in the big-map" 250 | %% ct (Z.to_string big_map_id) 251 | %% t "at the key" 252 | %% ct (Z.to_string key) 253 | %% t "(hash: " % ct hash_string % t ").") 254 | ~f:(fun () -> 255 | Fmt.kstr (rpc_get ctxt node) 256 | "/chains/main/blocks/head/context/big_maps/%s/%s" 257 | (Z.to_string big_map_id) hash_string)) 258 | >>= fun raw_value -> 259 | Fmt.kstr log "JSON raw value: %s" 260 | (ellipsize_string raw_value ~max_length:60); 261 | let content = Michelson.micheline_of_json raw_value in 262 | return content 263 | end 264 | 265 | module Node_list = struct 266 | type t = (string, Node.t * bool) List.Assoc.t 267 | 268 | let empty : t = [] 269 | 270 | let add ?(dev = false) t n = 271 | List.Assoc.add ~equal:String.equal t n.Node.name (n, dev) 272 | 273 | let remove_by_name t n = List.Assoc.remove ~equal:String.equal t n 274 | 275 | let remove_dev t = 276 | List.filter t ~f:(function _, (_, true) -> false | _ -> true) 277 | 278 | let fold_nodes t ~init ~f = List.fold t ~init ~f:(fun p (_, (n, _)) -> f p n) 279 | let map t ~f = List.map t ~f:(fun (_, (n, _)) -> f n) 280 | let concat_map t ~f = List.concat_map t ~f:(fun (_, (n, _)) -> f n) 281 | end 282 | 283 | type t = { 284 | nodes : Node_list.t Reactive.var; 285 | wake_up_call : unit Lwt_condition.t; 286 | loop_started : bool Reactive.var; 287 | loop_interval : float Reactive.var; 288 | loop_status : [ `Not_started | `In_progress | `Sleeping ] Reactive.var; 289 | } 290 | 291 | let create () = 292 | { 293 | nodes = Reactive.var Node_list.empty; 294 | wake_up_call = Lwt_condition.create (); 295 | loop_started = Reactive.var false; 296 | loop_interval = Reactive.var 10.; 297 | loop_status = Reactive.var `Not_started; 298 | } 299 | 300 | let get (ctxt : < nodes : t ; .. > Context.t) = ctxt#nodes 301 | let nodes t = (get t).nodes 302 | 303 | let get_nodes t ~map = 304 | Reactive.pair ((get t).nodes |> Reactive.get) (System.dev_mode t) 305 | |> Reactive.map ~f:(function 306 | | l, true -> Node_list.map ~f:map l 307 | | l, false -> Node_list.map ~f:map (Node_list.remove_dev l)) 308 | 309 | let add_node ?dev ctxt nod = 310 | Reactive.set (nodes ctxt) 311 | (Node_list.add ?dev (Reactive.peek (nodes ctxt)) nod) 312 | 313 | let remove_node ctxt ~name = 314 | Reactive.set (nodes ctxt) 315 | (Node_list.remove_by_name (Reactive.peek (nodes ctxt)) name) 316 | 317 | let default_nodes : Node.t list = 318 | let teztnets = "https://teztnets.xyz" in 319 | let smartpy = "https://smartpy.io/nodes" in 320 | let ecad = "https://tezostaquito.io/docs/rpc_nodes" in 321 | let _marigold = "https://status.marigold.dev/" in 322 | (* let giga = "https://giganode.io/" in *) 323 | List.rev 324 | [ 325 | Node.create "Ghostnet-Teztnets" ~network:`Ghostnet 326 | "https://rpc.ghostnet.teztnets.xyz/" ~info_url:teztnets; 327 | Node.create "Nairobinet-Teztnets" ~network:`Nairobinet 328 | "https://rpc.nairobinet.teztnets.xyz/" ~info_url:teztnets; 329 | Node.create "Oxfordnet-Teztnets" ~network:`Oxfordnet 330 | "https://rpc.oxfordnet.teztnets.xyz/" ~info_url:teztnets 331 | (* ; Node.create "Oxfordnet-Marigold" ~network:`Oxfordnet 332 | "https://oxfordnet.tezos.marigold.dev/" ~info_url:marigold *); 333 | Node.create "Mainnet-SmartPy" "https://mainnet.smartpy.io" 334 | ~network:`Mainnet ~info_url:smartpy; 335 | Node.create "Ghostnet-SmartPy" ~network:`Ghostnet 336 | "https://ghostnet.smartpy.io" ~info_url:smartpy; 337 | Node.create "Mainnet-ECAD-Labs" ~network:`Mainnet 338 | "https://mainnet.api.tez.ie" ~info_url:ecad; 339 | Node.create "Mainnet-Blockscale" ~network:`Mainnet 340 | "https://rpc.tzbeta.net/" ~info_url:ecad; 341 | Node.create "Ghostnet-ECAD-Labs" ~network:`Ghostnet 342 | "https://ghostnet.ecadinfra.com" ~info_url:ecad; 343 | Node.create "Nairobinet-ECAD-Labs" ~network:`Nairobinet 344 | "https://nairobinet.ecadinfra.com" ~info_url:ecad 345 | (* ; Node.create "Mainnet-GigaNode" "https://mainnet-tezos.giganode.io" 346 | ~network:`Mainnet ~info_url:giga *); 347 | Node.create "Flextesabox-node" "http://127.0.0.1:20000" ~network:`Sandbox 348 | ~info_url:"https://tezos.gitlab.io/flextesa/"; 349 | ] 350 | 351 | let dev_nodes = 352 | List.rev 353 | [ 354 | Node.create "Dev:Wrong-node" "http://example.com/nothing" 355 | ~network:`Sandbox; 356 | ] 357 | 358 | let add_default_nodes ctxt = 359 | List.iter ~f:(add_node ~dev:true ctxt) dev_nodes; 360 | List.iter ~f:(add_node ~dev:false ctxt) default_nodes 361 | 362 | let loop_interval ctxt = Reactive.peek (get ctxt).loop_interval 363 | let loop_status ctxt = Reactive.get (get ctxt).loop_status 364 | let set_loop_status ctxt = Reactive.set (get ctxt).loop_status 365 | 366 | let observe_nodes ctxt = 367 | let data = get_nodes ~map:Fn.id ctxt in 368 | let data_root = Reactive.observe data in 369 | let nodes = Reactive.quick_sample data_root in 370 | Reactive.quick_release data_root; 371 | nodes 372 | 373 | module Update_status_loop = struct 374 | let wake_up ctxt = Lwt_condition.broadcast (get ctxt).wake_up_call () 375 | let wait_for_wake_up t = Lwt_condition.wait (get t).wake_up_call 376 | 377 | let start ctxt = 378 | let open Lwt.Infix in 379 | Lwt.ignore_result 380 | (let rec loop count = 381 | set_loop_status ctxt `In_progress; 382 | let sleep_time = loop_interval ctxt in 383 | let nodes = observe_nodes ctxt in 384 | dbgf "update-loop %d (%f s) %d nodes" count sleep_time 385 | (List.length nodes); 386 | List.fold nodes ~init:Lwt.return_unit ~f:(fun prevm nod -> 387 | prevm >>= fun () -> 388 | Node.ping ctxt nod >>= fun new_status -> 389 | dbgf "got status for %s" nod.name; 390 | let now = System.now () in 391 | Reactive.set nod.status (now, new_status); 392 | Lwt.return ()) 393 | >>= fun () -> 394 | set_loop_status ctxt `Sleeping; 395 | Lwt.pick 396 | [ Js_of_ocaml_lwt.Lwt_js.sleep sleep_time; wait_for_wake_up ctxt ] 397 | >>= fun () -> 398 | Reactive.set (get ctxt).loop_interval 399 | (Float.min (sleep_time *. 1.4) 120.); 400 | loop (count + 1) 401 | in 402 | loop 0) 403 | 404 | let ensure t = 405 | match Reactive.peek (get t).loop_started with 406 | | true -> () 407 | | false -> 408 | start t; 409 | Reactive.set (get t).loop_started true 410 | end 411 | 412 | let find_node_with_contract ctxt addr = 413 | let open Lwt in 414 | let trace = ref [] in 415 | catch 416 | (fun () -> 417 | Lwt_list.find_s 418 | (fun node -> 419 | catch 420 | (fun () -> 421 | Fmt.kstr (Node.rpc_get ctxt node) 422 | "/chains/main/blocks/head/context/contracts/%s/storage" addr 423 | >>= fun _ -> 424 | State.set_current_network ctxt node.Node.network; 425 | return_true) 426 | (fun exn -> 427 | trace := exn :: !trace; 428 | return_false)) 429 | (observe_nodes ctxt) 430 | >>= fun node -> Lwt.return node) 431 | (fun _ -> 432 | Decorate_error.raise ~trace:(List.rev !trace) 433 | Message.(t "Cannot find a node that knows about address" %% ct addr)) 434 | 435 | let metadata_value ctxt ~address ~key ~(log : string -> unit) = 436 | let open Lwt in 437 | let logf f = Fmt.kstr log f in 438 | find_node_with_contract ctxt address >>= fun node -> 439 | logf "Found contract with node %S" node.Node.name; 440 | Node.metadata_big_map ctxt node ~address ~log >>= fun metacontract -> 441 | let big_map_id = metacontract.Node.Contract.metadata_big_map in 442 | logf "Metadata big-map: %s" (Z.to_string big_map_id); 443 | Node.bytes_value_of_big_map_at_string ctxt node ~big_map_id ~key ~log 444 | 445 | let call_off_chain_view ctxt ~log ~address ~view ~parameter = 446 | let open Lwt in 447 | let open 448 | Tezai_contract_metadata.Metadata_contents.View.Implementation 449 | .Michelson_storage in 450 | let logf f = 451 | Fmt.kstr 452 | (fun s -> 453 | log s; 454 | dbgf "call_off_chain_view: %s" s) 455 | f 456 | in 457 | logf "Calling %s(%a)" address Tezai_michelson.Untyped.pp parameter; 458 | find_node_with_contract ctxt address >>= fun node -> 459 | logf "Found contract with node %S" node.name; 460 | Fmt.kstr (Node.rpc_get ctxt node) "/chains/main/blocks/head/protocols" 461 | >>= fun protocols -> 462 | let protocol_kind, protocol_hash = 463 | let hash = 464 | match Ezjsonm.value_from_string protocols with 465 | | `O l -> 466 | List.find_map l ~f:(function 467 | | "protocol", `String p -> Some p 468 | | _ -> None) 469 | | _ | (exception _) -> None 470 | in 471 | match hash with 472 | | None -> 473 | Decorate_error.raise 474 | Message.( 475 | t "Cannot understand answer from “protocols” RPC:" 476 | %% code_block protocols) 477 | | Some p when String.is_prefix p ~prefix:"PsCARTHA" -> (`Carthage, p) 478 | | Some p when String.is_prefix p ~prefix:"PsDELPH1" -> (`Delphi, p) 479 | | Some p when String.is_prefix p ~prefix:"PtEdoTez" -> (`Edo, p) 480 | | Some p when String.is_prefix p ~prefix:"PtEdo2Zk" -> (`Edo, p) 481 | | Some p when String.is_prefix p ~prefix:"PsFLorena" -> (`Florence, p) 482 | | Some p when String.is_prefix p ~prefix:"PtGRANAD" -> (`Granada, p) 483 | | Some p when String.is_prefix p ~prefix:"ProtoALpha" -> (`Granada, p) 484 | | Some p -> 485 | logf "Can't recognize protocol: `%s` assuming Edo-like." p; 486 | (`Granada, p) 487 | in 488 | logf "Protocol is `%s`" protocol_hash; 489 | Node.get_storage ctxt node ~address ~log >>= fun storage -> 490 | logf "Got the storage: %s" storage; 491 | Fmt.kstr (Node.rpc_get ctxt node) 492 | "/chains/main/blocks/head/context/contracts/%s/script" address 493 | >>= fun script -> 494 | Fmt.kstr (Node.rpc_get ctxt node) 495 | "/chains/main/blocks/head/context/contracts/%s/balance" address 496 | >>= fun balance -> 497 | let balance = Ezjsonm.(value_from_string balance |> get_string) in 498 | Fmt.kstr (Node.rpc_get ctxt node) "/chains/main/chain_id" >>= fun chain_id -> 499 | let chain_id = Ezjsonm.(value_from_string chain_id |> get_string) in 500 | logf "Got the script: %s" (ellipsize_string script ~max_length:30); 501 | let contract_storage = 502 | Tezai_michelson.Untyped.of_json (Ezjsonm.value_from_string storage) 503 | in 504 | let `Contract view_contract, `Input view_input, `Storage view_storage = 505 | let code_mich = 506 | match Ezjsonm.value_from_string script with 507 | | `O (("code", code) :: _) -> Tezai_michelson.Untyped.of_json code 508 | | _ -> assert false 509 | (* Michelson.micheline_of_json script *) 510 | in 511 | let open Tezai_michelson.Untyped_contract in 512 | let contract_storage_type = get_storage_type_exn code_mich in 513 | let contract_parameter_type = get_parameter_type_exn code_mich in 514 | let view_parameters = parameter in 515 | let view = 516 | (* TEMPORARY: this is one macro expansion for the test that is on 517 | carthagenet *) 518 | let code = 519 | match view.code with 520 | | Michelson_blob mich -> 521 | let open Tezos_micheline.Micheline in 522 | let node = root mich in 523 | let rec go = function 524 | | (Int _ | String _ | Bytes _) as ok -> ok 525 | | Prim (_loc, "CDAR", [], _annot) -> 526 | Seq 527 | ( _loc, 528 | [ Prim (_loc, "CDR", [], []); Prim (_loc, "CAR", [], []) ] 529 | ) 530 | | Prim (_loc, _prim, args, _annot) -> 531 | Prim (_loc, _prim, List.map ~f:go args, _annot) 532 | | Seq (loc, args) -> Seq (loc, List.map ~f:go args) 533 | in 534 | go node |> strip_locations 535 | in 536 | { view with code = Michelson_blob code } 537 | in 538 | Tezai_contract_metadata_manipulation.Micheline_helpers 539 | .build_off_chain_view_contract view ~contract_balance:(Z.of_string balance) 540 | ~contract_address:address ~contract_storage ~view_parameters 541 | ~contract_storage_type ~contract_parameter_type 542 | in 543 | logf "Made the view-script: %a" Tezai_michelson.Untyped.pp view_contract; 544 | logf "Made the view-input: %a" Tezai_michelson.Untyped.pp view_input; 545 | logf "Made the view-storage: %a" Tezai_michelson.Untyped.pp view_storage; 546 | let constructed = 547 | let michjson which mich = 548 | try Tezai_michelson.Untyped.to_json mich 549 | with e -> Fmt.failwith "micheline_to_ezjsonm '%s' → %a" which Exn.pp e 550 | in 551 | let open Ezjsonm in 552 | let normal_fields = 553 | [ 554 | ("script", michjson "script" view_contract); 555 | ("storage", michjson "storage" view_storage); 556 | ("input", michjson "input" view_input); 557 | ("amount", string "0"); 558 | ("chain_id", string chain_id); 559 | ] 560 | in 561 | let fields = 562 | match protocol_kind with 563 | | `Edo | `Florence | `Granada -> 564 | normal_fields 565 | @ [ 566 | ("balance", string "0"); 567 | ("unparsing_mode", string "Optimized_legacy"); 568 | ] 569 | | `Carthage | `Delphi -> normal_fields 570 | in 571 | dict fields 572 | in 573 | logf "Calling `/run_code`: %s" 574 | (try Ezjsonm.value_to_string constructed 575 | with e -> Fmt.failwith "JSON too deep for JS backend: %a" Exn.pp e); 576 | Node.rpc_post ctxt node 577 | ~body:(Ezjsonm.value_to_string constructed) 578 | (match protocol_kind with 579 | | `Edo -> "/chains/main/blocks/head/helpers/scripts/run_code/normalized" 580 | | _ -> "/chains/main/blocks/head/helpers/scripts/run_code") 581 | >>= fun result -> 582 | logf "RESULT: %s" result; 583 | let actual_result = 584 | let open Ezjsonm in 585 | let d = value_from_string result |> get_dict in 586 | let mich = 587 | match List.Assoc.find ~equal:String.equal d "storage" with 588 | | None -> Fmt.failwith "Result has not storage: %S" result 589 | | Some json -> Tezai_michelson.Untyped.of_json json 590 | in 591 | let open Tezai_michelson.Untyped.M in 592 | match mich with 593 | | Prim (_, "Some", [ s ], _) -> s 594 | | other -> 595 | Fmt.failwith "Result is not (Some _): %a" Tezai_michelson.Untyped.pp 596 | other 597 | in 598 | return (Ok (actual_result, contract_storage)) 599 | -------------------------------------------------------------------------------- /src/client/state.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | module Page = struct 4 | type t = Explorer | Settings | Token_viewer | About | Editor 5 | 6 | let to_string = function 7 | | Explorer -> "Explorer" 8 | | Editor -> "Editor" 9 | | Token_viewer -> "TokenViewer" 10 | | Settings -> "Settings" 11 | | About -> "About" 12 | 13 | let all_in_order = [ Explorer; Editor; Token_viewer; Settings; About ] 14 | end 15 | 16 | open Page 17 | 18 | module Editor_mode = struct 19 | type format = [ `Uri | `Hex | `Michelson | `Metadata_json ] 20 | type t = [ `Guess | format ] 21 | 22 | let to_string : [< t ] -> string = function 23 | | `Guess -> "guess" 24 | | `Uri -> "uri" 25 | | `Hex -> "hex" 26 | | `Michelson -> "michelson" 27 | | `Metadata_json -> "metadata" 28 | 29 | let all : t list = [ `Guess; `Uri; `Hex; `Michelson; `Metadata_json ] 30 | 31 | let explain : t -> _ = 32 | let open Meta_html in 33 | function 34 | | `Metadata_json -> t "Parse and display TZIP-16 Metadata JSON content." 35 | | `Uri -> t "Parse and display TZIP-16 Metadata URIs." 36 | | `Michelson -> 37 | t "Parse and serialize Micheline concrete syntax (Michelson)." 38 | | `Hex -> t "Parse Hexadecimal Michelson" %% ct "PACK" % t "-ed bytes." 39 | | `Guess -> t "Use heuristics to guess your intended format." 40 | end 41 | 42 | type t = { 43 | page : [ `Page of Page.t | `Changing_to of Page.t ] Reactive.var; 44 | explorer_input : string Reactive.var; 45 | explorer_go : bool Reactive.var; 46 | explorer_went : bool Reactive.var; 47 | explorer_result : Html_types.div_content_fun Meta_html.H5.elt Async_work.t; 48 | editor_content : string Reactive.var; 49 | editor_mode : Editor_mode.t Reactive.var; 50 | editor_load : bool Reactive.var; 51 | editor_should_load : bool Reactive.var; 52 | token_address : string Reactive.var; 53 | token_id : string Reactive.var; 54 | check_micheline_indentation : bool Reactive.var; 55 | always_show_multimedia : bool Reactive.var; 56 | show_token_details : bool Reactive.var; 57 | current_network : Network.t Reactive.var; 58 | } 59 | 60 | let get (state : < gui : t ; .. > Context.t) = state#gui 61 | let local_storage_filename = "tzcomet-editor-input" 62 | 63 | module Fragment = struct 64 | let to_string = Uri.to_string 65 | let pp = Uri.pp 66 | let page_to_path page = Fmt.str "/%s" (Page.to_string page |> String.lowercase) 67 | 68 | let make ~page ~dev_mode ~editor_input ~explorer_input ~explorer_go 69 | ~editor_mode ~token_address ~token_id ~check_micheline_indentation 70 | ~editor_load ~always_show_multimedia ~show_token_details = 71 | let query = 72 | match explorer_input with 73 | | "" -> [] 74 | | more -> [ ("explorer-input", [ more ]) ] 75 | in 76 | let query = 77 | match editor_input with 78 | | "" -> query 79 | | more -> ("editor-input", [ more ]) :: query 80 | in 81 | let query = if not dev_mode then query else ("dev", [ "true" ]) :: query in 82 | let query = 83 | if not explorer_go then query else ("go", [ "true" ]) :: query 84 | in 85 | let query = 86 | if not check_micheline_indentation then query 87 | else ("check-micheline-indentation", [ "true" ]) :: query 88 | in 89 | let query = 90 | match editor_mode with 91 | | `Guess -> query 92 | | other -> ("editor-mode", [ Editor_mode.to_string other ]) :: query 93 | in 94 | let query = 95 | if editor_load then ("load-storage", [ "true" ]) :: query else query 96 | in 97 | let query = 98 | if always_show_multimedia then 99 | ("always-show-multimedia", [ "true" ]) :: query 100 | else query 101 | in 102 | let query = 103 | if show_token_details then ("show-token-details", [ "true" ]) :: query 104 | else query 105 | in 106 | let path, query = 107 | match (page, token_address, token_id) with 108 | | _, "", "" -> (page_to_path page, query) 109 | | Token_viewer, kt, id -> (Fmt.str "/token/%s/%s" kt id, query) 110 | | _, kt, id -> 111 | (page_to_path page, ("token", [ Fmt.str "%s/%s" kt id ]) :: query) 112 | in 113 | Uri.make () ~path ~query 114 | 115 | let change_for_page t page = Uri.with_path t (page_to_path page) 116 | 117 | let parse fragment = 118 | let uri = Uri.of_string (Uri.pct_decode fragment) in 119 | let query = Uri.query uri in 120 | let in_query = List.Assoc.find ~equal:String.equal query in 121 | let true_in_query q = 122 | match in_query q with Some [ "true" ] -> true | _ -> false 123 | in 124 | let dev_mode = true_in_query "dev" in 125 | let mich_indent = true_in_query "check-micheline-indentation" in 126 | let explorer_input = 127 | match in_query "explorer-input" with Some [ one ] -> one | _ -> "" 128 | in 129 | let editor_mode = 130 | Option.bind (in_query "editor-mode") ~f:(function 131 | | [] -> None 132 | | one :: _ -> 133 | List.find Editor_mode.all ~f:(fun mode -> 134 | String.equal 135 | (String.lowercase (Editor_mode.to_string mode)) 136 | (one |> String.lowercase))) 137 | |> Option.value ~default:`Guess 138 | in 139 | let explorer_go = true_in_query "go" in 140 | let editor_load = true_in_query "load-storage" in 141 | let always_show_multimedia = true_in_query "always-show-multimedia" in 142 | let show_token_details = true_in_query "show-token-details" in 143 | let editor_input = 144 | match in_query "editor-input" with Some [ one ] -> one | _ -> "" 145 | in 146 | let extra_nodes = 147 | List.concat_map query ~f:(function "add-node", l -> l | _ -> []) 148 | in 149 | let page, (token_address, token_id) = 150 | let path_split = 151 | Uri.path uri 152 | |> String.chop_prefix_if_exists ~prefix:"/" 153 | |> String.split ~on:'/' 154 | in 155 | let token_in_query () = 156 | match in_query "token" with 157 | | Some [ one ] -> ( 158 | match String.split one ~on:'/' with 159 | | [ k ] -> (k, "0") 160 | | [ k; t ] -> (k, t) 161 | | _ -> ("", "")) 162 | | _ -> ("", "") 163 | in 164 | match path_split with 165 | | [ pagename ] -> 166 | let page = 167 | List.find all_in_order ~f:(fun page -> 168 | String.equal 169 | (String.lowercase (Page.to_string page)) 170 | (pagename |> String.lowercase)) 171 | |> Option.value ~default:Explorer 172 | in 173 | (page, token_in_query ()) 174 | | [ "token"; addr; id ] -> (Token_viewer, (addr, id)) 175 | | _ -> (Explorer, token_in_query ()) 176 | in 177 | ( System.create ~dev_mode (), 178 | `Extra_node_prefixes extra_nodes, 179 | { 180 | page = Reactive.var (`Page page); 181 | explorer_input = Reactive.var explorer_input; 182 | explorer_go = Reactive.var explorer_go; 183 | explorer_went = 184 | (* If page is not the explorer we will ignore the command = 185 | assume it aready happened. *) 186 | Reactive.var Poly.(page <> Page.Explorer); 187 | explorer_result = Async_work.empty (); 188 | editor_content = Reactive.var editor_input; 189 | editor_mode = Reactive.var editor_mode; 190 | editor_load = Reactive.var editor_load; 191 | editor_should_load = 192 | Reactive.var (editor_load && String.is_empty editor_input); 193 | token_address = Reactive.var token_address; 194 | token_id = Reactive.var token_id; 195 | check_micheline_indentation = Reactive.var mich_indent; 196 | always_show_multimedia = Reactive.var always_show_multimedia; 197 | show_token_details = Reactive.var show_token_details; 198 | current_network = Reactive.var `Mainnet; 199 | } ) 200 | end 201 | 202 | (* in 203 | { page= Reactive.var page 204 | ; version_string= None 205 | ; dev_mode= Reactive.var dev_mode 206 | ; explorer_input= Reactive.var explorer_input } *) 207 | 208 | let set_page state p () = Reactive.set (get state).page p 209 | let page state = (get state).page |> Reactive.get 210 | let explorer_result ctxt = (get ctxt).explorer_result 211 | 212 | let current_page_is_not state p = 213 | Reactive.get (get state).page 214 | |> Reactive.map ~f:Poly.(function `Page pp | `Changing_to pp -> pp <> p) 215 | 216 | let dev_mode state = System.dev_mode state 217 | let dev_mode_bidirectional = System.dev_mode_bidirectional 218 | let explorer_input state = (get state).explorer_input |> Reactive.get 219 | let explorer_input_value state = (get state).explorer_input |> Reactive.peek 220 | let set_explorer_input state = (get state).explorer_input |> Reactive.set 221 | 222 | let explorer_input_bidirectional state = 223 | (get state).explorer_input |> Reactive.Bidirectional.of_var 224 | 225 | let save_editor_content ctxt = 226 | Local_storage.write_file ctxt local_storage_filename 227 | ~content:(Reactive.peek (get ctxt).editor_content) 228 | 229 | let set_editor_content state v = Reactive.set (get state).editor_content v 230 | let set_current_network state v = Reactive.set (get state).current_network v 231 | let current_network state = Reactive.peek (get state).current_network 232 | 233 | let load_editor_content ctxt = 234 | match Local_storage.read_file ctxt local_storage_filename with 235 | | None -> set_editor_content ctxt "" 236 | | Some s -> set_editor_content ctxt s 237 | 238 | let editor_content ctxt = 239 | let s = get ctxt in 240 | if Reactive.peek s.editor_should_load then ( 241 | load_editor_content ctxt; 242 | Reactive.set s.editor_should_load false); 243 | (get ctxt).editor_content |> Reactive.Bidirectional.of_var 244 | 245 | let editor_mode ctxt = Reactive.get (get ctxt).editor_mode 246 | let set_editor_mode ctxt = Reactive.set (get ctxt).editor_mode 247 | 248 | let transform_editor_content ctxt ~f = 249 | let v = (get ctxt).editor_content in 250 | let changed = f (Reactive.peek v) in 251 | Reactive.set v changed 252 | 253 | (* 254 | Automatic saving to make one day? 255 | let variable = (get ctxt).editor_content in 256 | Reactive.Bidirectional.make (Reactive.get variable) (fun v -> 257 | Local_storage.write_file ctxt local_storage_filename v ; 258 | Reactive.set variable v) 259 | *) 260 | 261 | let token_address ctxt = (get ctxt).token_address 262 | let token_id ctxt = (get ctxt).token_id 263 | 264 | let check_micheline_indentation ctxt = 265 | Reactive.peek (get ctxt).check_micheline_indentation 266 | 267 | let check_micheline_indentation_bidirectional ctxt = 268 | Reactive.Bidirectional.of_var (get ctxt).check_micheline_indentation 269 | 270 | let always_show_multimedia ctxt = 271 | Reactive.peek (get ctxt).always_show_multimedia 272 | 273 | let get_always_show_multimedia ctxt = 274 | Reactive.get (get ctxt).always_show_multimedia 275 | 276 | let get_show_token_details ctxt = Reactive.get (get ctxt).show_token_details 277 | 278 | let always_show_multimedia_bidirectional ctxt = 279 | Reactive.Bidirectional.of_var (get ctxt).always_show_multimedia 280 | 281 | let make_fragment ?(side_effects = true) ctxt = 282 | (* WARNING: for now it is important for this to be attached "somewhere" 283 | in the DOM. 284 | WARNING-2: this function is used for side effects unrelated to the 285 | fragment too (system.dev_mode). 286 | *) 287 | let open Js_of_ocaml.Url in 288 | let state = get ctxt in 289 | let dev = dev_mode ctxt in 290 | let page = 291 | Reactive.get state.page 292 | |> Reactive.map ~f:(function `Page p | `Changing_to p -> p) 293 | in 294 | let explorer_input = Reactive.get state.explorer_input in 295 | let editor_input = Reactive.get state.editor_content in 296 | let explorer_go = Reactive.get state.explorer_go in 297 | Reactive.( 298 | dev ** page ** explorer_input ** explorer_go ** editor_input 299 | ** get state.editor_mode ** get state.token_address ** get state.token_id 300 | ** get state.check_micheline_indentation 301 | ** get state.editor_load 302 | ** get state.always_show_multimedia 303 | ** get state.show_token_details) 304 | |> Reactive.map 305 | ~f:(fun 306 | ( dev_mode, 307 | ( page, 308 | ( explorer_input, 309 | ( explorer_go, 310 | ( editor_input, 311 | ( editor_mode, 312 | ( token_address, 313 | ( token_id, 314 | ( check_micheline_indentation, 315 | ( editor_load, 316 | (always_show_multimedia, show_token_details) ) 317 | ) ) ) ) ) ) ) ) ) 318 | -> 319 | let now = 320 | Fragment.( 321 | let editor_input = 322 | if String.length editor_input < 40 then editor_input else "" 323 | in 324 | make ~page ~dev_mode ~explorer_input ~explorer_go ~editor_input 325 | ~token_address ~token_id ~editor_mode ~always_show_multimedia 326 | ~show_token_details ~check_micheline_indentation ~editor_load) 327 | in 328 | if side_effects then ( 329 | let current = Js_of_ocaml.Url.Current.get_fragment () in 330 | dbgf "Updating fragment %S → %a" current Fragment.pp now; 331 | Current.set_fragment (Fragment.to_string now)); 332 | now) 333 | 334 | let link_to_editor ctxt content ~text = 335 | let open Meta_html in 336 | let fragment = make_fragment ~side_effects:false ctxt in 337 | let href = 338 | Reactive.(map fragment) ~f:(fun frg -> 339 | "#" ^ Fragment.(to_string (change_for_page frg Page.Editor))) 340 | in 341 | a 342 | ~a: 343 | [ 344 | H5.a_href href; 345 | H5.a_onclick 346 | (Tyxml_lwd.Lwdom.attr (fun _ -> 347 | Reactive.set (get ctxt).editor_should_load false; 348 | set_editor_content ctxt text; 349 | set_page ctxt (`Changing_to Page.Editor) (); 350 | false)); 351 | ] 352 | content 353 | 354 | let link_to_explorer ctxt content ~search = 355 | let open Meta_html in 356 | let fragment = make_fragment ~side_effects:false ctxt in 357 | let href = 358 | Reactive.(map fragment) ~f:(fun frg -> 359 | "#" ^ Fragment.(to_string (change_for_page frg Page.Explorer))) 360 | in 361 | a 362 | ~a: 363 | [ 364 | H5.a_href href; 365 | H5.a_onclick 366 | (Tyxml_lwd.Lwdom.attr (fun _ -> 367 | Reactive.set (get ctxt).explorer_go true; 368 | Reactive.set (get ctxt).explorer_went false; 369 | set_explorer_input ctxt search; 370 | set_page ctxt (`Changing_to Page.Explorer) (); 371 | false)); 372 | ] 373 | content 374 | 375 | let link_to_token_viewer ctxt content ~token_address ~token_id = 376 | let open Meta_html in 377 | let fragment = make_fragment ~side_effects:false ctxt in 378 | let href = 379 | Reactive.(map fragment) ~f:(fun frg -> 380 | "#" ^ Fragment.(to_string (change_for_page frg Page.Token_viewer))) 381 | in 382 | a 383 | ~a: 384 | [ 385 | H5.a_href href; 386 | H5.a_onclick 387 | (Tyxml_lwd.Lwdom.attr (fun _ -> 388 | Reactive.set (get ctxt).token_address token_address; 389 | Reactive.set (get ctxt).token_id token_id; 390 | set_page ctxt (`Changing_to Page.Token_viewer) (); 391 | false)); 392 | ] 393 | content 394 | 395 | let if_explorer_should_go state f = 396 | if 397 | (get state).explorer_go |> Lwd.peek 398 | && not ((get state).explorer_went |> Lwd.peek) 399 | then ( 400 | Lwd.set (get state).explorer_went true; 401 | f ()) 402 | else () 403 | 404 | module Examples = struct 405 | let alchememist_blockchain_adventures = "KT1W4wh1qDc2g22DToaTfnCtALLJ7jHn38Xc" 406 | let hicetnunc_version_2 = "KT1RJ6PbjHpwc3M5rw5s2Nbmefwbuwbdxton" 407 | let kalamint = "KT1EpGgjQs73QfFJs9z7m1Mxm5MTnpC2tqse" 408 | 409 | type item = string * string 410 | 411 | type t = { 412 | contracts : item list; 413 | uris : item list; 414 | metadata_blobs : item list; 415 | michelson_bytes : item list; 416 | michelson_concretes : item list; 417 | } 418 | 419 | let aggl ?(dev = false) () = 420 | let all = ref [] in 421 | let add v desc = all := (v, desc) :: !all in 422 | let add_dev v desc = if dev then add v desc else () in 423 | let all () = List.rev !all in 424 | (add, add_dev, all) 425 | 426 | let get state = 427 | let https_ok = 428 | "https://raw.githubusercontent.com/oxheadalpha/TZComet/8d95f7b/data/metadata_example0.json" 429 | in 430 | let hash_of_https_ok = 431 | (* `sha256sum data/metadata_example0.json` → Achtung, the URL 432 | above takes about 5 minutes to be up to date with `master` *) 433 | "5fba33eccc1b310add3e66a76fe7c9cd8267b519f2f78a88b72868936a5cb28d" 434 | in 435 | let sha256_https_ok = 436 | Fmt.str "sha256://0x%s/%s" hash_of_https_ok (Uri.pct_encode https_ok) 437 | in 438 | let sha256_https_ko = 439 | Fmt.str "sha256://0x%s/%s" 440 | (String.tr hash_of_https_ok ~target:'9' ~replacement:'1') 441 | (Uri.pct_encode https_ok) 442 | in 443 | dev_mode state 444 | |> Reactive.map ~f:(fun dev -> 445 | let kt1, kt1_dev, kt1_all = aggl ~dev () in 446 | let uri, uri_dev, uri_all = aggl ~dev () in 447 | let mtb, _mtb_dev, mtb_all = aggl ~dev () in 448 | let mby, mby_dev, mby_all = aggl ~dev () in 449 | let tzc, tzc_dev, tzc_all = aggl ~dev () in 450 | kt1 alchememist_blockchain_adventures 451 | "An NFT collection by “The Alchememist” on Mainnet."; 452 | kt1 hicetnunc_version_2 453 | "The version 2 of Hic Et Nunc's collection on Mainnet."; 454 | kt1_dev kalamint "Kalamint's NFT collection on Mainnet (invalid)."; 455 | kt1_dev "KT1JZFiBBt6Xzu2XEbXdBPt8Y624tN1Comet" 456 | "Should not exist any where."; 457 | let one_off_chain_view = 458 | let kt1 = kt1_dev in 459 | (* BEGIN The ones made by ./please.sh deploy examples all *) 460 | let de0 = "KT1EkhJrwU6XcBbNnR7N34vB75Q97CXvW687" in 461 | kt1 de0 "Empty contract"; 462 | let empty_metadata = "KT1GosuTFssM2k6jvVVF8m27uMKX2H5Nno3V" in 463 | kt1 empty_metadata "The missing metadata one."; 464 | let wrong_uri = "KT1L9NrvkSFLiRyz5m4zmT5MHM7k7yf7gPXX" in 465 | kt1 wrong_uri "Has a URI that points nowhere."; 466 | let empty_but_valid = "KT19ANJVafahVicNTEC1dsGkEPSVizkPsvWe" in 467 | kt1 empty_but_valid "Empty, but valid metadata."; 468 | let just_version = "KT19b2ZYsm6RK1691En4tsVH2uPw4yJvcASa" in 469 | kt1 just_version "Has just a version string."; 470 | let with_basics = "KT19MiqX1i3Lf4L58rDymzKYBCfKFMVT3u2a" in 471 | kt1 with_basics "This contract has few more fields."; 472 | let one_off_chain_view = "KT1C7nECC1BGZ163mRcvPvTi7AUvx18URMZ6" in 473 | kt1 one_off_chain_view 474 | "This contract has a one off-chain-view which is actually \ 475 | reused for the error-translation."; 476 | let bunch_of_views = "KT18oQxCaVcYTgjfF8Rzgr49ZMfM2fnUPZj3" in 477 | kt1 bunch_of_views "This contract has a bunch of off-chain-views."; 478 | let invalid_uri = "KT1T1qLqHCTdhQttfLzxYCvtfDp9v9kXUP6j" in 479 | kt1 invalid_uri "Has a URI that is invalid."; 480 | let invalid_version_field = 481 | "KT1FmdGZCkH31d4vnNswLc1LVZCxocBwTnBt" 482 | in 483 | kt1 invalid_version_field 484 | "Points to invalid metadata (wrong version field)."; 485 | let views_return_bytes = "KT1J8Kq8uNHY7GrPfGtTqNBEupNu9i2vJ7yc" in 486 | kt1 views_return_bytes 487 | "This contract has bytes-returning off-chain-views."; 488 | (* END of the generated ones. *) 489 | one_off_chain_view 490 | in 491 | uri https_ok "A valid HTTPS URI."; 492 | uri sha256_https_ok "A valid SHA256+HTTPS URI."; 493 | uri_dev sha256_https_ko 494 | "A valid SHA256+HTTPS URI but the hash is not right."; 495 | uri 496 | (Fmt.str "tezos-storage://%s/contents" one_off_chain_view) 497 | "An on-chain pointer to metadata."; 498 | uri_dev 499 | (Fmt.str "tezos-storage://%s.NetXrtZMmJmZSeb/contents" 500 | one_off_chain_view) 501 | "An on-chain pointer to metadata with chain-id."; 502 | uri_dev "tezos-storage:/here" 503 | "An on-chain pointer that requires a KT1 in context."; 504 | uri "ipfs://QmWDcp3BpBjvu8uJYxVqb7JLfr1pcyXsL97Cfkt3y1758o" 505 | "An IPFS URI to metadata JSON."; 506 | uri_dev "ipfs://ldisejdse-dlseidje" "An invalid IPFS URI."; 507 | mtb "{}" "Empty, but valid, Metadata"; 508 | mtb {json|{"description": "This is just a description."}|json} 509 | "Metadata with just a description."; 510 | (* let all_mtb_from_lib = 511 | let open Tezos_contract_metadata.Metadata_contents in 512 | let rec go n = 513 | try (n, Example.build n) :: go (n + 1) with _ -> [] in 514 | go 0 in 515 | List.iter all_mtb_from_lib ~f:(fun (ith, v) -> 516 | mtb_dev 517 | (Tezos_contract_metadata.Metadata_contents.to_json v) 518 | (Fmt.str "Meaningless example #%d" ith) ) ; *) 519 | mby "0x05030b" "The Unit value, PACKed."; 520 | mby 521 | "050707010000000c486\n\ 522 | 56c6c6f20576f726c64\n\ 523 | 2102000000260704010\n\ 524 | 0000003666f6f010000\n\ 525 | 0003626172070401000\n\ 526 | 0000474686973010000\n\ 527 | 000474686174" 528 | "Michelson with a (map string string)."; 529 | mby_dev "0x05" "Empty but still Michelsonian bytes."; 530 | (let tzself f c = Fmt.kstr (f c) "Michelson %S" c in 531 | List.iter ~f:(tzself tzc) 532 | [ "Unit"; "12"; "\"hello world\""; "(Pair 42 51)" ]; 533 | List.iter ~f:(tzself tzc_dev) 534 | [ "Unit 12"; "\"hœlló wörld\""; "(Pair 42 51 \"meh\")" ]); 535 | { 536 | contracts = kt1_all (); 537 | uris = uri_all (); 538 | metadata_blobs = mtb_all (); 539 | michelson_bytes = mby_all (); 540 | michelson_concretes = tzc_all (); 541 | }) 542 | 543 | type 'weight_type candidate = { 544 | weight : 'weight_type; 545 | name : string; 546 | address : string; 547 | tokens : [ `Range of int * int ]; 548 | } 549 | 550 | let range_of_tuple (weight, name, address, min_token, max_token) = 551 | { weight; name; address; tokens = `Range (min_token, max_token) } 552 | 553 | let tokens_global = 554 | let absolute_weights = 555 | (* weight, name, kt1, min-token, max-token *) 556 | [ 557 | range_of_tuple 558 | (100, "Alchememist", alchememist_blockchain_adventures, 0, 15); 559 | range_of_tuple (600, "HicEtNunc", hicetnunc_version_2, 300, 564520); 560 | range_of_tuple (200, "Kalamint", kalamint, 1, 62345); 561 | range_of_tuple 562 | (100, "OpenMinter-0", "KT1PuASz2FWF7fhdWidFpV5v9zqTVtYxexAS", 0, 4); 563 | range_of_tuple 564 | (100, "OpenMinter-1", "KT1QcxwB4QyPKfmSwjH1VRxa6kquUjeDWeEy", 0, 48); 565 | range_of_tuple 566 | (150, "OpenMinter-2", "KT1JBThDEqyqrEHimhxoUBCSnsKAqFcuHMkP", 0, 179); 567 | range_of_tuple 568 | (100, "OpenMinter-4", "KT1Wb8YcWDZeFSeq8YXjaZduXGZvEodYEBzg", 0, 23); 569 | ] 570 | in 571 | let total = 572 | List.fold absolute_weights ~init:0 ~f:(fun prev candidate -> 573 | prev + candidate.weight) 574 | in 575 | List.map absolute_weights ~f:(fun candidate -> 576 | { 577 | candidate with 578 | weight = Float.(of_int candidate.weight / of_int total); 579 | }) 580 | 581 | let random_token (_ : _ Context.t) = 582 | let chosen_one = 583 | List.find tokens_global ~f:(fun candidate -> 584 | let open Float in 585 | Random.float 1. < candidate.weight) 586 | |> function 587 | | Some s -> s 588 | | None -> List.random_element_exn tokens_global 589 | in 590 | ( chosen_one.address, 591 | match chosen_one.tokens with `Range (m, x) -> Random.int_incl m x ) 592 | end 593 | 594 | module Metadata_metadata = struct 595 | let jpegs = 596 | List.map 597 | [ 598 | "ipfs://QmeayPYZeicG1MJSKoVnVM54qafYcvCCZbYLZuNdg36GWF"; 599 | "ipfs://QmXmktVYyJ3AtzsDYAZCgpbL9MtPGv2U95wECaXcRL3Cqv"; 600 | "ipfs://QmYGFcSb4z3TmpR4C6tyDWFzSWFCdqzcnjkBPeSwNZTex6"; 601 | ] ~f:(fun uri -> (Blob.Format.jpeg, uri)) 602 | 603 | let static_sfw_multimedia : (Blob.Format.t * string) list = jpegs 604 | 605 | let sfw_multimedia (_ctxt : _ Context.t) uri = 606 | Lwt.return 607 | (List.find_map static_sfw_multimedia ~f:(function 608 | | fmt, k when String.equal k uri -> Some fmt 609 | | _ -> None)) 610 | end 611 | --------------------------------------------------------------------------------