Baker: add client-side validation

src/proto_alpha/lib_client/jbuild

@@ -9,6 +9,7 @@
               tezos-shell-services
               tezos-client-base
               tezos-rpc
+              tezos-storage
               tezos-signer-backends
               bip39))
   (library_flags (:standard -linkall))
@@ -17,6 +18,7 @@
                     -open Tezos_base__TzPervasives
                     -open Tezos_shell_services
                     -open Tezos_client_base
+                    -open Tezos_storage
                     -open Tezos_rpc))))
 
 (alias

src/proto_alpha/lib_client/proto_alpha.ml

@@ -8,9 +8,12 @@
 (**************************************************************************)
 
 module Name = struct let name = "alpha" end
-module Alpha_environment = Tezos_protocol_environment_faked.MakeV1(Name)()
+module T = Tezos_protocol_environment.Make(Tezos_storage.Context)
+module Alpha_environment = T.MakeV1(Name)()
+
 module Proto = Tezos_protocol_alpha.Functor.Make(Alpha_environment)
 module Alpha_block_services = Block_services.Make(Proto)(Proto)
+
 include Proto
 
 class type rpc_context = object

src/proto_alpha/lib_delegate/client_baking_blocks.ml

@@ -19,6 +19,7 @@ type block_info = {
   protocol: Protocol_hash.t ;
   next_protocol: Protocol_hash.t ;
   level: Raw_level.t ;
+  context : Context_hash.t ;
 }
 
 let raw_info cctxt ?(chain = `Main) hash shell_header =
@@ -27,12 +28,13 @@ let raw_info cctxt ?(chain = `Main) hash shell_header =
   Shell_services.Blocks.protocols
     cctxt ~chain ~block () >>=? fun { current_protocol = protocol ;
                                       next_protocol } ->
-  let { Tezos_base.Block_header.predecessor ; fitness ; timestamp ; level ; _ } =
+  let { Tezos_base.Block_header.predecessor ; fitness ;
+        timestamp ; level ; context ; _ } =
     shell_header in
   match Raw_level.of_int32 level with
   | Ok level ->
       return { hash ; chain_id ; predecessor ; fitness ;
-               timestamp ; protocol ; next_protocol ; level }
+               timestamp ; protocol ; next_protocol ; level ; context }
   | Error _ ->
       failwith "Cannot convert level into int32"
 

src/proto_alpha/lib_delegate/client_baking_blocks.mli

@@ -19,6 +19,7 @@ type block_info = {
   protocol: Protocol_hash.t ;
   next_protocol: Protocol_hash.t ;
   level: Raw_level.t ;
+  context : Context_hash.t ;
 }
 
 val info:

src/proto_alpha/lib_delegate/client_baking_forge.ml

@@ -18,9 +18,21 @@ let generate_proof_of_work_nonce () =
 let generate_seed_nonce () =
   match Nonce.of_bytes @@
     Rand.generate Constants.nonce_length with
-  | Error _ -> assert false
+  | Error _errs -> assert false
   | Ok nonce -> nonce
 
