Shell: add option --checkpoint to tezos-node run

docs/doc_gen/node_helpers.ml

@@ -28,6 +28,7 @@ let with_node f =
       context_root = dir / "context" ;
       p2p = None ;
       test_chain_max_tll = None ;
+      checkpoint = None ;
     } in
     Node.create
       node_config

src/bin_node/node_run_command.ml

@@ -90,7 +90,7 @@ let init_logger ?verbosity (log_config : Node_config_file.log) =
   end ;
   Logging_unix.init ~template:log_config.template log_config.output
 
-let init_node ?sandbox (config : Node_config_file.t) =
+let init_node ?sandbox ?checkpoint (config : Node_config_file.t) =
   let patch_context json ctxt =
     begin
       match json with
@@ -181,6 +181,7 @@ let init_node ?sandbox (config : Node_config_file.t) =
     context_root = context_dir config.data_dir ;
     p2p = p2p_config ;
     test_chain_max_tll = Some (48 * 3600) ; (* 2 days *)
+    checkpoint ;
   } in
   Node.create
     node_config
@@ -242,7 +243,7 @@ let init_signal () =
   ignore (Lwt_unix.on_signal Sys.sigint (handler "INT") : Lwt_unix.signal_handler_id) ;
   ignore (Lwt_unix.on_signal Sys.sigterm (handler "TERM") : Lwt_unix.signal_handler_id)
 
-let run ?verbosity ?sandbox (config : Node_config_file.t) =
+let run ?verbosity ?sandbox ?checkpoint (config : Node_config_file.t) =
   Node_data_version.ensure_data_dir config.data_dir >>=? fun () ->
   Lwt_lock_file.create
     ~unlink_on_exit:true (lock_file config.data_dir) >>=? fun () ->
@@ -250,7 +251,7 @@ let run ?verbosity ?sandbox (config : Node_config_file.t) =
   init_logger ?verbosity config.log >>= fun () ->
   Updater.init (protocol_dir config.data_dir) ;
   lwt_log_notice "Starting the Tezos node..." >>= fun () ->
-  init_node ?sandbox config >>=? fun node ->
+  init_node ?sandbox ?checkpoint config >>=? fun node ->
   init_rpc config.rpc node >>=? fun rpc ->
   lwt_log_notice "The Tezos node is now running!" >>= fun () ->
   Lwt_exit.termination_thread >>= fun x ->
@@ -262,7 +263,7 @@ let run ?verbosity ?sandbox (config : Node_config_file.t) =
   Logging_unix.close () >>= fun () ->
   return ()
 
-let process sandbox verbosity args =
+let process sandbox verbosity checkpoint args =
   let verbosity =
     match verbosity with
     | [] -> None
@@ -281,11 +282,29 @@ let process sandbox verbosity args =
           else return ()
       | None -> return ()
     end >>=? fun () ->
+    begin
+      match checkpoint with
+      | None -> return None
+      | Some s ->
+          match String.split ',' s with
+          | [ lvl ; block ] ->
+              Lwt.return (Block_hash.of_b58check block) >>=? fun block ->
+              begin
+                match Int32.of_string_opt lvl with
+                | None ->
+                    failwith "... FIXME ..."
+                | Some lvl ->
+                    return lvl
+              end >>=? fun lvl ->
+              return (Some (lvl, block))
+          | _ ->
+              failwith "... FIXME ..."
+    end >>=? fun checkpoint ->
     Lwt_lock_file.is_locked
       (lock_file config.data_dir) >>=? function
     | false ->
         Lwt.catch
-          (fun () -> run ?sandbox ?verbosity config)
+          (fun () -> run ?sandbox ?verbosity ?checkpoint config)
           (function
             |Unix.Unix_error(Unix.EADDRINUSE, "bind","") ->
                 begin match config.rpc.listen_addr with
@@ -327,8 +346,17 @@ module Term = struct
          info ~docs:Node_shared_arg.Manpage.misc_section
            ~doc ~docv:"FILE.json" ["sandbox"])
 
+  let checkpoint =
+    let open Cmdliner in
+    let doc =
+      "..."
+    in
+    Arg.(value & opt (some string) None &
+         info ~docs:Node_shared_arg.Manpage.misc_section
+           ~doc ~docv:"<level>,<block_hash>" ["checkpoint"])
+
   let term =
