Compiler: by default, enforce the hash declared in TEZOS_PROTOCOL

scripts/archive_protocol.sh

@@ -21,27 +21,15 @@ if [ -z "$version" ] ; then
     exit 1
 fi
 
-alpha_tmpdir=`mktemp -d`
-
-cleanup () {
-    set +e
-    echo Cleaning up...
-    [ ! -d "$alpha_tmpdir" ] || rm -rf "$alpha_tmpdir"
-}
-trap cleanup EXIT INT
-
-mkdir "$alpha_tmpdir"/src
-
 current_hash_alpha=`jq '.hash' < src/proto_$dir_name/lib_protocol/src/TEZOS_PROTOCOL | tr -d '"'`
 
 echo "Computing the protocol hash..."
 
-cp src/proto_${dir_name}/lib_protocol/src/*.ml src/proto_${dir_name}/lib_protocol/src/*.mli "$alpha_tmpdir"/src/
 sed -i --follow-symlink \
     -e 's/let version_value = "[^"]*"/let version_value = "'${name}'_'${version}'"/' \
-    "$alpha_tmpdir"/src/raw_context.ml
-grep -v '"hash"' < src/proto_${dir_name}/lib_protocol/src/TEZOS_PROTOCOL > "$alpha_tmpdir"/src/TEZOS_PROTOCOL
-long_hash=`./tezos-protocol-compiler -hash-only  $alpha_tmpdir/tmp $alpha_tmpdir/src`
+    src/proto_${dir_name}/lib_protocol/src/raw_context.ml
+
+long_hash=`./tezos-protocol-compiler -hash-only src/proto_${dir_name}/lib_protocol/src`
 short_hash=$(echo $long_hash | head -c 8)
 
 if [ -d "src/proto_${version}_${short_hash}" ] ; then
@@ -74,11 +62,6 @@ sed -i --follow-symlink \
     ../$proto_genesis_dir/lib_client/proto_alpha.ml \
     ../lib_shell/bench/helpers/proto_alpha.ml
 
-sed -i --follow-symlink \
-    -e 's/let name = "[^"]*"/let name = "'${name}'_'${version}'"/' \
-    lib_client/proto_alpha.ml \
-    lib_protocol/test/helpers/proto_alpha.ml
-
 sed -i --follow-symlink \
     -e 's/let version_value = "[^"]*"/let version_value = "'${name}'_'${version}'"/' \
     lib_protocol/src/raw_context.ml

src/lib_protocol_compiler/compiler.ml

@@ -150,10 +150,14 @@ let main { compile_ml ; pack_objects ; link_shared } =
   and static = ref false
   and register = ref false
   and build_dir = ref None
+  and output_file = ref None
   and output_dep = ref false
-  and hash_only = ref false in
+  and hash_only = ref false
+  and check_protocol_hash = ref true in
   let args_spec = [
-    "-hash-only", Arg.Set hash_only, " Don't compile" ;
+    "-o", Arg.String (fun s -> output_file := Some s), "" ;
+    "-hash-only", Arg.Set hash_only, " Only display the hash of the protocol and don't compile" ;
+    "-no-hash-check", Arg.Clear check_protocol_hash, " Don't check that TEZOS_PROTOCOL declares the expected protocol hash (if existent)" ;
     "-static", Arg.Set static, " Only build the static library (no .cmxs)" ;
     "-register", Arg.Set register, " Generete the `Registerer` module" ;
     "-bin-annot", Arg.Set Clflags.binary_annotations, " (see ocamlopt)" ;
@@ -164,13 +168,38 @@ let main { compile_ml ; pack_objects ; link_shared } =
   ] in
   let usage_msg =
     Printf.sprintf
-      "Usage: %s [options] <out> <srcdir>\nOptions are:"
+      "Usage: %s [options] <srcdir>\nOptions are:"
       Sys.argv.(0) in
   Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ;
-  let (output, source_dir) =
+  let source_dir =
     match List.rev !anonymous with
-    | [ output ; protocol_dir ] -> output, protocol_dir
+    | [ protocol_dir ] -> protocol_dir
     | _ -> Arg.usage args_spec usage_msg ; Pervasives.exit 1 in
+  let announced_hash, protocol =
+    match Lwt_main.run (Lwt_utils_unix.Protocol.read_dir source_dir) with
+    | Ok (hash, proto) -> (hash, proto)
+    | Error err ->
+        Format.eprintf
+          "Failed to read TEZOS_PROTOCOL: %a" pp_print_error err ;
+        exit 2 in
+  let real_hash = Protocol.hash protocol in
+  if !hash_only then begin
+    Format.printf "%a@." Protocol_hash.pp real_hash ;
+    exit 0 ;
+  end ;
+  let hash =
+    match announced_hash with
+    | None -> real_hash
+    | Some hash
+      when !check_protocol_hash && not (Protocol_hash.equal real_hash hash) ->
+        Format.eprintf
+          "Inconsistent hash for protocol in TEZOS_PROTOCOL.@\n\
+           Found: %a@\n\
+           Expected: %a@."
+          Protocol_hash.pp hash
+          Protocol_hash.pp real_hash ;
+        exit 2
+    | Some hash -> hash in
   let build_dir =
     match !build_dir with
     | None ->
@@ -178,16 +207,10 @@ let main { compile_ml ; pack_objects ; link_shared } =
         at_exit (fun () -> Lwt_main.run (Lwt_utils_unix.remove_dir dir)) ;
         dir
     | Some dir -> dir in
-  let hash, protocol =
-    match Lwt_main.run (Lwt_utils_unix.Protocol.read_dir source_dir) with
-    | Ok v -> v
-    | Error err ->
-        Format.kasprintf Pervasives.failwith
-          "Failed to read TEZOS_PROTOCOL: %a" pp_print_error err in
-  if !hash_only then begin
-    Format.printf "%a@." Protocol_hash.pp hash ;
-    exit 0
-  end ;
+  let output =
+    match !output_file with
+    | Some output -> output
+    | None -> Format.asprintf "proto_%a" Protocol_hash.pp hash in
   Lwt_main.run (Lwt_utils_unix.create_dir ~perm:0o755 build_dir) ;
   Lwt_main.run (Lwt_utils_unix.create_dir ~perm:0o755 (Filename.dirname output)) ;
   (* Generate the 'functor' *)
@@ -256,5 +279,5 @@ let main { compile_ml ; pack_objects ; link_shared } =
     Format.printf "let intf_digest = %S ;;\n" (Digest.to_hex dintf)
   end ;
 
-  Format.printf "Success: %a@." Protocol_hash.pp hash
+  Format.printf "Success: %a.@." Protocol_hash.pp hash
 

src/lib_protocol_compiler/main_embedded_packer.ml

@@ -28,7 +28,10 @@ let version = Sys.argv.(2)
 
 let hash, sources =
   match Lwt_main.run (Lwt_utils_unix.Protocol.read_dir srcdir) with
-  | Ok v -> v
+  | Ok (None, proto) ->
+      (Protocol.hash proto, proto)
+  | Ok (Some hash, proto) ->
+      (hash, proto)
   | Error err ->
       Format.kasprintf Pervasives.failwith
         "Failed to read TEZOS_PROTOCOL: %a" pp_print_error err

src/lib_protocol_compiler/main_packer.ml

@@ -38,7 +38,10 @@ let () =
     | _ -> Arg.usage args_spec usage_msg ; Pervasives.exit 1 in
   let hash, protocol =
     match Lwt_main.run (Lwt_utils_unix.Protocol.read_dir source_dir) with
-    | Ok v -> v
+    | Ok (None, proto) ->
+        (Protocol.hash proto, proto)
+    | Ok (Some hash, proto) ->
+        (hash, proto)
     | Error err ->
         Format.kasprintf Pervasives.failwith
           "Failed to read TEZOS_PROTOCOL: %a" pp_print_error err in

src/lib_protocol_updater/updater.ml

@@ -54,7 +54,7 @@ let do_compile hash p =
     Lwt_utils_unix.Protocol.write_dir source_dir ~hash p >>=? fun () ->
     let compiler_command =
       (Sys.executable_name,
-       Array.of_list [compiler_name; "-register"; plugin_file; source_dir]) in
+       Array.of_list [ compiler_name ; "-register" ; "-o" ; plugin_file ; source_dir]) in
     let fd = Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644) in
     Lwt_process.exec
       ~stdin:`Close ~stdout:(`FD_copy fd) ~stderr:(`FD_move fd)

src/lib_stdlib_unix/lwt_utils_unix.ml

@@ -237,12 +237,7 @@ module Protocol = struct
       match meta.expected_env_version with
       | None -> V1
       | Some v -> v in
-    let protocol = { expected_env ; components } in
-    let hash =
-      match meta.hash with
-      | None -> hash protocol
-      | Some hash -> hash in
-    return (hash, protocol)
+    return (meta.hash, { expected_env ; components })
 
   open Lwt.Infix
 

src/lib_stdlib_unix/lwt_utils_unix.mli

@@ -66,7 +66,7 @@ end
 
 module Protocol : sig
 
-  val read_dir: string -> (Protocol_hash.t * Protocol.t) tzresult Lwt.t
+  val read_dir: string -> (Protocol_hash.t option * Protocol.t) tzresult Lwt.t
 
   val write_dir: string -> ?hash:Protocol_hash.t -> Protocol.t -> unit tzresult Lwt.t