+let rec retry_call f ?(msg="Call error") ?(n=5) () =
+  f () >>= function
+  | Ok r -> return r
+  | (Error errs) as x ->
+      if n > 0 then
+        begin
+          lwt_log_error "%s\n%a\nRetrying..."
+            msg pp_print_error errs >>= fun () ->
+          Lwt_unix.sleep 1. >>= retry_call f ~msg ~n:(n-1)
+        end
+      else
+        Lwt.return x
 
 let forge_block_header
     (cctxt : #Proto_alpha.full)
@@ -370,14 +382,16 @@ let rec insert_baking_slot slot = function
 
 type state = {
   genesis: Block_hash.t ;
+  index : Context.index ;
   mutable delegates: public_key_hash list ;
   mutable best: Client_baking_blocks.block_info ;
   mutable future_slots:
     (Time.t * (Client_baking_blocks.block_info * int * public_key_hash)) list ;
 }
 
-let create_state genesis delegates best =
+let create_state genesis index delegates best =
   { genesis ;
+    index ;
     delegates ;
     best ;
     future_slots = [] ;
@@ -491,6 +505,42 @@ let pop_baking_slots state =
   state.future_slots <- future_slots ;
   slots
 
+
+let filter_invalid_operations (cctxt : #full) state block_info (operations : packed_operation list list) =
+  let open Client_baking_simulator in
+  lwt_debug "Starting client-side validation" >>= fun () ->
+  begin_construction cctxt state.index block_info >>=? fun initial_inc ->
+  let endorsements = List.nth operations 0 in
+  let votes = List.nth operations 1 in
+  let anonymous = List.nth operations 2 in
+  let managers = List.nth operations 3 in
+  (* TODO log *)
+  let validate_operation inc op =
+    add_operation inc op >>= function
+    | Error _ -> return None
+    | Ok inc -> return (Some inc)
+  in
+  let filter_valid_operations inc ops =
+    fold_left_s (fun (inc, acc) op ->
+        validate_operation inc op >>=? function
+        | None -> return (inc, acc)
+        | Some inc -> return (inc, op :: acc)
+      ) (inc, []) ops
+  in
+  let is_valid_endorsement endorsement =
+    validate_operation initial_inc endorsement >>=? function
+    | None -> return None
+    | Some inc -> finalize_construction inc >>= begin function
+        | Ok _ -> return (Some endorsement)
+        | Error _ -> return None
+      end
+  in
+  filter_map_s is_valid_endorsement endorsements >>=? fun _endorsements ->
+  filter_valid_operations initial_inc votes >>=? fun (inc, votes) ->
+  filter_valid_operations inc anonymous >>=? fun (inc, anonymous) ->
+  filter_valid_operations inc managers >>=? fun (_, managers) ->
+  return @@ List.map List.rev [ endorsements ; votes ; anonymous ; managers ]
+
 let bake_slot
     cctxt
     state
@@ -525,28 +575,46 @@ let bake_slot
   let protocol_data =
     forge_faked_protocol_data ~priority ~seed_nonce_hash in
   let operations = classify_operations operations in
-  Alpha_block_services.Helpers.Preapply.block
+  (* Don't validate if current block is genesis *)
-    cctxt ~chain ~block
+  begin
-    ~timestamp ~sort:true ~protocol_data operations >>= function
+    (* Don't load an alpha context if still in genesis *)
+    if Protocol_hash.(bi.protocol = bi.next_protocol) then
+      filter_invalid_operations cctxt state bi operations
+    else
+      return operations
+  end >>= function
   | Error errs ->
-      lwt_log_error "Error while prevalidating operations:@\n%a"
+      lwt_log_error "Error while filtering invalid operations (client-side) :@\n%a"
         pp_print_error
         errs >>= fun () ->
       return None
-  | Ok (shell_header, operations) ->
+  | Ok operations ->
-      lwt_debug
+      retry_call
-        "Computed candidate block after %a (slot %d): %a/%d fitness: %a"
+        (fun () ->
-        Block_hash.pp_short bi.hash priority
+           Alpha_block_services.Helpers.Preapply.block
-        (Format.pp_print_list
+             cctxt ~chain ~block
-           ~pp_sep:(fun ppf () -> Format.fprintf ppf "+")
+             ~timestamp ~sort:true ~protocol_data operations)
-           (fun ppf operations -> Format.fprintf ppf "%d" (List.length operations.Preapply_result.applied)))
+        ~msg:"Error while prevalidating operations" ()
-        operations
+      >>= function
-        total_op_count
+      | Error errs ->
-        Fitness.pp shell_header.fitness >>= fun () ->
+          lwt_log_error "Error while prevalidating operations:@\n%a"
-      let operations =
+            pp_print_error
-        List.map (fun l -> List.map snd l.Preapply_result.applied) operations in
+            errs >>= fun () ->
-      return
+          return None
-        (Some (bi, priority, shell_header, operations, delegate, seed_nonce_hash))
+      | Ok (shell_header, operations) ->
+          lwt_debug
+            "Computed candidate block after %a (slot %d): %a/%d fitness: %a"
+            Block_hash.pp_short bi.hash priority
+            (Format.pp_print_list
+               ~pp_sep:(fun ppf () -> Format.fprintf ppf "+")
+               (fun ppf operations -> Format.fprintf ppf "%d" (List.length operations.Preapply_result.applied)))
+            operations
+            total_op_count
+            Fitness.pp shell_header.fitness >>= fun () ->
+          let operations =
+            List.map (fun l -> List.map snd l.Preapply_result.applied) operations in
+          return
+            (Some (bi, priority, shell_header, operations, delegate, seed_nonce_hash))
 
 let fittest
     (_, _, (h1: Block_header.shell_header), _, _, _)
@@ -635,6 +703,7 @@ let check_error p =
 let create
     (cctxt : #Proto_alpha.full)
     ?max_priority
+    ~(context_path: string)
     (delegates: public_key_hash list)
     (block_stream: Client_baking_blocks.block_info tzresult Lwt_stream.t)
     (bi: Client_baking_blocks.block_info) =
@@ -651,7 +720,9 @@ let create
         last_get_block := Some t ;
         t
     | Some t -> t in
-  let state = create_state genesis_hash delegates bi in
+  lwt_debug "Opening shell context" >>= fun () ->
+  Client_baking_simulator.load_context ~context_path >>= fun index ->
+  let state = create_state genesis_hash index delegates bi in
   check_error @@ insert_block cctxt ?max_priority state bi >>= fun () ->
 
   (* main loop *)
@@ -694,16 +765,15 @@ let create
   cctxt#message "Starting the baker" >>= fun () ->
   worker_loop ()
 
-
-
 (* Wrapper around previous [create] function that handles the case of
    unavailable blocks (empty block chain). *)
 let create
     (cctxt : #Proto_alpha.full)
     ?max_priority
+    ~(context_path: string)
     (delegates: public_key_hash list)
     (block_stream: Client_baking_blocks.block_info tzresult Lwt_stream.t) =
   Client_baking_scheduling.wait_for_first_block
     ~info:cctxt#message
     block_stream
-    (create cctxt ?max_priority delegates block_stream)
+    (create cctxt ?max_priority ~context_path delegates block_stream)

src/proto_alpha/lib_delegate/client_baking_forge.mli

@@ -79,6 +79,7 @@ end
 val create:
   #Proto_alpha.full ->
   ?max_priority: int ->
+  context_path: string ->
   public_key_hash list ->
   Client_baking_blocks.block_info tzresult Lwt_stream.t ->
   unit tzresult Lwt.t

src/proto_alpha/lib_delegate/client_baking_lib.ml

@@ -101,31 +101,3 @@ let reveal_nonces cctxt () =
   Client_baking_forge.get_unrevealed_nonces
     cctxt cctxt#block >>=? fun nonces ->
   do_reveal cctxt cctxt#block nonces
-
-let run_daemon cctxt ?max_priority ~endorsement_delay delegates ~endorsement ~baking ~denunciation =
-  let endorser =
-    if endorsement then
-      Client_daemon.Endorser.run cctxt
-        ~delay:endorsement_delay
-        ~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
-        delegates >>=? fun () -> return ()
-    else return ()
-  in
-  let baker =
-    if baking then
-      Client_daemon.Baker.run cctxt
-        ?max_priority
-        ~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
-        delegates >>=? fun () -> return ()
-    else return ()
-  in
-  let accuser =
-    if denunciation then
-      Client_daemon.Accuser.run cctxt >>=? fun () -> return ()
-    else
-      return ()
-  in
-  endorser >>=? fun () ->
-  baker >>=? fun () ->
-  accuser >>=? fun () ->
-  return ()

src/proto_alpha/lib_delegate/client_baking_lib.mli

@@ -45,14 +45,3 @@ val reveal_nonces :
   #Proto_alpha.full ->
   unit ->
   unit Error_monad.tzresult Lwt.t
-
-(** Initialize the baking daemon *)
-val run_daemon:
-  #Proto_alpha.full ->
-  ?max_priority:int ->
-  endorsement_delay:int ->
-  public_key_hash list ->
-  endorsement:bool ->
-  baking:bool ->
-  denunciation:bool ->
-  unit Error_monad.tzresult Lwt.t

src/proto_alpha/lib_delegate/client_baking_simulator.ml

@@ -0,0 +1,64 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Proto_alpha
+open Alpha_context
+
+module Main = Alpha_environment.Lift(Main)
+
+type incremental = {
+  predecessor: Client_baking_blocks.block_info ;
+  context : Context.t ;
+  state: Main.validation_state ;
+  rev_operations: Operation.packed list ;
+  header: Tezos_base.Block_header.shell_header ;
+}
+
+let load_context ~context_path =
+  Context.init ~readonly:true context_path
+
+let begin_construction (_cctxt : #Proto_alpha.full) index predecessor =
+  let { Client_baking_blocks.context } = predecessor in
+  Context.checkout_exn index context >>= fun context ->
+  let timestamp = Time.now () in
+  let predecessor_hash = predecessor.hash in
+  (* Shell_services.Blocks.header cctxt ~chain:`Main ~block:(`Hash (predecessor_hash, 0)) ()
+   * >>=? fun { shell ; _ } -> *)
+  let header : Tezos_base.Block_header.shell_header = Tezos_base.Block_header.{
+      predecessor = predecessor_hash ;
+      proto_level = 0 (* shell.proto_level *) ;
+      validation_passes = 0 (* shell.validation_passes *) ;
+      fitness = predecessor.fitness (* shell.fitness *) ;
+      timestamp ;
+      level = 0l (* shell.level *) ;
+      context = Context_hash.zero ;
+      operations_hash = Operation_list_list_hash.zero ;
+    } in
+  Main.begin_construction
+    ~predecessor_context: context
+    ~predecessor_timestamp: header.timestamp
+    ~predecessor_fitness: header.fitness
+    ~predecessor_level: header.level
+    ~predecessor:predecessor_hash
+    ~timestamp
+    () >>=? fun state ->
+  return {
+    predecessor ;
+    context ;
+    state ;
+    rev_operations = [] ;
+    header ;
+  }
+
+let add_operation st ( op : Operation.packed ) =
+  Main.apply_operation st.state op >>=? fun (state, _) ->
+  return { st with state ; rev_operations = op :: st.rev_operations }
+
+let finalize_construction inc =
+  Main.finalize_block inc.state >>=? fun _ -> return ()

src/proto_alpha/lib_delegate/client_baking_simulator.mli

@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Proto_alpha
+open Alpha_context
+
+type incremental = {
+  predecessor: Client_baking_blocks.block_info ;
+  context : Context.t ;
+  state: Main.validation_state ;
+  rev_operations: Operation.packed list ;
+  header: Tezos_base.Block_header.shell_header ;
+}
+
+val load_context : context_path:string -> Context.index Lwt.t
+
+val begin_construction : #Proto_alpha.full -> Context.index -> Client_baking_blocks.block_info -> incremental tzresult Lwt.t
+
+val add_operation : incremental -> Operation.packed -> incremental tzresult Lwt.t
+
+val finalize_construction : incremental -> unit tzresult Lwt.t

src/proto_alpha/lib_delegate/client_daemon.ml

@@ -18,14 +18,13 @@ module Endorser = struct
 
 end
 
-
 module Baker = struct
 
-  let run (cctxt : #Proto_alpha.full) ?max_priority ?min_date delegates =
+  let run (cctxt : #Proto_alpha.full) ?max_priority ?min_date ~context_path delegates =
     Client_baking_blocks.monitor_heads
       cctxt `Main >>=? fun block_stream ->
     Client_baking_forge.create cctxt
-      ?max_priority delegates block_stream >>=? fun () ->
+      ?max_priority ~context_path delegates block_stream >>=? fun () ->
     ignore min_date;
     return ()
 

src/proto_alpha/lib_delegate/client_daemon.mli

@@ -23,6 +23,7 @@ module Baker : sig
     #Proto_alpha.full ->
     ?max_priority: int ->
     ?min_date: Time.t ->
+    context_path: string ->
     public_key_hash list -> unit tzresult Lwt.t
 end
 

src/proto_alpha/lib_delegate/delegate_commands.ml

@@ -54,14 +54,18 @@ let baker_commands () =
       title = "Commands related to the baker daemon." }
   in
   [
-    command ~group ~desc: "Launch a daemon that handles delegate operations."
+    command ~group ~desc: "Launch the baker daemon."
       (args1 max_priority_arg)
-      (prefixes [ "launch" ]
+      (prefixes [ "launch" ; "with" ; "context" ]
+       @@ string
+         ~name:"Context path"
+         ~desc:"Path to the shell context"
        @@ seq_of_param Client_keys.Public_key_hash.alias_param)
-      (fun max_priority delegates cctxt ->
+      (fun max_priority context_path delegates cctxt ->
          Client_daemon.Baker.run cctxt
            ?max_priority
            ~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
+           ~context_path
            (List.map snd delegates)
       )
   ]

src/proto_alpha/lib_delegate/jbuild

@@ -10,6 +10,7 @@
               tezos-client-base
               tezos-client-alpha
               tezos-client-commands
+              tezos-storage
               tezos-rpc))
   (library_flags (:standard -linkall))
   (modules (:standard \
@@ -22,6 +23,7 @@
                     -open Tezos_client_base
                     -open Tezos_client_alpha
                     -open Tezos_client_commands
+                    -open Tezos_storage
                     -open Tezos_rpc))))
 
 (library