diff --git a/devtools/proto_manager/command.ml b/devtools/proto_manager/command.ml index 07e0c0fae0e76fbb5ee834630cb91c19a58b5a0c..c0c4f137b7b3e39bcb3a1c895fc909fc16cc5123 100644 --- a/devtools/proto_manager/command.ml +++ b/devtools/proto_manager/command.ml @@ -7,6 +7,12 @@ type t = {describe : State.t -> State.t; execute : State.t -> State.t} +let create ~desc execute = {describe = desc; execute} + +let execute c state = c.execute state + +let describe c state = c.describe state + module FIFO = struct type elt = t @@ -14,23 +20,23 @@ module FIFO = struct let empty = [] - let register c l = c :: l - let describe l state = List.fold_right (fun c state -> c.describe state) l state let execute l state = List.fold_right (fun c state -> c.execute state) l state - - let to_command ?desc t = - let describe = - match desc with Some describe -> describe | None -> describe t - in - {describe; execute = execute t} end +let register c l = c :: l + +let of_fifo ?desc t = + let describe = + match desc with Some describe -> describe | None -> FIFO.describe t + in + {describe; execute = FIFO.execute t} + module Shell = struct let create ~__LOC__ ?desc ?error_msg shell = - let describe = + let desc = match desc with | Some desc -> desc | None -> @@ -48,7 +54,7 @@ module Shell = struct State.exit ~__LOC__ state) ; state in - {describe; execute} + create ~desc execute end module File = struct @@ -86,12 +92,31 @@ module File = struct Stdlib.exit 1) ; state); } + + let ocamlformat ~__LOC__ files = + let desc state = + Log.printfln + "Format %a" + Format.( + pp_print_list + ~pp_sep:(fun fmt () -> pp_print_string fmt ", ") + pp_print_string) + (files state) ; + state + in + let execute state = + Utils.File.Content.ocamlformat + ~error:(fun () -> State.exit ~__LOC__ state) + (files state) ; + state + in + create ~desc execute end module Git = struct - let git ({git_dir; _} : State.t) cmd = "git -C " ^ git_dir ^ " " ^ cmd + let git state cmd = "git -C " ^ State.get_git_dir state ^ " " ^ cmd - let check_no_uncommitted_changes = + let check_no_uncommitted_changes ~__LOC__ = Shell.create ~__LOC__ ~error_msg:"Git tree is not clean, please commit or stash your changes" @@ -105,20 +130,26 @@ module Git = struct fi|} (git state "status --porcelain")) - let commit_no_hooks message = - let open FIFO in + let commit ~__LOC__ ?no_verify get_msg = let commands = FIFO.empty - |> register (Shell.create ~__LOC__ (fun state -> git state {|add ."|})) + |> register (Shell.create ~__LOC__ (fun state -> git state {|add .|})) |> register (Shell.create ~__LOC__ (fun state -> - (* if pre-commit hooks are enabled, do not run them *) + let no_verify = + match no_verify with + | Some () -> + (* if pre-commit hooks are enabled, do not run them *) + " --no-verify" + | None -> "" + in git state (Format.asprintf - {|commit -m "%s/%s" --no-verify|} - state.capitalize_label - message))) + {|commit -m "%s/%s"%s|} + (State.Target.get_constructor state) + (get_msg state) + no_verify))) |> register { describe = @@ -129,8 +160,8 @@ module Git = struct (fun state -> Log.printfln "@{Created commit:@{ %s/%s@}@}" - state.capitalize_label - message ; + (State.Target.get_constructor state) + (get_msg state) ; state); } |> register @@ -138,13 +169,61 @@ module Git = struct describe = (fun state -> Log.printfln "increment commit counter" ; - {state with commits = state.commits + 1}); - execute = (fun state -> {state with commits = state.commits + 1}); + State.incr_commit_count state); + execute = (fun state -> State.incr_commit_count state); } in - to_command + of_fifo ~desc:(fun state -> - Log.printfln "commit no hooks with message %s" message ; + Log.printfln "commit no hooks with message %s" (get_msg state) ; state) commands + + let cp ~__LOC__ get_src get_dest = + Shell.create + ~__LOC__ + ~desc:(fun state -> + Log.printfln "copy versioned files of %s" (get_src state) ; + state) + (fun state -> + git state (Format.asprintf {|archive HEAD "%s"|} (get_src state)) + ^ Format.asprintf {| | tar -x -C "%s"|} (get_dest state)) +end + +module Log = struct + let printfln get_msg = + let desc state = + Log.printfln "Log: %s" (get_msg state) ; + state + in + create ~desc (fun state -> + Log.printfln "%s" (get_msg state) ; + state) + + let cyan get_msg = + let desc state = + Log.printfln "Log: %s" (get_msg state) ; + state + in + create ~desc (fun state -> + Log.cyan "%s" (get_msg state) ; + state) + + let yellow get_msg = + let desc state = + Log.printfln "Log: %s" (get_msg state) ; + state + in + create ~desc (fun state -> + Log.yellow "%s" (get_msg state) ; + state) + + let blue get_msg = + let desc state = + Log.printfln "Log: %s" (get_msg state) ; + state + in + create ~desc (fun state -> + Log.blue "%s" (get_msg state) ; + state) end diff --git a/devtools/proto_manager/command.mli b/devtools/proto_manager/command.mli index 7d60545ec051a479b472216d4d51e338838102aa..83a85d5e263fb326c825ed97caaae10050b05c38 100644 --- a/devtools/proto_manager/command.mli +++ b/devtools/proto_manager/command.mli @@ -5,21 +5,33 @@ (* *) (*****************************************************************************) -(** [t] is a command that can be described or executed. *) -type t = {describe : State.t -> State.t; execute : State.t -> State.t} +(** [t] is a command. + It can be: + - registered, + - described or, + - executed. + Commands are not executed at their creation. + To execute a command see [execute]. *) +type t + +(** [create ?desc exec] returns a new command. *) +val create : desc:(State.t -> State.t) -> (State.t -> State.t) -> t + +(** [execute c state] executes [c] with [state]. *) +val execute : t -> State.t -> State.t + +(** [describe c state] prints the description of [c] with [state]. *) +val describe : t -> State.t -> State.t (** Module that represent a queue of commands. This queue can be encapsulated into a single command. *) module FIFO : sig - type elt = t + type elt type t val empty : t - (** [register elt t] adds [elt] in the FIFO. *) - val register : elt -> t -> t - (** [describe t state] applies describe function of each command contained in queue in FIFO order. *) val describe : t -> State.t -> State.t @@ -27,12 +39,29 @@ module FIFO : sig (** [describe t state] applies execute function of each command contained in queue in FIFO order. *) val execute : t -> State.t -> State.t +end + +(** [register c cmds] adds [c] in [cmds]. *) +val register : t -> FIFO.t -> FIFO.t + +(** [to_command ?desc cmds] encapsulates [cmds] in a single command using + [FIFO.describe] and [FIFO.execute]. - (** [to_command ?desc t] encapsulates [t] in a single command using - [describe] and [execute]. + If [desc] is provided, it is used instead of [FIFO.describe]. *) +val of_fifo : ?desc:(State.t -> State.t) -> FIFO.t -> t - If [desc] is provided, it is used instead of [describe]. *) - val to_command : ?desc:(State.t -> State.t) -> t -> elt +module Log : sig + (** [log get_msg] creates a command that logs the value returned by [get_msg]. *) + val printfln : (State.t -> string) -> t + + (** Same as [log] but using cyan color. *) + val cyan : (State.t -> string) -> t + + (** Same as [log] but using yellow color. *) + val yellow : (State.t -> string) -> t + + (** Same as [log] but using blue color. *) + val blue : (State.t -> string) -> t end (** Module that contains commands related to shell commands. *) @@ -60,12 +89,23 @@ module File : sig [get_path] does not exist. If it does, call [State.exit]. *) val check_not_exist : ?error_msg:(State.t -> string) -> (State.t -> string) -> t + + val ocamlformat : __LOC__:string -> (State.t -> string list) -> t end module Git : sig + (** [git state args] returns a git command with [args] running in the + [state]’s git repository. *) + val git : State.t -> string -> string + (** Command that checks that there is no uncommitted changes. *) - val check_no_uncommitted_changes : t + val check_no_uncommitted_changes : __LOC__:string -> t + + (** [commit ~__LOC__ ?no_verify msg] add changes to stage and commit them. If + [no_verify] is provided, pre-commit are not run. *) + val commit : __LOC__:string -> ?no_verify:unit -> (State.t -> string) -> t - (** [commit_no_hooks msg] add changes to stage and commit them.*) - val commit_no_hooks : string -> t + (** [cp ~__LOC__ get_src get_dest] returns a command that copies the + versioned files from [get_src] to [get_dest]. *) + val cp : __LOC__:string -> (State.t -> string) -> (State.t -> string) -> t end diff --git a/devtools/proto_manager/log.ml b/devtools/proto_manager/log.ml index ed594448e1d1bcbc23565b92f029573ac4a3098c..646c43c41a1a32a252a6cb0dc91910db276b5e7d 100644 --- a/devtools/proto_manager/log.ml +++ b/devtools/proto_manager/log.ml @@ -79,5 +79,7 @@ let green fmt = Format.kasprintf (fun msg -> printfln "@{%s@}" msg) fmt let cyan fmt = Format.kasprintf (fun msg -> printfln "@{%s@}" msg) fmt +let yellow fmt = Format.kasprintf (fun msg -> printfln "@{%s@}" msg) fmt + let magenta fmt = Format.kasprintf (fun msg -> printfln "@{%s@}" msg) fmt diff --git a/devtools/proto_manager/log.mli b/devtools/proto_manager/log.mli index 78122c56296d29e70a304b41b72ad0f491ba032c..00e8df76a0c1ad9af8ca0f3897ab2c910a5af800 100644 --- a/devtools/proto_manager/log.mli +++ b/devtools/proto_manager/log.mli @@ -48,5 +48,8 @@ val green : ('a, Format.formatter, unit) format -> 'a (* Same as [printfln] but prints in cyan. *) val cyan : ('a, Format.formatter, unit) format -> 'a +(* Same as [printfln] but prints in yellow. *) +val yellow : ('a, Format.formatter, unit) format -> 'a + (* Same as [printfln] but prints in magenta. *) val magenta : ('a, Format.formatter, unit) format -> 'a diff --git a/devtools/proto_manager/proto_manager.ml b/devtools/proto_manager/proto_manager.ml index 4cc9a3f928d4cb29960fd8d67b3718cd1484a8db..88446c22d0e1a7c1f3562ab674e47ae1619efdc7 100644 --- a/devtools/proto_manager/proto_manager.ml +++ b/devtools/proto_manager/proto_manager.ml @@ -5,13 +5,15 @@ (* *) (*****************************************************************************) -let ( // ) = Filename.concat +open Utils.Infix + +let error ~__LOC__ state () = State.exit ~__LOC__ state let tmp_proto_snapshot_dir = Filename.get_temp_dir_name () // "tezos_proto_snapshot" let tezt_protocol_file (state : State.t) = - state.git_dir // "tezt" // "lib_tezos" // "protocol.ml" + State.make_absolute ("tezt" // "lib_tezos" // "protocol.ml") state type pattern = {string : string; regex : Re.re} @@ -21,76 +23,50 @@ let protocol_pattern = let string = {|[a-z]+[0-9]*|} in {string; regex = Re.Perl.(compile @@ re ("^" ^ string ^ "$"))} -let check_proto_name get_proto_name pattern = - Command. - { - describe = - (fun state -> - Log.printfln - "Check that the protocol name '%s' is of form '%a'" - (get_proto_name state) - pp_pattern - pattern ; - state); - execute = - (fun state -> - if not (Re.execp pattern.regex (get_proto_name state)) then ( - Log.error - "Protocol name '%s' should be of the form '%a'" - (get_proto_name state) - pp_pattern - pattern ; - Stdlib.exit 1) ; - state); - } - -let check_arguments target_pattern = - let open Command.FIFO in +let check_proto_name proto_name pattern = + if not (Re.execp pattern.regex proto_name) then ( + Log.error + "Protocol name '%s' should be of the form '%a'" + proto_name + pp_pattern + pattern ; + Stdlib.exit 1) + +let check_arguments = let commands = - empty + Command.FIFO.empty |> (* Check source and target *) - register - { - describe = - (fun state -> - Log.printfln "check that protocol source and target are different" ; - state); - execute = - (fun state -> - if state.protocol_source = state.protocol_target then ( - Log.error "protocol source and target should be different" ; - Stdlib.exit 1) ; - state); - } - |> register - (check_proto_name - (fun state -> state.protocol_source) - protocol_pattern) - |> register - (check_proto_name (fun state -> state.protocol_target) target_pattern) - |> register + Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "check that protocol source and target are different" ; + state) + (fun state -> + if State.eq_source_target state then ( + Log.error "protocol source and target should be different" ; + Stdlib.exit 1) ; + state)) + |> Command.register (Command.File.check_exists (fun state -> - (state.git_dir // "src" // "proto_") ^ state.protocol_source)) - |> register + State.Source.Dir.Absolute.get_src_proto state)) + |> Command.register (Command.File.check_exists (fun state -> - state.git_dir // "docs" // state.protocol_source)) - |> register + State.Source.Dir.Absolute.get_doc state)) + |> Command.register (Command.File.check_not_exist (fun state -> - state.git_dir // "src" - // Format.asprintf "proto_%a" State.pp_label state.target_label)) - |> register + State.Target.Dir.Absolute.get_src_proto state)) + |> Command.register (Command.File.check_not_exist (fun state -> - state.git_dir // "docs" - // Format.asprintf "%a" State.pp_label_name state.target_label)) + State.Target.Dir.Absolute.get_doc state)) |> (* Check git directory *) - register + Command.register (Command.File.check_exists ~error_msg:(fun _state -> "octez-protocol-compiler not found, compile it") - (fun state -> state.git_dir // "octez-protocol-compiler")) - |> register Command.Git.check_no_uncommitted_changes + (fun state -> State.make_absolute "octez-protocol-compiler" state)) + |> Command.register (Command.Git.check_no_uncommitted_changes ~__LOC__) in - to_command + Command.of_fifo ~desc:(fun state -> Log.printfln "Check the arguments" ; state) @@ -100,70 +76,667 @@ let clean_tmp_dir = Command.Shell.create ~__LOC__ (fun _state -> "rm -rf " ^ tmp_proto_snapshot_dir) +let raw_copy = + let commands = + Command.FIFO.empty + |> Command.register + (Command.Log.printfln (fun state -> + Format.asprintf + "Copying %s to %s" + (State.Source.Dir.Relative.get_src_proto state) + (State.Target.Dir.Relative.get_src_proto state))) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "create temp directory" ; + state) + (fun state -> + Sys.mkdir tmp_proto_snapshot_dir 0o700 ; + state)) + |> Command.register + (Command.Git.cp + ~__LOC__ + (fun state -> State.Source.Dir.Absolute.get_src_proto state) + (fun _state -> tmp_proto_snapshot_dir)) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "move sources from temp to git repository." ; + state) + (fun state -> + let _ = + Utils.Process.shell + ~error:(error ~__LOC__ state) + (Format.asprintf + "mv %s %s" + (tmp_proto_snapshot_dir + // State.Source.Dir.Relative.get_src_proto state) + (State.Target.Dir.Absolute.get_src_proto state)) + in + state)) + |> Command.register + (Command.Shell.create ~__LOC__ (fun _state -> + "rm -rf " ^ tmp_proto_snapshot_dir)) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln {|delete all auto generated dune files.|} ; + state) + (fun state -> + let files = + Utils.File.find + ~error:(error ~__LOC__ state) + ~dir:(State.Target.Dir.Absolute.get_src_proto state) + ~opts: + {|-name dune -exec grep -l "; This file was automatically generated, do not edit." {} \;|} + in + (match files with + | [] -> Log.warning "No auto-generated dune file found." + | _ -> ()) ; + List.iter Sys.remove files ; + state)) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun state -> + "src: copy from " ^ State.Source.Dir.Relative.get_src_proto state)) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "Copy and clean protocol sources" ; + state) + commands + +let set_current_version = + let commands = + (* set current version + Starting from 018 the version value moved to `constants_repr`. To be + able to snapshot older protocol the `raw_context` file is kept even + if it is not strictly needed anymore. *) + Command.FIFO.empty + |> Command.register + (Command.Log.printfln (fun _state -> + "Setting current version in raw_context and proxy")) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "" ; + state) + (fun state -> + let files = + [ + State.Target.Dir.Absolute.get_lib_protocol state + // "constants_repr.ml"; + State.Target.Dir.Absolute.get_lib_protocol state + // "raw_context.ml"; + State.Target.Dir.Absolute.get_src_proto state + // "lib_client" // "proxy.ml"; + ] + in + let re = + Re.( + seq + [ + str {|let version_value = "|}; + str (State.Source.get_version_value state); + rep (compl [set {|"|}]); + str {|"|}; + ]) + in + let regex = Re.(compile re) in + let replacements = + Utils.File.Content.replace_string_all + ~regex + ~by: + (Format.asprintf + {|let version_value = "%s"|} + (State.Target.get_version_value state)) + files + in + if replacements = 0 then + Log.warning "No current version to set found." ; + state)) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun _state -> + "src: set current version")) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "set current version" ; + state) + commands + +let add_predecessor = + let commands = + let raw_context_file state = + State.Target.Dir.Absolute.get_lib_protocol state // "raw_context.ml" + in + let files (state : State.t) = + [ + raw_context_file state; + State.Target.Dir.Absolute.get_lib_protocol state // "raw_context.mli"; + State.Target.Dir.Absolute.get_lib_protocol state // "init_storage.ml"; + ] + in + Command.FIFO.empty + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "add add_predecessor" ; + state) + (fun state -> + let by = + Format.asprintf + {|else if Compare.String.(s = "%s") then return (%s, ctxt)|} + (State.Target.get_name state) + (State.Target.get_constructor state) + in + let regex = + Re.( + compile + (seq + [ + rep notnl; + str "return ("; + str (State.Source.get_constructor state); + str ", ctxt)"; + rep notnl; + ])) + in + let replacements = + Utils.File.Content.replace_string + ~regex + ~by + (raw_context_file state) + in + if replacements <> 1 then Log.warning "No predecessor added" ; + state)) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "Replace constructor occurences in files" ; + state) + (fun state -> + let regex = + Re.(compile (str (State.Source.get_constructor state))) + in + let by = State.Target.get_constructor state in + let replacements = + Utils.File.Content.replace_string_all ~regex ~by (files state) + in + if replacements = 0 then Log.warning "No Variant found" ; + state)) + |> Command.register + (Command.File.ocamlformat ~__LOC__ (fun state -> files state)) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun state -> + Format.asprintf + "src: adapt %s predecessors" + (State.Target.get_constructor state))) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "add predecessors" ; + state) + commands + +let compute_and_replace_hash = + let commands = + Command.FIFO.empty + |> Command.register (Command.Log.cyan (fun _state -> "Computing hash")) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln + "Hash %s" + (State.Target.Dir.Relative.get_src_proto state) ; + State.set_target_hash ~hash:(Some "HASH") state) + (fun state -> + let bin = "octez-protocol-compiler" in + let output = + Utils.Process.exec + ~error:(error ~__LOC__ state) + ~dir:(State.get_git_dir state) + ~bin + ~args: + [ + "-hash-only"; + State.Target.Dir.Absolute.get_lib_protocol state; + ] + in + let hash = Utils.Process.stdout_by_line output in + let hash = + match hash with + | [hash] -> hash + | _ -> + Log.error "Invalid hash computed by %s" bin ; + State.exit ~__LOC__ state + in + let state = State.set_target_hash ~hash:(Some hash) state in + Log.magenta + "Hash computed: %s" + (State.Target.get_hash ~__LOC__ state) ; + Log.magenta + "Short hash: %s" + (State.Target.get_hash ~__LOC__ ~short:() state) ; + state)) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "replace fake hash with real hash in TEZOS_PROTOCOL" ; + state) + (fun state -> + let regex = + Re.( + compile + (seq + [str {|"hash": "|}; rep (compl [set {|"|}]); str {|",|}])) + in + let by = + Format.asprintf + {|"hash": "%s",|} + (State.Target.get_hash ~__LOC__ state) + in + let replacements = + Utils.File.Content.replace_string + ~regex + ~by + (State.Target.Dir.Absolute.get_lib_protocol state + // "TEZOS_PROTOCOL") + in + if replacements = 0 then + Log.warning {|No field "hash" found in "TEZOS_PROTOCOL"|} + else if replacements <> 1 then + Log.warning {|Multiple fields "hash" found in "TEZOS_PROTOCOL"|} ; + state)) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun state -> + Format.asprintf + "src: replace %s hash with %s hash" + (State.Source.get_name state) + (State.Target.get_name state))) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "Compute and update hash" ; + state) + commands + +let rename_binaries = + let commands = + Command.FIFO.empty + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "rename main_*.ml{,i} files of the binaries" ; + state) + (fun state -> + let opts = + Format.asprintf + {|-name main_\*_%s.ml -or -name main_\*_%s.mli|} + (State.Source.get_bin_suffix ~__LOC__ state) + (State.Source.get_bin_suffix ~__LOC__ state) + in + let files = + Utils.File.find + ~error:(error ~__LOC__ state) + ~dir:(State.Target.Dir.Absolute.get_src_proto state) + ~opts + in + let regex = + Re.( + compile + (str ("_" ^ State.Source.get_bin_suffix ~__LOC__ state))) + in + let new_files = + List.map + (Re.replace_string + regex + ~by:("_" ^ State.Target.get_bin_suffix ~__LOC__ state)) + files + in + List.iter2 + (fun file new_file -> + let cmd = + Command.Git.git + state + (Format.asprintf "mv %s %s" file new_file) + in + let _ = + Utils.Process.shell ~error:(error ~__LOC__ state) cmd + in + ()) + files + new_files ; + Log.magenta + "Files: %a" + Format.(pp_print_list pp_print_string) + files ; + state)) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun _state -> + "src: rename binaries main_*.ml{,i} files")) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "rename binaries" ; + state) + commands + +let replace_protocol_occurences = + let commands = + Command.FIFO.empty + |> Command.register + (Command.create + ~desc:(fun state -> + Log.eprintfln "replace protocol occurences in lib_protocol code" ; + state) + (fun state -> + let files = + Utils.File.find + ~error:(error ~__LOC__ state) + ~dir:(State.Target.Dir.Absolute.get_lib_protocol state) + ~opts:"-type f" + in + let regex = + Re.( + compile + (alt + [ + group + ~name:"full" + (str + (State.Source.get_module_name_root ~__LOC__ state)); + group + ~name:"dash" + (str + ("protocol-" + ^ State.Source.get_dune_name ~__LOC__ state)); + group + ~name:"functor" + (str + ("protocol-functor-" + ^ State.Source.get_dune_name ~__LOC__ state)); + ])) + in + let assoc = + [ + ("full", State.Target.get_module_name_root ~__LOC__ state); + ( "dash", + "protocol-" ^ State.Target.get_dune_name ~__LOC__ state ); + ( "functor", + "protocol-functor-" + ^ State.Target.get_dune_name ~__LOC__ state ); + ] + in + let replacements = + Utils.File.Content.replace_assoc_all + ~error:(error ~__LOC__ state) + ~regex + ~assoc + files + in + if replacements = 0 then + Log.warning "No protocol occurrences found." ; + state)) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "Format modified files." ; + state) + (fun state -> + let files = + Utils.File.find + ~error:(error ~__LOC__ state) + ~dir:(State.Target.Dir.Absolute.get_lib_protocol state) + ~opts:{|-type f -name "*.ml"|} + in + let files = + files + @ Utils.File.find + ~error:(error ~__LOC__ state) + ~dir:(State.Target.Dir.Absolute.get_lib_protocol state) + ~opts:{|-type f -name "*.mli"|} + in + Utils.File.Content.ocamlformat ~error:(error ~__LOC__ state) files ; + state)) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun state -> + Format.asprintf + "src: replace %s with %s" + (State.Source.get_module_name_root ~__LOC__ state) + (State.Target.get_module_name_root ~__LOC__ state))) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "Replace protocol occurences in ocaml source files" ; + state) + commands + +let add_to_final_protocol_versions = + let commands = + Command.FIFO.empty + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "Add this protocol to the immutable list." ; + state) + (fun state -> + Utils.File.Content.append + ~content: + (Format.asprintf + "%s\n" + (State.Target.get_hash ~__LOC__ state)) + (State.make_absolute + ("src" // "lib_protocol_compiler" + // "final_protocol_versions") + state) ; + state)) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun _state -> + "src: add protocol to final_protocol_versions")) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "Add protocom to final_protocol_versions" ; + state) + commands + +let update_readme = + let commands = + Command.FIFO.empty + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "Update README.md" ; + state) + (fun state -> + let regex = Re.(compile (str (State.Source.get_name state))) in + let by = State.Target.get_name state in + let replacements = + Utils.File.Content.replace_string + ~regex + ~by + (State.Target.Dir.Absolute.get_src_proto state // "README.md") + in + if replacements = 0 then + Log.warning "No protocol found in README.md" ; + state)) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun _state -> + "src: rename protocol in the README")) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "rename protocol in the README" ; + state) + commands + +let link = + let commands = + let file (state : State.t) = + State.make_absolute ("manifest" // "product_octez.ml") state + in + Command.FIFO.empty + |> Command.register + (Command.Log.yellow (fun _state -> + "Linking protocol in the node, client and codec")) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "link protocol in the node, client and codec" ; + state) + (fun state -> + let regex = + Re.( + compile + (group + (seq + [ + str "let"; + rep1 (str " "); + str (State.Source.get_name state); + str + (Format.asprintf + {| = active (Name.dev "%s")|} + (State.Source.get_name state)); + ]))) + in + let f gp = + match Re.Group.get_opt gp 1 with + | None -> + Log.error "Group not found in manifest" ; + State.exit ~__LOC__ state + | Some matched -> + Format.asprintf + {|let _%s = active (Name.dev "%s")@.%s@.|} + (State.Target.get_name state) + (State.Target.get_name state) + matched + in + let replacements = + Utils.File.Content.replace_f ~regex ~f (file state) + in + if replacements = 0 then + Log.warning "No modifications in manifest has been done." ; + state)) + |> Command.register + (Command.File.ocamlformat ~__LOC__ (fun state -> [file state])) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun _state -> + "manifest: link protocol in the node, client and codec")) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "link protocol in manifest" ; + state) + commands + +let make_manifest = + let commands = + Command.FIFO.empty + |> Command.register (Command.Log.blue (fun _state -> "Make manifest")) + |> Command.register + (Command.Shell.create ~__LOC__ (fun _state -> "make -C manifest")) + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln "Format devtools ocaml source files" ; + state) + (fun state -> + let files = + Utils.File.find + ~error:(error ~__LOC__ state) + ~dir:(State.make_absolute "devtools" state) + ~opts:"-name '*.ml'" + in + Utils.File.Content.ocamlformat ~error:(error ~__LOC__ state) files ; + state)) + |> Command.register + (Command.Git.commit ~__LOC__ ~no_verify:() (fun _state -> + "manifest: make manifest")) + in + Command.of_fifo + ~desc:(fun state -> + Log.printfln "make manifest" ; + state) + commands + let copy_source = - let commands = Command.FIFO.empty in - (* TODO *) Command.FIFO.to_command commands + let commands = + Command.FIFO.empty |> Command.register raw_copy + |> Command.register set_current_version + |> Command.register + (Command.Log.printfln (fun state -> State.Source.get_name state)) + |> Command.register add_predecessor + |> Command.register compute_and_replace_hash + |> Command.register rename_binaries + |> Command.register replace_protocol_occurences + |> Command.register add_to_final_protocol_versions + |> Command.register update_readme + |> Command.register link + |> Command.register make_manifest + in + Command.of_fifo commands let update_protocol_tests = let commands = Command.FIFO.empty in - (* TODO *) Command.FIFO.to_command commands + (* TODO *) Command.of_fifo commands let update_source = let commands = Command.FIFO.empty in - (* TODO *) Command.FIFO.to_command commands + (* TODO *) Command.of_fifo commands let update_tezt_tests = let commands = Command.FIFO.empty in - (* TODO *) Command.FIFO.to_command commands + (* TODO *) Command.of_fifo commands let misc_updates = let commands = Command.FIFO.empty in - (* TODO *) Command.FIFO.to_command commands + (* TODO *) Command.of_fifo commands let generate_doc = let commands = Command.FIFO.empty in - (* TODO *) Command.FIFO.to_command commands + (* TODO *) Command.of_fifo commands let snapshot_protocol = - let open Command.FIFO in let commands = - empty |> register copy_source - |> register update_protocol_tests - |> register update_source |> register update_tezt_tests - |> register misc_updates |> register generate_doc + Command.FIFO.empty + |> Command.register copy_source + |> Command.register update_protocol_tests + |> Command.register update_source + |> Command.register update_tezt_tests + |> Command.register misc_updates + |> Command.register generate_doc in - to_command commands + Command.of_fifo commands module Stabilise = struct - let run git_dir protocol_source protocol_target = - let open Command.FIFO in + let run git_dir source target = + check_proto_name source protocol_pattern ; + check_proto_name target protocol_pattern ; let state = State.create ~git_dir - ~protocol_source - ~protocol_target + ~source + ~target ~target_pattern:protocol_pattern.string in let commands = Command.FIFO.empty - |> register (check_arguments protocol_pattern) - |> register clean_tmp_dir - |> register - { - describe = - (fun state -> - Log.printfln - "Will stabilise protocol from 'src/proto_%s'" - state.protocol_source ; - state); - execute = - (fun state -> - Log.blue - "Will stabilise protocol from 'src/proto_%s'" - state.protocol_source ; - state); - } - |> register snapshot_protocol + |> Command.register check_arguments + |> Command.register clean_tmp_dir + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln + "Will stabilise protocol from '%s'" + (State.Source.Dir.Relative.get_src_proto state) ; + state) + (fun state -> + Log.blue + "Will stabilise protocol from '%s'" + (State.Source.Dir.Relative.get_src_proto state) ; + state)) + |> Command.register snapshot_protocol in Log.cyan "Describe commands" ; let _state = Command.FIFO.describe commands state in @@ -178,44 +751,38 @@ module Snapshot = struct let string = {|[a-z]+_[0-9][0-9][0-9]|} in {string; regex = Re.Perl.(compile @@ re ("^" ^ string ^ "$"))} - let check_version_coherency = - Command. - { - describe = - (fun state -> - Log.printfln - "Extract version corresponding to label from tezt and check \ - coherency with arguments" ; - state); - execute = - (fun state -> - let target_label = - match state.target_label with - | Snapshot label -> label - | _ -> - Log.error "Wrong target label type." ; - Stdlib.exit 1 - in - let pattern = - { - string = state.capitalize_label ^ " -> [0-9]+"; - regex = - Re.( - compile - (seq - [ - str state.capitalize_label; - str " -> "; - group (rep1 digit); - ])); - } - in - let in_channel = open_in (tezt_protocol_file state) in - let content = In_channel.input_all in_channel in - In_channel.close in_channel ; - let group = Re.exec_opt pattern.regex content in - let expected_version = - match group with + let check_version_coherency : Command.t = + Command.create + ~desc:(fun state -> + Log.printfln + "Extract version corresponding to label from tezt and check \ + coherency with arguments" ; + state) + (fun state -> + let pattern = + { + string = State.Source.get_constructor state ^ " -> [0-9]+"; + regex = + Re.( + compile + (seq + [ + str (State.Source.get_constructor state); + str " -> "; + group (rep1 digit); + ])); + } + in + let groups = + Utils.File.Content.search + ~regex:pattern.regex + (tezt_protocol_file state) + in + let expected_version = + match groups with + | [group] -> ( + match Re.Group.get_opt group 1 with + | Some expected_version -> expected_version | None -> Log.error "Cannot parse protocol version from %s." @@ -224,70 +791,65 @@ module Snapshot = struct "This file should contain a line matching '%a'." pp_pattern pattern ; - Stdlib.exit 1 - | Some group -> ( - match Re.Group.get_opt group 1 with - | Some expected_version -> expected_version - | None -> - Log.error - "Cannot parse protocol version from %s." - (tezt_protocol_file state) ; - Log.error - "This file should contain a line matching '%a'." - pp_pattern - pattern ; - Stdlib.exit 1) - in - let expected_version = - match int_of_string_opt expected_version with - | Some version -> version - | None -> - Log.error - "Cannot parse protocol version from %s" - (tezt_protocol_file state) ; - Log.error - "This file should contain a line matching '%a'." - pp_pattern - pattern ; - Stdlib.exit 1 - in - if expected_version <> target_label.version then ( - Log.error "Wrong protocol version: %03d" target_label.version ; - Log.error "Expected version: %03d" expected_version ; - Stdlib.exit 1) ; - state); - } - - let run git_dir protocol_source protocol_target = - let open Command.FIFO in + Stdlib.exit 1) + | _ -> + Log.error + "Cannot parse protocol version from %s." + (tezt_protocol_file state) ; + Log.error + "This file should contain a line matching '%a'." + pp_pattern + pattern ; + Stdlib.exit 1 + in + let expected_version = + match int_of_string_opt expected_version with + | Some version -> version + | None -> + Log.error + "Cannot parse protocol version from %s" + (tezt_protocol_file state) ; + Log.error + "This file should contain a line matching '%a'." + pp_pattern + pattern ; + Stdlib.exit 1 + in + let target_version = State.Target.get_version ~__LOC__ state in + if expected_version <> target_version then ( + Log.error "Wrong protocol version: %03d" target_version ; + Log.error "Expected version: %03d" expected_version ; + Stdlib.exit 1) ; + state) + + let run git_dir source target = + check_proto_name source protocol_pattern ; + check_proto_name target target_pattern ; let state = State.create ~git_dir - ~protocol_source - ~protocol_target + ~source + ~target ~target_pattern:target_pattern.string in let commands = Command.FIFO.empty - |> register (check_arguments target_pattern) - |> register check_version_coherency - |> register clean_tmp_dir - |> register - { - describe = - (fun state -> - Log.printfln - "Will snapshot protocol from 'src/proto_%s'" - state.protocol_source ; - state); - execute = - (fun state -> - Log.blue - "Will snapshot protocol from 'src/proto_%s'" - state.protocol_source ; - state); - } - |> register snapshot_protocol + |> Command.register check_arguments + |> Command.register check_version_coherency + |> Command.register clean_tmp_dir + |> Command.register + (Command.create + ~desc:(fun state -> + Log.printfln + "Will snapshot protocol from '%s'" + (State.Source.Dir.Relative.get_src_proto state) ; + state) + (fun state -> + Log.blue + "Will snapshot protocol from '%s'" + (State.Source.Dir.Relative.get_src_proto state) ; + state)) + |> Command.register snapshot_protocol in Log.cyan "Describe commands" ; let _state = Command.FIFO.describe commands state in diff --git a/devtools/proto_manager/state.ml b/devtools/proto_manager/state.ml index 6f0ea6df6279dab86a285f92c3141f091b558298..c34f75a6cd52074cec3fb482d51924d7fabb4303 100644 --- a/devtools/proto_manager/state.ml +++ b/devtools/proto_manager/state.ml @@ -5,26 +5,63 @@ (* *) (*****************************************************************************) -type snapshot_label = {name : string; version : int} +open Utils.Infix -type label = Snapshot of snapshot_label | Stabilise of string +type protocol = {name : string; version : int option; hash : string option} -type t = { - commits : int; - protocol_source : string; - protocol_target : string; - target_label : label; - capitalize_label : string; - git_dir : string; -} +type t = {git_dir : string; commits : int; source : protocol; target : protocol} -let pp_label fmt = function - | Stabilise label -> Format.pp_print_string fmt label - | Snapshot label -> Format.fprintf fmt "%03d_%s" label.version label.name +let get_git_dir {git_dir; _} = git_dir -let pp_label_name fmt = function - | Stabilise label -> Format.pp_print_string fmt label - | Snapshot label -> Format.fprintf fmt "%s" label.name +let eq_source_target {source; target; _} = source = target + +let incr_commit_count state = {state with commits = state.commits + 1} + +module type Dir_sig = sig + val get_src_proto : t -> string + + val get_lib_protocol : t -> string + + val get_doc : t -> string +end + +module type Protocol_sig = sig + module Dir : sig + module Relative : Dir_sig + + module Absolute : Dir_sig + end + + val get_name : t -> string + + val get_version_value : t -> string + + val get_constructor : t -> string + + val get_hash : __LOC__:string -> ?short:unit -> t -> string + + val get_bin_suffix : __LOC__:string -> t -> string + + val get_module_name_root : __LOC__:string -> t -> string + + val get_dune_name : __LOC__:string -> t -> string + + val get_version : __LOC__:string -> t -> int +end + +module type Get_protocol = sig + val get_protocol : t -> protocol +end + +let get_src_proto_dir proto = + match (proto.version, proto.hash) with + | None, _ -> ("src" // "proto_") ^ proto.name + | Some version, None -> + Format.asprintf "%s_%03d_%s" ("src" // "proto_") version proto.name + | Some version, Some hash -> + Format.asprintf "%s_%03d_%s" ("src" // "proto_") version hash + +let get_doc_dir proto = "docs" // proto.name let exit ~__LOC__ (state : t) = let open Log in @@ -32,40 +69,125 @@ let exit ~__LOC__ (state : t) = if state.commits > 0 then printfln "@[@{To clean up git commits run:@}@,\ - git reset -- hard HEAD~%i" + git reset --hard HEAD~%i" state.commits ; printfln "@[@[@{To clean up other created files:@}@,\ - rm -rf docs/%a@,\ - rm -rf src/proto_%a@]@,\ + rm -rf %s@,\ + rm -rf src/proto_%s@]@,\ exiting ...@]" - pp_label_name - state.target_label - pp_label - state.target_label ; + (get_doc_dir state.target) + (get_src_proto_dir state.target) ; exit 1 -let create ~git_dir ~protocol_source ~protocol_target ~target_pattern = - let target_label = - match String.split_on_char '_' protocol_target with +let make_absolute relative state = state.git_dir // relative + +module Protocol (G : Get_protocol) = struct + module Dir = struct + module Relative = struct + let get_src_proto state = get_src_proto_dir (G.get_protocol state) + + let get_lib_protocol state = get_src_proto state // "lib_protocol" + + let get_doc state = get_doc_dir (G.get_protocol state) + end + + module Absolute = struct + let get_src_proto state = + make_absolute (get_src_proto_dir (G.get_protocol state)) state + + let get_lib_protocol state = get_src_proto state // "lib_protocol" + + let get_doc state = + make_absolute (get_doc_dir (G.get_protocol state)) state + end + end + + let get_name state = (G.get_protocol state).name + + let get_version_value state = + let proto = G.get_protocol state in + match proto.version with + | None -> proto.name + | Some version -> Format.asprintf "%s_%03d" proto.name version + + let get_constructor state = + String.capitalize_ascii (G.get_protocol state).name + + let get_hash ~__LOC__ ?short state = + let proto = G.get_protocol state in + match proto.hash with + | Some hash -> ( + match short with None -> hash | Some () -> String.sub hash 0 8) + | None -> + Log.error "Protocol %s does not contain a hash" proto.name ; + exit ~__LOC__ state + + let get_bin_suffix ~__LOC__ state = + let proto = G.get_protocol state in + match (proto.version, proto.hash) with + | None, _ -> proto.name + | Some version, Some hash -> Format.asprintf "%03d_%s" version hash + | Some _, None -> + Log.error "Protocol %s does not contain a hash" proto.name ; + exit ~__LOC__ state + + let get_module_name_root ~__LOC__ state = + let proto = G.get_protocol state in + match (proto.version, proto.hash) with + | None, _ -> "protocol_" ^ proto.name + | Some version, Some hash -> Format.asprintf "protocol_%03d_%s" version hash + | Some _, None -> + Log.error "Protocol %s does not contain a hash" proto.name ; + exit ~__LOC__ state + + let get_dune_name ~__LOC__ state = + let proto = G.get_protocol state in + match (proto.version, proto.hash) with + | None, _ -> proto.name + | Some version, Some hash -> Format.asprintf "%03d_%s" version hash + | Some _, None -> + Log.error "Protocol %s does not contain a hash" proto.name ; + exit ~__LOC__ state + + let get_version ~__LOC__ state = + let proto = G.get_protocol state in + match proto.version with + | None -> + Log.error "%s protocol does not contain a version" proto.name ; + exit ~__LOC__ state + | Some version -> version +end + +module Source = Protocol (struct + let get_protocol {source; _} = source +end) + +module Target = Protocol (struct + let get_protocol {target; _} = target +end) + +let create ~git_dir ~source ~target ~target_pattern = + let parse_protocol proto = + match String.split_on_char '_' proto with | [name; version] -> ( match int_of_string_opt version with - | Some version -> Snapshot {name; version} + | Some _ as version -> {name; version; hash = None} | None -> Log.error "Cannot parse protocol target version." ; Log.error "Protocol target should be of form '%s'." target_pattern ; Stdlib.exit 1) - | [name] -> Stabilise name + | [name] -> {name; version = None; hash = None} | _ -> Log.error "Cannot parse protocol target." ; Log.error "Protocol target should be of form '%s'." target_pattern ; Stdlib.exit 1 in { - commits = 0; - protocol_source; - protocol_target; - target_label; - capitalize_label = String.capitalize_ascii protocol_source; git_dir; + commits = 0; + source = parse_protocol source; + target = parse_protocol target; } + +let set_target_hash ~hash state = {state with target = {state.target with hash}} diff --git a/devtools/proto_manager/state.mli b/devtools/proto_manager/state.mli index dd0d2d95a4aab3a92a552cc98cabf1ce52928a2e..dfaa74f1c647551a1ca77f112a6da17b08b9ead7 100644 --- a/devtools/proto_manager/state.mli +++ b/devtools/proto_manager/state.mli @@ -5,26 +5,95 @@ (* *) (*****************************************************************************) -(** Type of target label representation for snapshot. *) -type snapshot_label = {name : string; version : int} +(** Type that represents a protocol. *) +type protocol -(** Type of different target label representation for different actions. *) -type label = Snapshot of snapshot_label | Stabilise of string +(** Type that represents the state of the protocol manager. *) +type t -type t = { - commits : int; (** Count of commit done by this process. *) - protocol_source : string; - protocol_target : string; - target_label : label; - capitalize_label : string; - git_dir : string; -} +(** [eq_source_target state] is true if source and target protocols designate + the same protocol. *) +val eq_source_target : t -> bool -(** [pp_label fmt l] prints the full representation of [l] in [fmt]. *) -val pp_label : Format.formatter -> label -> unit +(** [get_git_dir state] returns the absolute path of the tezos git repository + directory where the protocol manager operates. *) +val get_git_dir : t -> string -(** [pp_label_name fmt l] prints the name of [l] in [fmt]. *) -val pp_label_name : Format.formatter -> label -> unit +(** [incr_commit_count state] increments by one the count of commits made by + the protocol manager. *) +val incr_commit_count : t -> t + +(** [make_absolute path state] returns the absolute path of [path] considering + that it is relative to the git repository directory. *) +val make_absolute : string -> t -> string + +(** Module type that contains functions to get protocol related directories. *) +module type Dir_sig = sig + (** [get_src_proto state] returns the protocol source directory. *) + val get_src_proto : t -> string + + (** [get_lib_protocol state] returns the lib_protocol directory of the + protocol. *) + val get_lib_protocol : t -> string + + (** [get_doc state] returns the doc directory of the protocol. *) + val get_doc : t -> string +end + +(** Module type that contains functions to get informations of a protocol. *) +module type Protocol_sig = sig + (** Module that contains functions to get the directories of the protocol. *) + module Dir : sig + (** Module that contains functions to get the paths relative to the git + repository directory. *) + module Relative : Dir_sig + + (** Module that contains the functions to get the absolute paths. *) + module Absolute : Dir_sig + end + + (** [get_name state] returns the name of the protocol in lowercase. *) + val get_name : t -> string + + (** [get_version_value state] returns the protocol version_value string. It + is of the form quebec_021 or alpha. *) + val get_version_value : t -> string + + (** [get_constructor state] returns a string representing an Ocaml + constructor of the protocol. *) + val get_constructor : t -> string + + (** [get_hash ~__LOC__ ?short state] returns the hash of the protocol if + exists or fails. If [short] is provided returns the 8 first characters of + the hash. *) + val get_hash : __LOC__:string -> ?short:unit -> t -> string + + (** [get_bin_suffix ~__LOC__ state] returns the suffix used for protocol + binaries. If the protocol has a version but not a hash it fails. *) + val get_bin_suffix : __LOC__:string -> t -> string + + (** [get_module_name_root ~__LOC__ state] returns the root of protocol module + names. If the protocol has a version but not a hash it fails. *) + val get_module_name_root : __LOC__:string -> t -> string + + (** [get_dune_name ~__LOC__ state] returns the name of the protocol used in + dune files. If the protocol has a version but not a hash it fails. *) + val get_dune_name : __LOC__:string -> t -> string + + (** [get_version ~__LOC__ state] returns ther version of the protocol. If the + protocol has not a version it fails. *) + val get_version : __LOC__:string -> t -> int +end + +(** Module to get information about the source protocol. *) +module Source : Protocol_sig + +(** Module to get information about the target protocol. *) +module Target : Protocol_sig + +(** [set_target_hash ~hash state] returns [state] but with [hash] as hash of + the target protocol. *) +val set_target_hash : hash:string option -> t -> t (** Log an error message and how to clean up created files and exits the process. *) @@ -32,8 +101,4 @@ val exit : __LOC__:string -> t -> 'a (** Creates a state. *) val create : - git_dir:string -> - protocol_source:string -> - protocol_target:string -> - target_pattern:string -> - t + git_dir:string -> source:string -> target:string -> target_pattern:string -> t