-    Cmdliner.Term.(ret (const process $ sandbox $ verbosity $
+    Cmdliner.Term.(ret (const process $ sandbox $ verbosity $ checkpoint $
                         Node_shared_arg.Term.args))
 
 end

src/lib_shell/node.ml

@@ -67,6 +67,7 @@ type config = {
   patch_context: (Context.t -> Context.t Lwt.t) option ;
   p2p: (P2p.config * P2p.limits) option ;
   test_chain_max_tll: int option ;
+  checkpoint: (Int32.t * Block_hash.t) option ;
 }
 
 and peer_validator_limits = Peer_validator.limits = {
@@ -134,9 +135,19 @@ let default_chain_validator_limits = {
   }
 }
 
+let may_update_checkpoint chain_state checkpoint =
+  match checkpoint with
+  | None ->
+      Lwt.return_unit
+  | Some checkpoint ->
+      State.best_known_head_for_checkpoint
+        chain_state checkpoint >>= fun new_head ->
+      Chain.set_head chain_state new_head >>= fun _old_head ->
+      State.Chain.set_checkpoint chain_state checkpoint
+
 let create { genesis ; store_root ; context_root ;
              patch_context ; p2p = p2p_params ;
-             test_chain_max_tll = max_child_ttl }
+             test_chain_max_tll = max_child_ttl ; checkpoint }
     peer_validator_limits
     block_validator_limits
     prevalidator_limits
@@ -148,6 +159,7 @@ let create { genesis ; store_root ; context_root ;
   init_p2p p2p_params >>=? fun p2p ->
   State.read
     ~store_root ~context_root ?patch_context genesis >>=? fun (state, mainchain_state) ->
+  may_update_checkpoint mainchain_state checkpoint >>= fun () ->
   let distributed_db = Distributed_db.create state p2p in
   Validator.create state distributed_db
     peer_validator_limits

src/lib_shell/node.mli

@@ -16,6 +16,7 @@ type config = {
   patch_context: (Context.t -> Context.t Lwt.t) option ;
   p2p: (P2p.config * P2p.limits) option ;
   test_chain_max_tll: int option ;
+  checkpoint: (Int32.t * Block_hash.t) option ;
 }
 
 and peer_validator_limits = {

src/lib_shell/state.ml

@@ -643,6 +643,13 @@ module Block = struct
       else fail (Block_not_invalid block)
     end
 
+  let is_valid_for_checkpoint block checkpoint =
+    let chain_state = block.chain_state in
+    Shared.use chain_state.block_store begin fun store ->
+      Locked_block.is_valid_for_checkpoint
+        store block.hash block.contents.header checkpoint
+    end
+
   let known chain_state hash =
     Shared.use chain_state.block_store begin fun store ->
       Store.Block.Contents.known (store, hash) >>= fun known ->
@@ -983,6 +990,54 @@ let fork_testchain block protocol expiration =
     return chain
   end
 
+let best_known_head_for_checkpoint chain_state (level, _ as checkpoint) =
+  Shared.use chain_state.block_store begin fun store ->
+    Shared.use chain_state.chain_data begin fun data ->
+      let head_hash = data.data.current_head.hash in
+      let head_header = data.data.current_head.contents.header in
+      Locked_block.is_valid_for_checkpoint
+        store head_hash head_header checkpoint >>= fun valid ->
+      if valid then
+        Lwt.return data.data.current_head
+      else
+        let find_valid_predecessor hash =
+          Store.Block.Contents.read_exn
+            (store, hash) >>= fun contents ->
+          if Compare.Int32.(contents.header.shell.level < level) then
+            Lwt.return { hash ; contents ; chain_state }
+          else
+            predecessor_n store hash
+              (1 + (Int32.to_int @@
+                    Int32.sub contents.header.shell.level level)) >>= function
+            | None -> assert false
+            | Some pred ->
+                Store.Block.Contents.read_exn
+                  (store, pred) >>= fun pred_contents ->
+                Lwt.return { hash = pred ; contents = pred_contents ;
+                             chain_state } in
+        Store.Chain_data.Known_heads.read_all
+          data.chain_data_store >>= fun heads ->
+        Store.Block.Contents.read_exn
+          (store, chain_state.genesis.block) >>= fun genesis_contents ->
+        let genesis =
+          { hash = chain_state.genesis.block ;
+            contents = genesis_contents ;
+            chain_state } in
+        Block_hash.Set.fold
+          (fun head best ->
+             let valid_predecessor = find_valid_predecessor head in
+             best >>= fun best ->
+             valid_predecessor >>= fun pred ->
+             if Fitness.(pred.contents.header.shell.fitness >
+                         best.contents.header.shell.fitness) then
+               Lwt.return pred
+             else
+               Lwt.return best)
+          heads
+          (Lwt.return genesis)
+    end
+  end
+
 module Protocol = struct
 
   include Protocol

src/lib_shell/state.mli

@@ -146,6 +146,8 @@ module Block : sig
   val predecessor: t -> block option Lwt.t
   val predecessor_n: t -> int -> Block_hash.t option Lwt.t
 
+  val is_valid_for_checkpoint: t -> (Int32.t * Block_hash.t) -> bool Lwt.t
+
   val context: t -> Context.t Lwt.t
   val protocol_hash: t -> Protocol_hash.t Lwt.t
   val test_chain: t -> Test_chain_status.t Lwt.t
@@ -186,6 +188,13 @@ val read_block_exn:
 
 val watcher: t -> Block.t Lwt_stream.t * Lwt_watcher.stopper
 
+(** Computes the block with the best fitness amongst the known blocks
+    which are compatible with the given checkpoint. *)
+val best_known_head_for_checkpoint:
+  Chain.t ->
+  Int32.t * Block_hash.t ->
+  Block.t Lwt.t
+
 val compute_locator: Chain.t -> ?size:int -> Block.t -> Block_locator.seed -> Block_locator.t Lwt.t
 
 val fork_testchain: