From 5a21f3c1596d372b896dc678c04d2a0e6d6a74e7 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Thu, 20 Oct 2016 18:54:16 +0200 Subject: [PATCH 1/2] Reengineer the PROTOCOL signature to prepare for the multi-step validator. --- src/Makefile.files | 2 + src/client/client_node_rpcs.ml | 2 +- src/client/client_node_rpcs.mli | 4 +- .../alpha/baker/client_mining_forge.ml | 6 +- src/node/shell/node.ml | 59 +++--- src/node/shell/node.mli | 4 +- src/node/shell/node_rpc_services.ml | 8 +- src/node/shell/node_rpc_services.mli | 4 +- src/node/shell/prevalidation.ml | 176 ++++++++++++++++ src/node/shell/prevalidation.mli | 42 ++++ src/node/shell/prevalidator.ml | 164 +++++---------- src/node/shell/prevalidator.mli | 10 +- src/node/shell/validator.ml | 12 +- src/node/updater/protocol.mli | 107 +++++----- src/node/updater/register.ml | 28 ++- src/node/updater/updater.ml | 60 ------ src/node/updater/updater.mli | 17 -- src/proto/alpha/apply.ml | 190 +++++------------- src/proto/alpha/main.ml | 77 ++++++- src/proto/alpha/services_registration.ml | 12 +- src/proto/demo/main.ml | 44 ++-- src/proto/environment/updater.mli | 108 +++++----- src/proto/genesis/main.ml | 44 +++- test/shell/test_state.ml | 10 +- test/test-basic.sh | 13 +- 25 files changed, 682 insertions(+), 521 deletions(-) create mode 100644 src/node/shell/prevalidation.ml create mode 100644 src/node/shell/prevalidation.mli diff --git a/src/Makefile.files b/src/Makefile.files index 6b8376184..1bc67514c 100644 --- a/src/Makefile.files +++ b/src/Makefile.files @@ -227,6 +227,7 @@ NODE_LIB_INTFS := \ node/shell/distributed_db_message.mli \ node/shell/distributed_db_metadata.mli \ node/shell/distributed_db.mli \ + node/shell/prevalidation.mli \ node/shell/prevalidator.mli \ node/shell/validator.mli \ \ @@ -273,6 +274,7 @@ FULL_NODE_LIB_IMPLS := \ node/shell/distributed_db_message.ml \ node/shell/distributed_db_metadata.ml \ node/shell/distributed_db.ml \ + node/shell/prevalidation.ml \ node/shell/prevalidator.ml \ node/shell/validator.ml \ \ diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index ecc13baa5..c6edf65a4 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -70,7 +70,7 @@ module Blocks = struct timestamp: Time.t option ; } type preapply_result = Services.Blocks.preapply_result = { - operations: error Updater.preapply_result ; + operations: error Prevalidation.preapply_result ; fitness: MBytes.t list ; timestamp: Time.t ; } diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index 050562e73..d22b59e7b 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -98,7 +98,7 @@ module Blocks : sig val pending_operations: config -> block -> - (error Updater.preapply_result * Operation_hash.Set.t) tzresult Lwt.t + (error Prevalidation.preapply_result * Operation_hash.Set.t) tzresult Lwt.t type block_info = { hash: Block_hash.t ; @@ -131,7 +131,7 @@ module Blocks : sig unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t type preapply_result = { - operations: error Updater.preapply_result ; + operations: error Prevalidation.preapply_result ; fitness: MBytes.t list ; timestamp: Time.t ; } diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index 3ec313828..a3c991391 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -93,7 +93,9 @@ let forge_block cctxt block Client_node_rpcs.Blocks.pending_operations cctxt block >>=? fun (ops, pendings) -> return (Operation_hash.Set.elements @@ - Operation_hash.Set.union (Updater.operations ops) pendings) + Operation_hash.Set.union + (Prevalidation.preapply_result_operations ops) + pendings) | Some operations -> return operations end >>=? fun operations -> begin @@ -417,7 +419,7 @@ let mine cctxt state = block >>=? fun (res, ops) -> let operations = let open Operation_hash.Set in - elements (union ops (Updater.operations res)) in + elements (union ops (Prevalidation.preapply_result_operations res)) in let request = List.length operations in Client_node_rpcs.Blocks.preapply cctxt.rpc_config block ~timestamp ~sort:true operations >>= function diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 5cc16c4ee..bc5304276 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -276,13 +276,20 @@ module RPC = struct let pv = Validator.prevalidator validator in let net_state = Validator.net_state validator in State.Valid_block.Current.head net_state >>= fun head -> - let ctxt = Prevalidator.context pv in - Context.get_fitness ctxt >|= fun fitness -> - { (convert head) with - hash = prevalidation_hash ; - fitness ; - timestamp = Prevalidator.timestamp pv - } + Prevalidator.context pv >>= function + | Error _ -> Lwt.fail Not_found + | Ok ctxt -> + Context.get_fitness ctxt >>= fun fitness -> + Context.get_protocol ctxt >>= fun protocol -> + let operations = + let pv_result, _ = Prevalidator.operations pv in + Some [ pv_result.applied ] in + let timestamp = Prevalidator.timestamp pv in + Lwt.return + { (convert head) with + hash = prevalidation_hash ; + protocol = Some protocol ; + fitness ; operations ; timestamp } let get_context node block = match block with @@ -304,7 +311,9 @@ module RPC = struct | ( `Prevalidation | `Test_prevalidation ) as block -> let validator, _net = get_net node block in let pv = Validator.prevalidator validator in - Lwt.return (Some (Prevalidator.context pv)) + Prevalidator.context pv >>= function + | Error _ -> Lwt.fail Not_found + | Ok ctxt -> Lwt.return (Some ctxt) let operations node block = match block with @@ -321,9 +330,9 @@ module RPC = struct | (`Prevalidation | `Test_prevalidation) as block -> let validator, _net = get_net node block in let pv = Validator.prevalidator validator in - let { Updater.applied }, _ = Prevalidator.operations pv in + let { Prevalidation.applied }, _ = Prevalidator.operations pv in Lwt.return [applied] - | `Hash hash-> + | `Hash hash -> read_valid_block node hash >|= function | None -> [] | Some { operations } -> operations @@ -347,24 +356,24 @@ module RPC = struct State.Valid_block.Current.head net_state >>= fun head -> get_pred net_db n head >>= fun b -> Prevalidator.pending ~block:b prevalidator >|= fun ops -> - Updater.empty_result, ops + Prevalidation.empty_result, ops | `Genesis -> let net = node.mainnet_net in State.Valid_block.Current.genesis net >>= fun b -> let validator = get_validator node `Genesis in let prevalidator = Validator.prevalidator validator in Prevalidator.pending ~block:b prevalidator >|= fun ops -> - Updater.empty_result, ops + Prevalidation.empty_result, ops | `Hash h -> begin get_validator_per_hash node h >>= function | None -> - Lwt.return (Updater.empty_result, Operation_hash.Set.empty) + Lwt.return (Prevalidation.empty_result, Operation_hash.Set.empty) | Some (validator, net_db) -> let net_state = Distributed_db.state net_db in let prevalidator = Validator.prevalidator validator in State.Valid_block.read_exn net_state h >>= fun block -> Prevalidator.pending ~block prevalidator >|= fun ops -> - Updater.empty_result, ops + Prevalidation.empty_result, ops end let protocols { state } = @@ -396,17 +405,21 @@ module RPC = struct read_valid_block node hash >>= function | None -> Lwt.return (error_exn Not_found) | Some data -> return data - end >>=? fun { hash ; context ; protocol } -> - begin - match protocol with - | None -> failwith "Unknown protocol version" - | Some protocol -> return protocol - end >>=? fun ((module Proto) as protocol) -> + end >>=? fun predecessor -> let net_db = Validator.net_db node.mainnet_validator in - Prevalidator.preapply - net_db context protocol hash timestamp sort ops >>=? fun (ctxt, r) -> + map_p + (fun h -> + Distributed_db.Operation.read net_db h >>= function + | None -> failwith "Unknown operation %a" Operation_hash.pp h + | Some po -> return (h, po)) + ops >>=? fun rops -> + Prevalidation.start_prevalidation + ~predecessor ~timestamp >>=? fun validation_state -> + Prevalidation.prevalidate + validation_state ~sort rops >>=? fun (validation_state, r) -> + Prevalidation.end_prevalidation validation_state >>=? fun ctxt -> Context.get_fitness ctxt >>= fun fitness -> - return (fitness, r) + return (fitness, { r with applied = List.rev r.applied }) let complete node ?block str = match block with diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli index 502682f43..edfd4351d 100644 --- a/src/node/shell/node.mli +++ b/src/node/shell/node.mli @@ -66,7 +66,7 @@ module RPC : sig t -> (Operation_hash.t * Store.Operation.t) Lwt_stream.t * Watcher.stopper val pending_operations: - t -> block -> (error Updater.preapply_result * Operation_hash.Set.t) Lwt.t + t -> block -> (error Prevalidation.preapply_result * Operation_hash.Set.t) Lwt.t val protocols: t -> Protocol_hash.t list Lwt.t @@ -82,7 +82,7 @@ module RPC : sig t -> block -> timestamp:Time.t -> sort:bool -> Operation_hash.t list -> - (Protocol.fitness * error Updater.preapply_result) tzresult Lwt.t + (Protocol.fitness * error Prevalidation.preapply_result) tzresult Lwt.t val validate: t -> Net_id.t -> Block_hash.t -> unit tzresult Lwt.t diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index d3d572e0f..1891d076a 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -157,7 +157,7 @@ module Blocks = struct (opt "timestamp" Time.encoding))) type preapply_result = { - operations: error Updater.preapply_result ; + operations: error Prevalidation.preapply_result ; fitness: MBytes.t list ; timestamp: Time.t ; } @@ -171,7 +171,7 @@ module Blocks = struct (obj3 (req "timestamp" Time.encoding) (req "fitness" Fitness.encoding) - (req "operations" (Updater.preapply_result_encoding Error.encoding)))) + (req "operations" (Prevalidation.preapply_result_encoding Error.encoding)))) let block_path : (unit, unit * block) RPC.Path.path = RPC.Path.(root / "blocks" /: blocks_arg ) @@ -266,14 +266,14 @@ module Blocks = struct ~input: empty ~output: (conv - (fun ({ Updater.applied; branch_delayed ; branch_refused }, + (fun ({ Prevalidation.applied; branch_delayed ; branch_refused }, unprocessed) -> (applied, Operation_hash.Map.bindings branch_delayed, Operation_hash.Map.bindings branch_refused, Operation_hash.Set.elements unprocessed)) (fun (applied, branch_delayed, branch_refused, unprocessed) -> - ({ Updater.applied ; refused = Operation_hash.Map.empty ; + ({ Prevalidation.applied ; refused = Operation_hash.Map.empty ; branch_refused = List.fold_right (fun (k, o) -> Operation_hash.Map.add k o) diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index 98988a26c..fa24399bc 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -64,7 +64,7 @@ module Blocks : sig (unit, unit * block, unit, (Net_id.t * Time.t) option) RPC.service val pending_operations: (unit, unit * block, unit, - error Updater.preapply_result * Hash.Operation_hash.Set.t) RPC.service + error Prevalidation.preapply_result * Hash.Operation_hash.Set.t) RPC.service type list_param = { operations: bool ; @@ -85,7 +85,7 @@ module Blocks : sig timestamp: Time.t option ; } type preapply_result = { - operations: error Updater.preapply_result ; + operations: error Prevalidation.preapply_result ; fitness: MBytes.t list ; timestamp: Time.t ; } diff --git a/src/node/shell/prevalidation.ml b/src/node/shell/prevalidation.ml new file mode 100644 index 000000000..0822bae23 --- /dev/null +++ b/src/node/shell/prevalidation.ml @@ -0,0 +1,176 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +type 'error preapply_result = { + applied: Operation_hash.t list; + refused: 'error list Operation_hash.Map.t; + branch_refused: 'error list Operation_hash.Map.t; + branch_delayed: 'error list Operation_hash.Map.t; +} + +let empty_result = { + applied = [] ; + refused = Operation_hash.Map.empty ; + branch_refused = Operation_hash.Map.empty ; + branch_delayed = Operation_hash.Map.empty ; +} + +let map_result f r = { + applied = r.applied; + refused = Operation_hash.Map.map f r.refused ; + branch_refused = Operation_hash.Map.map f r.branch_refused ; + branch_delayed = Operation_hash.Map.map f r.branch_delayed ; +} + +let preapply_result_encoding error_encoding = + let open Data_encoding in + let refused_encoding = tup2 Operation_hash.encoding error_encoding in + let build_list map = Operation_hash.Map.bindings map in + let build_map list = + List.fold_right + (fun (k, e) m -> Operation_hash.Map.add k e m) + list Operation_hash.Map.empty in + conv + (fun { applied ; refused ; branch_refused ; branch_delayed } -> + (applied, build_list refused, + build_list branch_refused, build_list branch_delayed)) + (fun (applied, refused, branch_refused, branch_delayed) -> + let refused = build_map refused in + let branch_refused = build_map branch_refused in + let branch_delayed = build_map branch_delayed in + { applied ; refused ; branch_refused ; branch_delayed }) + (obj4 + (req "applied" (list Operation_hash.encoding)) + (req "refused" (list refused_encoding)) + (req "branch_refused" (list refused_encoding)) + (req "branch_delayed" (list refused_encoding))) + +let preapply_result_operations t = + let ops = + List.fold_left + (fun acc x -> Operation_hash.Set.add x acc) + Operation_hash.Set.empty t.applied in + let ops = + Operation_hash.Map.fold + (fun x _ acc -> Operation_hash.Set.add x acc) + t.branch_delayed ops in + let ops = + Operation_hash.Map.fold + (fun x _ acc -> Operation_hash.Set.add x acc) + t.branch_refused ops in + ops + +let empty_result = + { applied = [] ; + refused = Operation_hash.Map.empty ; + branch_refused = Operation_hash.Map.empty ; + branch_delayed = Operation_hash.Map.empty } + +let merge_result r r' = + let open Updater in + let merge _key a b = + match a, b with + | None, None -> None + | Some x, None -> Some x + | _, Some y -> Some y in + let merge_map = + Operation_hash.Map.merge merge in + { applied = r'.applied @ r.applied ; + refused = merge_map r.refused r'.refused ; + branch_refused = merge_map r.branch_refused r'.branch_refused ; + branch_delayed = r'.branch_delayed } + +let rec apply_operations apply_operation state ~sort ops = + Lwt_list.fold_left_s + (fun (state, r) (hash, op) -> + apply_operation state op >>= function + | Ok state -> + let applied = hash :: r.applied in + Lwt.return (state, { r with applied} ) + | Error errors -> + match classify_errors errors with + | `Branch -> + let branch_refused = + Operation_hash.Map.add hash errors r.branch_refused in + Lwt.return (state, { r with branch_refused }) + | `Permanent -> + let refused = + Operation_hash.Map.add hash errors r.refused in + Lwt.return (state, { r with refused }) + | `Temporary -> + let branch_delayed = + Operation_hash.Map.add hash errors r.branch_delayed in + Lwt.return (state, { r with branch_delayed })) + (state, empty_result) + ops >>= fun (state, r) -> + match r.applied with + | _ :: _ when sort -> + let rechecked_operations = + List.filter + (fun (hash, _) -> Operation_hash.Map.mem hash r.branch_delayed) + ops in + apply_operations apply_operation + state ~sort rechecked_operations >>=? fun (state, r') -> + return (state, merge_result r r') + | _ -> + return (state, r) + +type prevalidation_state = + State : { proto : 'a proto ; state : 'a } + -> prevalidation_state + +and 'a proto = + (module Updater.REGISTRED_PROTOCOL + with type validation_state = 'a) + +let start_prevalidation + ~predecessor: + { State.Valid_block.protocol ; + hash = predecessor ; + context = predecessor_context ; + timestamp = predecessor_timestamp } + ~timestamp = + let (module Proto) = + match protocol with + | None -> assert false (* FIXME, this should not happen! *) + | Some protocol -> protocol in + Proto.begin_construction + ~predecessor_context + ~predecessor_timestamp + ~predecessor + ~timestamp >>=? fun state -> + return (State { proto = (module Proto) ; state }) + +let prevalidate + (State { proto = (module Proto) ; state }) + ~sort ops = + (* The operations list length is bounded by the size of the mempool, + where eventually an operation should not stay more than one hours. *) + Lwt_list.map_p + (fun (h, op) -> + match Proto.parse_operation h op with + | Error _ -> + (* the operation will never be validated in the + current context, it is silently ignored. It may be + reintroduced in the loop by the next `flush`. *) + Lwt.return_none + | Ok p -> Lwt.return (Some (h, p))) + ops >>= fun ops -> + let ops = Utils.unopt_list ops in + let ops = + if sort then + let compare (_, op1) (_, op2) = Proto.compare_operations op1 op2 in + List.sort compare ops + else ops in + apply_operations Proto.apply_operation state ~sort ops >>=? fun (state, r) -> + return (State { proto = (module Proto) ; state }, r) + +let end_prevalidation (State { proto = (module Proto) ; state }) = + Proto.finalize_block state diff --git a/src/node/shell/prevalidation.mli b/src/node/shell/prevalidation.mli new file mode 100644 index 000000000..ce9a31cd8 --- /dev/null +++ b/src/node/shell/prevalidation.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type 'error preapply_result = { + applied: Operation_hash.t list; + refused: 'error list Operation_hash.Map.t; + (* e.g. invalid signature *) + branch_refused: 'error list Operation_hash.Map.t; + (* e.g. insufficent balance *) + branch_delayed: 'error list Operation_hash.Map.t; + (* e.g. timestamp in the future *) +} + +val empty_result : 'error preapply_result + +val preapply_result_operations : + 'error preapply_result -> Operation_hash.Set.t + +val preapply_result_encoding : + 'error list Data_encoding.t -> + 'error preapply_result Data_encoding.t + +type prevalidation_state + +val start_prevalidation : + predecessor: State.Valid_block.t -> + timestamp: Time.t -> + prevalidation_state tzresult Lwt.t + +val prevalidate : + prevalidation_state -> sort:bool -> + (Operation_hash.t * Store.Operation.t) list -> + (prevalidation_state * error preapply_result) tzresult Lwt.t + +val end_prevalidation : + prevalidation_state -> Context.t tzresult Lwt.t diff --git a/src/node/shell/prevalidator.ml b/src/node/shell/prevalidator.ml index 58f8b26f6..93fc62209 100644 --- a/src/node/shell/prevalidator.ml +++ b/src/node/shell/prevalidator.ml @@ -7,40 +7,7 @@ (* *) (**************************************************************************) - open Logging.Node.Prevalidator - -let preapply - net_db ctxt (module Proto : Updater.REGISTRED_PROTOCOL) - block timestamp sort ops = - lwt_debug "-> prevalidate (%d)" (List.length ops) >>= fun () -> - (* The operations list length is bounded by the size of the mempool, - where eventually an operation should not stay more than one hours. *) - Lwt_list.map_p - (fun h -> - Distributed_db.Operation.read net_db h >>= function - | None -> Lwt.return_none - | Some op -> - match Proto.parse_operation h op with - | Error _ -> - (* the operation will never be validated in the - current context, it is silently ignored. It may be - reintroduced in the loop by the next `flush`. *) - Lwt.return_none - | Ok p -> Lwt.return (Some p)) - ops >>= fun ops -> - Context.set_timestamp ctxt timestamp >>= fun ctxt -> - Proto.preapply ctxt block sort (Utils.unopt_list ops) >>= function - | Ok (ctxt, r) -> - lwt_debug "<- prevalidate (%d/%d/%d/%d)" - (List.length r.Updater.applied) - (Operation_hash.Map.cardinal r.Updater.refused) - (Operation_hash.Map.cardinal r.Updater.branch_refused) - (Operation_hash.Map.cardinal r.Updater.branch_delayed) >>= fun () -> - Lwt.return (Ok (ctxt, r)) - | Error errors -> - (* FIXME report internal error *) - lwt_debug "<- prevalidate (internal error)" >>= fun () -> - Lwt.return (Error errors) +open Logging.Node.Prevalidator let list_pendings net_db ~from_block ~to_block old_mempool = let rec pop_blocks ancestor hash mempool = @@ -75,22 +42,22 @@ let list_pendings net_db ~from_block ~to_block old_mempool = exception Invalid_operation of Operation_hash.t +open Prevalidation + type t = { net_db: Distributed_db.net ; flush: State.Valid_block.t -> unit; notify_operations: P2p.Peer_id.t -> Operation_hash.t list -> unit ; prevalidate_operations: bool -> Store.Operation.t list -> - (Operation_hash.t list * error Updater.preapply_result) tzresult Lwt.t ; - operations: unit -> error Updater.preapply_result * Operation_hash.Set.t ; + (Operation_hash.t list * error preapply_result) tzresult Lwt.t ; + operations: unit -> error preapply_result * Operation_hash.Set.t ; pending: ?block:State.Valid_block.t -> unit -> Operation_hash.Set.t Lwt.t ; timestamp: unit -> Time.t ; - context: unit -> Context.t ; - protocol: unit -> (module Updater.REGISTRED_PROTOCOL) ; + context: unit -> Context.t tzresult Lwt.t ; shutdown: unit -> unit Lwt.t ; } - let merge _key a b = match a, b with | None, None -> None @@ -105,27 +72,23 @@ let create net_db = let push_to_worker, worker_waiter = Lwt_utils.queue () in State.Valid_block.Current.head net_state >>= fun head -> - State.Valid_block.Current.protocol net_state >>= fun protocol -> State.Operation.list_pending net_state >>= fun initial_mempool -> let timestamp = ref (Time.now ()) in - begin - let (module Proto) = protocol in - Context.set_timestamp head.context !timestamp >>= fun ctxt -> - Proto.preapply ctxt head.hash false [] >|= function - | Error _ -> ref head.context - | Ok (ctxt, _) -> ref ctxt - end >>= fun context -> - + (start_prevalidation head !timestamp >|= ref) >>= fun validation_state -> let pending = Operation_hash.Table.create 53 in - let protocol = ref protocol in let head = ref head in - let operations = ref Updater.empty_result in + let operations = ref empty_result in let running_validation = ref Lwt.return_unit in let unprocessed = ref initial_mempool in let broadcast_unprocessed = ref false in - let set_context ctxt = - context := ctxt; + let set_validation_state state = + validation_state := state; + Lwt.return_unit in + + let reset_validation_state head timestamp = + start_prevalidation head timestamp >>= fun state -> + validation_state := state; Lwt.return_unit in let broadcast_operation ops = @@ -143,23 +106,29 @@ let create net_db = broadcast_unprocessed := false ; running_validation := begin begin - preapply - net_db !context !protocol !head.hash !timestamp true - (Operation_hash.Set.elements ops) >>= function - | Ok (ctxt, r) -> Lwt.return (ctxt, r) + Lwt_list.map_p + (fun h -> + Distributed_db.Operation.read net_db h >>= function + | None -> Lwt.return_none + | Some po -> Lwt.return_some (h, po)) + (Operation_hash.Set.elements ops) >>= fun rops -> + let rops = Utils.unopt_list rops in + (Lwt.return !validation_state >>=? fun validation_state -> + prevalidate validation_state ~sort:true rops) >>= function + | Ok (state, r) -> Lwt.return (Ok state, r) | Error err -> let r = - { Updater.empty_result with + { empty_result with branch_delayed = Operation_hash.Set.fold (fun op m -> Operation_hash.Map.add op err m) ops Operation_hash.Map.empty ; } in - Lwt.return (!context, r) - end >>= fun (ctxt, r) -> + Lwt.return (!validation_state, r) + end >>= fun (state, r) -> let filter_out s m = List.fold_right Operation_hash.Map.remove s m in operations := { - Updater.applied = List.rev_append r.applied !operations.applied ; + applied = List.rev_append r.applied !operations.applied ; refused = Operation_hash.Map.empty ; branch_refused = Operation_hash.Map.merge merge @@ -171,13 +140,13 @@ let create net_db = (filter_out r.applied !operations.branch_delayed) r.branch_delayed ; } ; - if broadcast then broadcast_operation r.Updater.applied ; + if broadcast then broadcast_operation r.applied ; Lwt_list.iter_s (fun (_op, _exns) -> (* FIXME *) (* Distributed_db.Operation.mark_invalid net_db op exns >>= fun _ -> *) Lwt.return_unit) - (Operation_hash.Map.bindings r.Updater.refused) >>= fun () -> + (Operation_hash.Map.bindings r.refused) >>= fun () -> (* TODO. Keep a bounded set of 'refused' operations. *) (* TODO. Log the error in some statistics associated to the peers that informed us of the operations. And @@ -185,7 +154,7 @@ let create net_db = (* TODO. Keep a bounded set of 'branch_refused' operations into the 'state'. It should be associated to the current block, and updated on 'set_current_head'. *) - set_context ctxt + set_validation_state state end; Lwt.catch (fun () -> !running_validation) @@ -209,22 +178,10 @@ let create net_db = Lwt_list.iter_s (function | `Prevalidate (ops, w, force) -> begin - let (module Proto) = !protocol in let result = - map_s (fun (h, b) -> - Distributed_db.Operation.known net_db h >>= function - | true -> - failwith - "Previously injected operation %a" - Operation_hash.pp_short h - | false -> - Lwt.return - (Proto.parse_operation h b - |> record_trace_exn (Invalid_operation h))) - (Operation_hash.Map.bindings ops) >>=? fun parsed_ops -> - Context.set_timestamp !context (Time.now ()) >>= fun ctxt -> - Proto.preapply - ctxt !head.hash true parsed_ops >>=? fun (ctxt, res) -> + let rops = Operation_hash.Map.bindings ops in + Lwt.return !validation_state >>=? fun validation_state -> + prevalidate validation_state ~sort:true rops >>=? fun (state, res) -> let register h = let op = Operation_hash.Map.find h ops in Distributed_db.Operation.inject @@ -237,18 +194,18 @@ let create net_db = { !operations with applied = h :: !operations.applied }; Lwt.return_unit ) - res.Updater.applied >>= fun () -> - broadcast_operation res.Updater.applied ; + res.applied >>= fun () -> + broadcast_operation res.applied ; begin if force then Lwt_list.iter_p (fun (h, _exns) -> register h) (Operation_hash.Map.bindings - res.Updater.branch_delayed) >>= fun () -> + res.branch_delayed) >>= fun () -> Lwt_list.iter_p (fun (h, _exns) -> register h) (Operation_hash.Map.bindings - res.Updater.branch_refused) >>= fun () -> + res.branch_refused) >>= fun () -> operations := { !operations with branch_delayed = @@ -262,7 +219,7 @@ let create net_db = else Lwt.return_unit end >>= fun () -> - set_context ctxt >>= fun () -> + set_validation_state (Ok state) >>= fun () -> return res in result >>= fun result -> @@ -299,32 +256,20 @@ let create net_db = lwt_debug "register %a" Operation_hash.pp_short op >>= fun () -> Lwt.return_unit | `Flush (new_head : State.Valid_block.t) -> - let new_protocol = - match new_head.protocol with - | None -> - assert false (* FIXME, this should not happen! *) - | Some protocol -> protocol in list_pendings net_db ~from_block:!head ~to_block:new_head - (Updater.operations !operations) >>= fun new_mempool -> + (preapply_result_operations !operations) >>= fun new_mempool -> lwt_debug "flush %a (mempool: %d)" Block_hash.pp_short new_head.hash (Operation_hash.Set.cardinal new_mempool) >>= fun () -> (* Reset the pre-validation context *) head := new_head ; - protocol := new_protocol ; - operations := Updater.empty_result ; + operations := empty_result ; broadcast_unprocessed := false ; unprocessed := new_mempool ; timestamp := Time.now () ; - (* Tag the context as a prevalidation context. *) - let (module Proto) = new_protocol in - Context.set_timestamp - new_head.context !timestamp >>= fun ctxt -> - Proto.preapply - ctxt new_head.hash false [] >>= function - | Error _ -> set_context new_head.context - | Ok (ctxt, _) -> set_context ctxt) + (* Reset the prevalidation context. *) + reset_validation_state new_head !timestamp) q >>= fun () -> worker_loop () in @@ -357,14 +302,15 @@ let create net_db = Lwt.cancel !running_validation; cancel () >>= fun () -> prevalidation_worker in - let pending ?block () = - let ops = Updater.operations !operations in + let ops = preapply_result_operations !operations in match block with | None -> Lwt.return ops | Some to_block -> - list_pendings net_db ~from_block:!head ~to_block ops - in + list_pendings net_db ~from_block:!head ~to_block ops in + let context () = + Lwt.return !validation_state >>=? fun prevalidation_state -> + Prevalidation.end_prevalidation prevalidation_state in Lwt.return { net_db ; flush ; @@ -376,8 +322,7 @@ let create net_db = !unprocessed) ; pending ; timestamp = (fun () -> !timestamp) ; - context = (fun () -> !context) ; - protocol = (fun () -> !protocol) ; + context ; shutdown ; } @@ -388,7 +333,6 @@ let operations pv = pv.operations () let pending ?block pv = pv.pending ?block () let timestamp pv = pv.timestamp () let context pv = pv.context () -let protocol pv = pv.protocol () let shutdown pv = pv.shutdown () let inject_operation pv ?(force = false) (op: Store.Operation.t) = @@ -404,15 +348,15 @@ let inject_operation pv ?(force = false) (op: Store.Operation.t) = (Unclassified "Prevalidator.inject_operation: invalid network") >>=? fun () -> pv.prevalidate_operations force [op] >>=? function - | ([h], { Updater.applied = [h'] }) when Operation_hash.equal h h' -> + | ([h], { applied = [h'] }) when Operation_hash.equal h h' -> return () - | ([h], { Updater.refused }) + | ([h], { refused }) when Operation_hash.Map.cardinal refused = 1 -> wrap_error h refused - | ([h], { Updater.branch_refused }) + | ([h], { branch_refused }) when Operation_hash.Map.cardinal branch_refused = 1 && not force -> wrap_error h branch_refused - | ([h], { Updater.branch_delayed }) + | ([h], { branch_delayed }) when Operation_hash.Map.cardinal branch_delayed = 1 && not force -> wrap_error h branch_delayed | _ -> diff --git a/src/node/shell/prevalidator.mli b/src/node/shell/prevalidator.mli index 7e17fd7d2..47cf052ae 100644 --- a/src/node/shell/prevalidator.mli +++ b/src/node/shell/prevalidator.mli @@ -43,13 +43,7 @@ val inject_operation: val flush: t -> State.Valid_block.t -> unit val timestamp: t -> Time.t -val operations: t -> error Updater.preapply_result * Operation_hash.Set.t -val context: t -> Context.t -val protocol: t -> (module Updater.REGISTRED_PROTOCOL) +val operations: t -> error Prevalidation.preapply_result * Operation_hash.Set.t +val context: t -> Context.t tzresult Lwt.t val pending: ?block:State.Valid_block.t -> t -> Operation_hash.Set.t Lwt.t - -val preapply: - Distributed_db.net -> Context.t -> (module Updater.REGISTRED_PROTOCOL) -> - Block_hash.t -> Time.t -> bool -> Operation_hash.t list -> - (Context.t * error Updater.preapply_result) tzresult Lwt.t diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index f3d2aebce..09af946f7 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -190,7 +190,6 @@ let apply_block net db Protocol_hash.pp_short Proto.hash >>= fun () -> lwt_debug "validation of %a: parsing header..." Block_hash.pp_short hash >>= fun () -> - Lwt.return (Proto.parse_block block pred.timestamp) >>=? fun parsed_header -> lwt_debug "validation of %a: parsing operations..." Block_hash.pp_short hash >>= fun () -> map2_s @@ -201,8 +200,15 @@ let apply_block net db operations >>=? fun parsed_operations -> lwt_debug "validation of %a: applying block..." Block_hash.pp_short hash >>= fun () -> - Proto.apply - patched_context parsed_header parsed_operations >>=? fun new_context -> + Proto.begin_application + ~predecessor_context:patched_context + ~predecessor_timestamp:pred.timestamp + block >>=? fun state -> + fold_left_s (fun state op -> + Proto.apply_operation state op >>=? fun state -> + return state) + state parsed_operations >>=? fun state -> + Proto.finalize_block state >>=? fun new_context -> lwt_log_info "validation of %a: success" Block_hash.pp_short hash >>= fun () -> return new_context diff --git a/src/node/updater/protocol.mli b/src/node/updater/protocol.mli index 70f274892..c8fb8d788 100644 --- a/src/node/updater/protocol.mli +++ b/src/node/updater/protocol.mli @@ -44,22 +44,6 @@ type raw_block = Store.Block_header.t = { proto: MBytes.t ; } -(** Result of the {!PROTOCOL.preapply} function of the protocol for - discriminating cacheable operations from droppable ones. *) -type 'error preapply_result = - { applied: Operation_hash.t list; - (** Operations that where successfully applied. *) - refused: 'error list Operation_hash.Map.t; - (** Operations which triggered a context independent, unavoidable - error (e.g. invalid signature). *) - branch_refused: 'error list Operation_hash.Map.t; - (** Operations which triggered an error that might not arise in a - different context (e.g. past account counter, insufficent - balance). *) - branch_delayed: 'error list Operation_hash.Map.t; - (** Operations which triggered an error that might not arise in a - future update of this context (e.g. futur account counter). *) } - (** This is the signature of a Tezos protocol implementation. It has access to the standard library and the Environment module. *) module type PROTOCOL = sig @@ -73,47 +57,80 @@ module type PROTOCOL = sig (** The maximum size of operations in bytes *) val max_operation_data_length : int - (** The version specific part of blocks. *) - type block - (** The maximum size of block headers in bytes *) val max_block_length : int (** The maximum *) val max_number_of_operations : int - (** The parsing / preliminary validation function for blocks. Its - role is to check that the raw header is well formed, and to - produce a pre-decomposed value of the high level, protocol defined - {!block} type. It does not have access to the storage - context. It may store the hash and raw bytes for later signature - verification by {!apply} or {!preapply}. The timestamp of the - predecessor block is also provided for early delay checks. *) - val parse_block : raw_block -> Time.t -> block tzresult - (** The parsing / preliminary validation function for operations. Similar to {!parse_block}. *) val parse_operation : Operation_hash.t -> raw_operation -> operation tzresult - (** The main protocol function that validates blocks. It receives the - block header and the list of associated operations, as - pre-decomposed by {!parse_block} and {!parse_operation}. *) - val apply : - Context.t -> block -> operation list -> - Context.t tzresult Lwt.t + (** Basic ordering of operations. [compare_operations op1 op2] means + that [op1] should appear before [op2] in a block. *) + val compare_operations : operation -> operation -> int - (** The auxiliary protocol entry point that validates pending - operations out of blocks. This function tries to apply the all - operations in the given order, and returns which applications have - suceeded and which ones have failed. The first two parameters - are a context in which to apply the operations and the hash of the - preceding block. This function is used by the shell for accepting or - dropping operations, as well as the mining client to check that a - sequence of operations forms a valid block. *) - val preapply : - Context.t -> Block_hash.t -> bool -> operation list -> - (Context.t * error preapply_result) tzresult Lwt.t + (** A functional state that is transmitted through the steps of a + block validation sequence. It must retain the current state of + the store (that can be extracted from the outside using + {!current_context}, and whose final value is produced by + {!finalize_block}). It can also contain the information that + must be remembered during the validation, which must be + immutable (as validator or baker implementations are allowed to + pause, replay or backtrack during the validation process). *) + type validation_state + + (** Access the context at a given validation step. *) + val current_context : validation_state -> Context.t tzresult Lwt.t + + (** Checks that a block is well formed in a given context. This + function should run quickly, as its main use is to reject bad + blocks from the network as early as possible. The input context + is the one resulting of an ancestor block of same protocol + version, not necessarily the one of its predecessor. *) + val precheck_block : + ancestor_context: Context.t -> + ancestor_timestamp: Time.t -> + raw_block -> + unit tzresult Lwt.t + + (** The first step in a block validation sequence. Initializes a + validation context for validating a block. Takes as argument the + {!raw_block} to initialize the context for this block, patching + the context resulting of the application of the predecessor + block passed as parameter. The function {!precheck_block} may + not have been called before [begin_application], so all the + check performed by the former must be repeated in the latter. *) + val begin_application : + predecessor_context: Context.t -> + predecessor_timestamp: Time.t -> + raw_block -> + validation_state tzresult Lwt.t + + (** Initializes a validation context for constructing a new block + (as opposed to validating an existing block). Since there is no + {!raw_block} header available, the parts that it provides are + passed as arguments (predecessor block hash, context resulting + of the application of the predecessor block, and timestamp). *) + val begin_construction : + predecessor_context: Context.t -> + predecessor_timestamp: Time.t -> + predecessor: Block_hash.t -> + timestamp: Time.t -> + validation_state tzresult Lwt.t + + (** Called after {!begin_application} (or {!begin_construction}) and + before {!finalize_block}, with each operation in the block. *) + val apply_operation : + validation_state -> operation -> validation_state tzresult Lwt.t + + (** The last step in a block validation sequence. It produces the + context that will be used as input for the validation of its + successor block candidates. *) + val finalize_block : + validation_state -> Context.t tzresult Lwt.t (** The list of remote procedures exported by this implementation *) val rpc_services : Context.t RPC.directory diff --git a/src/node/updater/register.ml b/src/node/updater/register.ml index 4e0ef55e1..df950446d 100644 --- a/src/node/updater/register.ml +++ b/src/node/updater/register.ml @@ -33,12 +33,30 @@ let register (module Proto : Protocol.PACKED_PROTOCOL) = let module V = struct include Proto include Make(Proto) - let parse_block d t = parse_block d t |> wrap_error + let precheck_block + ~ancestor_context ~ancestor_timestamp + raw_block = + precheck_block + ~ancestor_context ~ancestor_timestamp + raw_block >|= wrap_error + let begin_application + ~predecessor_context ~predecessor_timestamp + raw_block = + begin_application + ~predecessor_context ~predecessor_timestamp + raw_block >|= wrap_error + let begin_construction + ~predecessor_context ~predecessor_timestamp + ~predecessor ~timestamp = + begin_construction + ~predecessor_context ~predecessor_timestamp + ~predecessor ~timestamp >|= wrap_error + let current_context c = + current_context c >|= wrap_error + let apply_operation c o = + apply_operation c o >|= wrap_error + let finalize_block c = finalize_block c >|= wrap_error let parse_operation h b = parse_operation h b |> wrap_error - let apply c h ops = apply c h ops >|= wrap_error - let preapply c h b ops = - (preapply c h b ops >|= wrap_error) >>=? fun (ctxt, r) -> - return (ctxt, Updater.map_result (fun l -> [Ecoproto_error l]) r) let configure_sandbox c j = configure_sandbox c j >|= wrap_error end in diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index eba04a444..a0462d5ee 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -53,51 +53,6 @@ type raw_block = Store.Block_header.t = { } let raw_block_encoding = Store.Block_header.encoding -type 'error preapply_result = 'error Protocol.preapply_result = { - applied: Operation_hash.t list; - refused: 'error list Operation_hash.Map.t; - branch_refused: 'error list Operation_hash.Map.t; - branch_delayed: 'error list Operation_hash.Map.t; -} - -let empty_result = { - applied = [] ; - refused = Operation_hash.Map.empty ; - branch_refused = Operation_hash.Map.empty ; - branch_delayed = Operation_hash.Map.empty ; -} - -let map_result f r = { - applied = r.applied; - refused = Operation_hash.Map.map f r.refused ; - branch_refused = Operation_hash.Map.map f r.branch_refused ; - branch_delayed = Operation_hash.Map.map f r.branch_delayed ; -} - -let preapply_result_encoding error_encoding = - let open Data_encoding in - let refused_encoding = tup2 Operation_hash.encoding error_encoding in - let build_list map = Operation_hash.Map.bindings map in - let build_map list = - List.fold_right - (fun (k, e) m -> Operation_hash.Map.add k e m) - list Operation_hash.Map.empty in - conv - (fun { applied ; refused ; branch_refused ; branch_delayed } -> - (applied, build_list refused, - build_list branch_refused, build_list branch_delayed)) - (fun (applied, refused, branch_refused, branch_delayed) -> - let refused = build_map refused in - let branch_refused = build_map branch_refused in - let branch_delayed = build_map branch_delayed in - { applied ; refused ; branch_refused ; branch_delayed }) - (obj4 - (req "applied" (list Operation_hash.encoding)) - (req "refused" (list refused_encoding)) - (req "branch_refused" (list refused_encoding)) - (req "branch_delayed" (list refused_encoding))) - - (** Version table *) module VersionTable = Protocol_hash.Table @@ -200,18 +155,3 @@ let compile hash units = log_error "Internal error while compiling %a" Protocol_hash.pp hash; Lwt.return loaded end - -let operations t = - let ops = - List.fold_left - (fun acc x -> Operation_hash.Set.add x acc) - Operation_hash.Set.empty t.applied in - let ops = - Operation_hash.Map.fold - (fun x _ acc -> Operation_hash.Set.add x acc) - t.branch_delayed ops in - let ops = - Operation_hash.Map.fold - (fun x _ acc -> Operation_hash.Set.add x acc) - t.branch_refused ops in - ops diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index cc60f7597..bda578c43 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -41,23 +41,6 @@ type raw_block = Store.Block_header.t = { } val raw_block_encoding: raw_block Data_encoding.t -type 'error preapply_result = 'error Protocol.preapply_result = { - applied: Operation_hash.t list; - refused: 'error list Operation_hash.Map.t; (* e.g. invalid signature. *) - branch_refused: 'error list Operation_hash.Map.t; (* e.g. past account counter; - insufficent balance *) - branch_delayed: 'error list Operation_hash.Map.t; (* e.g. futur account counter. *) -} - -val empty_result: 'error preapply_result -val map_result: ('a list -> 'b list) -> 'a preapply_result -> 'b preapply_result - -val operations: 'error preapply_result -> Operation_hash.Set.t - -val preapply_result_encoding : - 'error list Data_encoding.t -> - 'error preapply_result Data_encoding.t - module type PROTOCOL = Protocol.PROTOCOL module type REGISTRED_PROTOCOL = sig val hash: Protocol_hash.t diff --git a/src/proto/alpha/apply.ml b/src/proto/alpha/apply.ml index bd66499d0..e959b8578 100644 --- a/src/proto/alpha/apply.ml +++ b/src/proto/alpha/apply.ml @@ -68,15 +68,11 @@ let apply_delegate_operation_content (Wrong_voting_period (level.voting_period, period)) >>=? fun () -> Amendment.record_ballot ctxt delegate proposal ballot -let rec is_reject = function - | [] -> false - | Script_interpreter.Reject _ :: _ -> true - | _ :: err -> is_reject err - type error += Non_scripted_contract_with_parameter type error += Scripted_contract_without_paramater -let apply_manager_operation_content ctxt origination_nonce accept_failing_script source = function +let apply_manager_operation_content + ctxt origination_nonce source = function | Transaction { amount ; parameters ; destination } -> begin Contract.spend ctxt source amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt -> @@ -84,7 +80,7 @@ let apply_manager_operation_content ctxt origination_nonce accept_failing_script | None -> begin match parameters with | None | Some (Prim (_, "Unit", [])) -> - return (ctxt, origination_nonce) + return (ctxt, origination_nonce, None) | Some _ -> fail Non_scripted_contract_with_parameter end | Some { code ; storage } -> @@ -102,12 +98,9 @@ let apply_manager_operation_content ctxt origination_nonce accept_failing_script Contract.update_script_storage_and_fees ctxt destination Script_interpreter.dummy_storage_fee storage_res >>=? fun ctxt -> - return (ctxt, origination_nonce) + return (ctxt, origination_nonce, None) | Error err -> - if accept_failing_script && is_reject err then - return (ctxt, origination_nonce) - else - Lwt.return (Error err) + return (ctxt, origination_nonce, Some err) end | Origination { manager ; delegate ; script ; spendable ; delegatable ; credit } -> @@ -122,10 +115,10 @@ let apply_manager_operation_content ctxt origination_nonce accept_failing_script ~manager ~delegate ~balance:credit ?script ~spendable ~delegatable >>=? fun (ctxt, _, origination_nonce) -> - return (ctxt, origination_nonce) + return (ctxt, origination_nonce, None) | Delegation delegate -> Contract.set_delegate ctxt source delegate >>=? fun ctxt -> - return (ctxt, origination_nonce) + return (ctxt, origination_nonce, None) let check_signature_and_update_public_key ctxt id public_key op = begin @@ -138,9 +131,8 @@ let check_signature_and_update_public_key ctxt id public_key op = Operation.check_signature public_key op >>=? fun () -> return ctxt -(* TODO document parameters *) let apply_sourced_operation - ctxt accept_failing_script miner_contract pred_block block_prio + ctxt miner_contract pred_block block_prio operation origination_nonce ops = match ops with | Manager_operations { source ; public_key ; fee ; counter ; operations = contents } -> @@ -156,11 +148,14 @@ let apply_sourced_operation | None -> return ctxt | Some contract -> Contract.credit ctxt contract fee) >>=? fun ctxt -> - fold_left_s (fun (ctxt, origination_nonce) content -> - Contract.must_exist ctxt source >>=? fun () -> - apply_manager_operation_content ctxt origination_nonce - accept_failing_script source content) - (ctxt, origination_nonce) contents + fold_left_s (fun (ctxt, origination_nonce, err) content -> + match err with + | Some _ -> return (ctxt, origination_nonce, err) + | None -> + Contract.must_exist ctxt source >>=? fun () -> + apply_manager_operation_content + ctxt origination_nonce source content) + (ctxt, origination_nonce, None) contents | Delegate_operations { source ; operations = contents } -> let delegate = Ed25519.Public_key.hash source in check_signature_and_update_public_key @@ -171,25 +166,25 @@ let apply_sourced_operation apply_delegate_operation_content ctxt delegate pred_block block_prio content) ctxt contents >>=? fun ctxt -> - return (ctxt, origination_nonce) + return (ctxt, origination_nonce, None) | Dictator_operation (Activate hash) -> let dictator_pubkey = Constants.dictator_pubkey ctxt in Operation.check_signature dictator_pubkey operation >>=? fun () -> activate ctxt hash >>= fun ctxt -> - return (ctxt, origination_nonce) + return (ctxt, origination_nonce, None) | Dictator_operation (Activate_testnet hash) -> let dictator_pubkey = Constants.dictator_pubkey ctxt in Operation.check_signature dictator_pubkey operation >>=? fun () -> set_test_protocol ctxt hash >>= fun ctxt -> fork_test_network ctxt >>= fun ctxt -> - return (ctxt, origination_nonce) + return (ctxt, origination_nonce, None) let apply_anonymous_operation ctxt miner_contract origination_nonce kind = match kind with | Seed_nonce_revelation { level ; nonce } -> let level = Level.from_raw ctxt level in - Nonce.reveal ctxt level nonce >>=? fun (ctxt, delegate_to_reward, - reward_amount) -> + Nonce.reveal ctxt level nonce + >>=? fun (ctxt, delegate_to_reward, reward_amount) -> Reward.record ctxt delegate_to_reward level.cycle reward_amount >>=? fun ctxt -> begin @@ -214,7 +209,7 @@ let apply_anonymous_operation ctxt miner_contract origination_nonce kind = return (ctxt, origination_nonce) let apply_operation - ctxt accept_failing_script miner_contract pred_block block_prio operation = + ctxt miner_contract pred_block block_prio operation = match operation.contents with | Anonymous_operations ops -> let origination_nonce = Contract.initial_origination_nonce operation.hash in @@ -222,13 +217,13 @@ let apply_operation (fun (ctxt, origination_nonce) -> apply_anonymous_operation ctxt miner_contract origination_nonce) (ctxt, origination_nonce) ops >>=? fun (ctxt, origination_nonce) -> - return (ctxt, Contract.originated_contracts origination_nonce) + return (ctxt, Contract.originated_contracts origination_nonce, None) | Sourced_operations op -> let origination_nonce = Contract.initial_origination_nonce operation.hash in apply_sourced_operation - ctxt accept_failing_script miner_contract pred_block block_prio - operation origination_nonce op >>=? fun (ctxt, origination_nonce) -> - return (ctxt, Contract.originated_contracts origination_nonce) + ctxt miner_contract pred_block block_prio + operation origination_nonce op >>=? fun (ctxt, origination_nonce, err) -> + return (ctxt, Contract.originated_contracts origination_nonce, err) let may_start_new_cycle ctxt = Mining.dawn_of_a_new_cycle ctxt >>=? function @@ -250,58 +245,37 @@ let may_start_new_cycle ctxt = ctxt last_cycle reward_date >>=? fun ctxt -> return ctxt -let apply_main ctxt accept_failing_script block pred_timestamp operations = - (* read only checks *) +let begin_construction ctxt = + Fitness.increase ctxt + +let begin_application ctxt block pred_timestamp = Mining.check_proof_of_work_stamp ctxt block >>=? fun () -> Mining.check_fitness_gap ctxt block >>=? fun () -> - Mining.check_mining_rights ctxt block pred_timestamp >>=? fun delegate_pkh -> - Mining.check_signature ctxt block delegate_pkh >>=? fun () -> - (* automatic bonds payment *) - Mining.pay_mining_bond ctxt block delegate_pkh >>=? fun ctxt -> - (* do effectful stuff *) + Mining.check_mining_rights ctxt block pred_timestamp >>=? fun miner -> + Mining.check_signature ctxt block miner >>=? fun () -> + Mining.pay_mining_bond ctxt block miner >>=? fun ctxt -> Fitness.increase ctxt >>=? fun ctxt -> - let priority = block.proto.mining_slot.priority in - fold_left_s (fun ctxt operation -> - apply_operation - ctxt accept_failing_script - (Some (Contract.default_contract delegate_pkh)) - block.shell.predecessor priority operation - >>=? fun (ctxt, _contracts) -> return ctxt) - ctxt operations >>=? fun ctxt -> + return (ctxt, miner) + +let finalize_application ctxt block miner op_count = (* end of level (from this point nothing should fail) *) + let priority = block.Block.proto.mining_slot.priority in let reward = Mining.base_mining_reward ctxt ~priority in Nonce.record_hash ctxt - delegate_pkh reward block.proto.seed_nonce_hash >>=? fun ctxt -> + miner reward block.proto.seed_nonce_hash >>=? fun ctxt -> Reward.pay_due_rewards ctxt >>=? fun ctxt -> Level.increment_current ctxt >>=? fun ctxt -> (* end of cycle *) may_start_new_cycle ctxt >>=? fun ctxt -> Amendment.may_start_new_voting_cycle ctxt >>=? fun ctxt -> - return ctxt - -type error += Internal_error of string - -let apply ctxt accept_failing_script block pred_timestamp operations = - (init ctxt >>=? fun ctxt -> - get_prevalidation ctxt >>= function - | true -> - fail (Internal_error "we should not call `apply` after `preapply`!") - | false -> - apply_main ctxt accept_failing_script block pred_timestamp operations >>=? fun ctxt -> - Level.current ctxt >>=? fun { level } -> - let level = Raw_level.diff level Raw_level.root in - Fitness.get ctxt >>=? fun fitness -> - let commit_message = - (* TODO: add more info ? *) - Format.asprintf "lvl %ld, fit %Ld" level fitness in - finalize ~commit_message ctxt) - -let empty_result = - { Updater.applied = []; - refused = Operation_hash.Map.empty; - branch_refused = Operation_hash.Map.empty; - branch_delayed = Operation_hash.Map.empty; - } + Level.current ctxt >>=? fun { level } -> + let level = Raw_level.to_int32 level in + Fitness.get ctxt >>=? fun fitness -> + let commit_message = + Format.asprintf + "lvl %ld, fit %Ld, prio %ld, %d ops" + level fitness priority op_count in + return (commit_message, ctxt) let compare_operations op1 op2 = match op1.contents, op2.contents with @@ -320,75 +294,3 @@ let compare_operations op1 op2 = (* Manager operations with smaller counter are pre-validated first. *) Int32.compare op1.counter op2.counter end - -let merge_result r r' = - let open Updater in - let merge _key a b = - match a, b with - | None, None -> None - | Some x, None -> Some x - | _, Some y -> Some y in - { applied = r'.applied @ r.applied ; - refused = Operation_hash.Map.merge merge r.refused r'.refused ; - branch_refused = - Operation_hash.Map.merge merge r.branch_refused r'.branch_refused ; - branch_delayed = r'.branch_delayed ; - } - -let prevalidate ctxt pred_block sort operations = - let operations = - if sort then List.sort compare_operations operations else operations in - let rec loop ctxt operations = - (Lwt_list.fold_left_s - (fun (ctxt, r) op -> - apply_operation ctxt false None pred_block 0l op >>= function - | Ok (ctxt, _contracts) -> - let applied = op.hash :: r.Updater.applied in - Lwt.return (ctxt, { r with Updater.applied} ) - | Error errors -> - match classify_errors errors with - | `Branch -> - let branch_refused = - Operation_hash.Map.add op.hash errors r.Updater.branch_refused in - Lwt.return (ctxt, { r with Updater.branch_refused }) - | `Permanent -> - let refused = - Operation_hash.Map.add op.hash errors r.Updater.refused in - Lwt.return (ctxt, { r with Updater.refused }) - | `Temporary -> - let branch_delayed = - Operation_hash.Map.add op.hash errors r.Updater.branch_delayed in - Lwt.return (ctxt, { r with Updater.branch_delayed })) - (ctxt, empty_result) - operations >>= fun (ctxt, r) -> - match r.Updater.applied with - | _ :: _ when sort -> - let rechecked_operations = - List.filter - (fun op -> Operation_hash.Map.mem op.hash r.Updater.branch_delayed) - operations in - loop ctxt rechecked_operations >>=? fun (ctxt, r') -> - return (ctxt, merge_result r r') - | _ -> - return (ctxt, r)) in - loop ctxt operations - -let preapply ctxt pred_block sort operations = - let result = - init ctxt >>=? fun ctxt -> - begin - get_prevalidation ctxt >>= function - | true -> return ctxt - | false -> - set_prevalidation ctxt >>= fun ctxt -> - Fitness.increase ctxt >>=? fun ctxt -> - return ctxt - end >>=? fun ctxt -> - prevalidate ctxt pred_block sort operations >>=? fun (ctxt, r) -> - (* TODO should accept failing script in the last round ? - or: what should we export to let the miner decide *) - finalize ctxt >>=? fun ctxt -> - return (ctxt, r) in - (* "Reify" errors into options. *) - result >>|? function (ctxt, r) -> - (ctxt, { r with Updater.applied = List.rev r.Updater.applied }) diff --git a/src/proto/alpha/main.ml b/src/proto/alpha/main.ml index 56417a362..b764fe923 100644 --- a/src/proto/alpha/main.ml +++ b/src/proto/alpha/main.ml @@ -16,14 +16,6 @@ let parse_operation = Tezos_context.Operation.parse let max_operation_data_length = Tezos_context.Operation.max_operation_data_length -type block = - { header : Tezos_context.Block.header ; - pred_timestamp : Time.t } - -let parse_block raw_header pred_timestamp = - Tezos_context.Block.parse_header raw_header >>? fun header -> - Ok { header ; pred_timestamp } - let max_number_of_operations = Tezos_context.Constants.max_number_of_operations @@ -32,9 +24,72 @@ let max_block_length = let rpc_services = Services_registration.rpc_services -let apply ctxt block ops = - Apply.apply ctxt true block.header block.pred_timestamp ops +type validation_mode = + | Application of Tezos_context.Block.header * Tezos_context.public_key_hash + | Construction of { pred_block : Block_hash.t ; timestamp : Time.t } -let preapply = Apply.preapply +type validation_state = + { mode : validation_mode ; + ctxt : Tezos_context.t ; + op_count : int } + +let current_context { ctxt } = + Tezos_context.finalize ctxt + +let precheck_block + ~ancestor_context:_ + ~ancestor_timestamp:_ + raw_block = + Lwt.return (Tezos_context.Block.parse_header raw_block) >>=? fun _ -> + (* TODO: decide what other properties should be checked *) + return () + +let begin_application + ~predecessor_context:ctxt + ~predecessor_timestamp:pred_timestamp + raw_block = + Lwt.return (Tezos_context.Block.parse_header raw_block) >>=? fun header -> + Tezos_context.init ctxt >>=? fun ctxt -> + Apply.begin_application ctxt header pred_timestamp >>=? fun (ctxt, miner) -> + let mode = Application (header, miner) in + return { mode ; ctxt ; op_count = 0 } + +let begin_construction + ~predecessor_context:ctxt + ~predecessor_timestamp:_ + ~predecessor:pred_block + ~timestamp = + let mode = Construction { pred_block ; timestamp } in + Tezos_context.init ctxt >>=? fun ctxt -> + Apply.begin_construction ctxt >>=? fun ctxt -> + return { mode ; ctxt ; op_count = 0 } + +let apply_operation ({ mode ; ctxt ; op_count } as data) operation = + let pred_block, block_prio, miner_contract = + match mode with + | Construction { pred_block } -> + pred_block, 0l, None + | Application (block, delegate) -> + block.shell.predecessor, + block.proto.mining_slot.priority, + Some (Tezos_context.Contract.default_contract delegate) in + Apply.apply_operation + ctxt miner_contract pred_block block_prio operation + >>=? fun (ctxt, _contracts, _ignored_script_error) -> + let op_count = op_count + 1 in + return { data with ctxt ; op_count } + +let finalize_block { mode ; ctxt ; op_count } = match mode with + | Construction _ -> + Tezos_context.finalize ctxt >>=? fun ctxt -> + return ctxt + | Application (block, miner) -> + Apply.finalize_application + ctxt block miner op_count >>=? fun (commit_message, ctxt) -> + Tezos_context.finalize ~commit_message ctxt >>=? fun ctxt -> + return ctxt + +let compare_operations op1 op2 = + Apply.compare_operations op1 op2 let configure_sandbox = Tezos_context.configure_sandbox diff --git a/src/proto/alpha/services_registration.ml b/src/proto/alpha/services_registration.ml index b40f5f4b1..0d2261c22 100644 --- a/src/proto/alpha/services_registration.ml +++ b/src/proto/alpha/services_registration.ml @@ -89,10 +89,12 @@ let () = (*-- Context -----------------------------------------------------------------*) +type error += Unexpected_level_in_context + let level ctxt = Level.current ctxt >>=? fun level -> match Level.pred ctxt level with - | None -> fail (Apply.Internal_error "unexpected level in context") + | None -> fail Unexpected_level_in_context | Some level -> return level let () = register0 Services.Context.level level @@ -192,9 +194,11 @@ let () = Mining.mining_priorities ctxt level >>=? fun (Misc.LCons (miner_pkh, _)) -> let miner_contract = Contract.default_contract miner_pkh in let block_prio = 0l in - Apply.apply_operation ctxt false (Some miner_contract) pred_block block_prio operation - >>=? fun (_ctxt, contracts) -> - Error_monad.return contracts) ; + Apply.apply_operation + ctxt (Some miner_contract) pred_block block_prio operation + >>=? function + | (_ctxt, _, Some script_err) -> Lwt.return (Error script_err) + | (_ctxt, contracts, None) -> Lwt.return (Ok contracts)) ; let run_parameters ctxt (script, storage, input, amount, contract, origination_nonce) = let amount = match amount with diff --git a/src/proto/demo/main.ml b/src/proto/demo/main.ml index 71fe59bf9..2dde8adf2 100644 --- a/src/proto/demo/main.ml +++ b/src/proto/demo/main.ml @@ -10,14 +10,13 @@ type operation = Operation_hash.t let max_operation_data_length = 42 -type block = unit - let max_block_length = 42 let max_number_of_operations = 42 -let parse_block _ _pred_timestamp = Ok () let parse_operation h _ = Ok h +let compare_operations _ _ = 0 + module Fitness = struct let version_number = "\000" @@ -64,7 +63,34 @@ module Fitness = struct end -let apply ctxt () _operations = +type validation_state = Context.t + +let current_context ctxt = + return ctxt + +let precheck_block + ~ancestor_context:_ + ~ancestor_timestamp:_ + _raw_block = + return () + +let begin_application + ~predecessor_context:ctxt + ~predecessor_timestamp:_ + _raw_block = + return ctxt + +let begin_construction + ~predecessor_context:ctxt + ~predecessor_timestamp:_ + ~predecessor:_ + ~timestamp:_ = + return ctxt + +let apply_operation ctxt _ = + return ctxt + +let finalize_block ctxt = Fitness.increase ctxt >>=? fun ctxt -> Fitness.get ctxt >>=? fun fitness -> let commit_message = @@ -72,16 +98,6 @@ let apply ctxt () _operations = Context.set_commit_message ctxt commit_message >>= fun ctxt -> return ctxt -let preapply context _block_pred _sort operations = - Lwt.return - (Ok - (context, - { Updater.applied = List.map (fun h -> h) operations; - refused = Operation_hash.Map.empty; - branch_delayed = Operation_hash.Map.empty; - branch_refused = Operation_hash.Map.empty; - })) - let rpc_services = Services.rpc_services let configure_sandbox ctxt _ = Lwt.return (Ok ctxt) diff --git a/src/proto/environment/updater.mli b/src/proto/environment/updater.mli index 52e452f6a..223d32b09 100644 --- a/src/proto/environment/updater.mli +++ b/src/proto/environment/updater.mli @@ -37,24 +37,8 @@ type raw_block = { } val raw_block_encoding: raw_block Data_encoding.t -(** Result of the {!PROTOCOL.preapply} function of the protocol for - discriminating cacheable operations from droppable ones. *) -type 'error preapply_result = - { applied: Operation_hash.t list; - (** Operations that where successfully applied. *) - refused: 'error list Operation_hash.Map.t; - (** Operations which triggered a context independent, unavoidable - error (e.g. invalid signature). *) - branch_refused: 'error list Operation_hash.Map.t; - (** Operations which triggered an error that might not arise in a - different context (e.g. past account counter, insufficent - balance). *) - branch_delayed: 'error list Operation_hash.Map.t; - (** Operations which triggered an error that might not arise in a - future update of this context (e.g. futur account counter). *) } - (** This is the signature of a Tezos protocol implementation. It has - access to the Environment module. *) + access to the standard library and the Environment module. *) module type PROTOCOL = sig type error = .. @@ -66,46 +50,80 @@ module type PROTOCOL = sig (** The maximum size of operations in bytes *) val max_operation_data_length : int - (** The version specific part of blocks. *) - type block - (** The maximum size of block headers in bytes *) val max_block_length : int (** The maximum *) val max_number_of_operations : int - (** The parsing / preliminary validation function for blocks. Its - role is to check that the raw header is well formed, and to - produce a pre-decomposed value of the high level, protocol defined - {!block} type. It does not have access to the storage - context. It may store the hash and raw bytes for later signature - verification by {!apply} or {!preapply}. The timestamp of the - predecessor block is also provided for early delay checks. *) - val parse_block : raw_block -> Time.t -> block tzresult - (** The parsing / preliminary validation function for operations. Similar to {!parse_block}. *) val parse_operation : Operation_hash.t -> raw_operation -> operation tzresult - (** The main protocol function that validates blocks. It receives the - block header and the list of associated operations, as - pre-decomposed by {!parse_block} and {!parse_operation}. *) - val apply : - Context.t -> block -> operation list -> Context.t tzresult Lwt.t + (** Basic ordering of operations. [compare_operations op1 op2] means + that [op1] should appear before [op2] in a block. *) + val compare_operations : operation -> operation -> int - (** The auxiliary protocol entry point that validates pending - operations out of blocks. This function tries to apply the all - operations in the given order, and returns which applications have - suceeded and which ones have failed. The first two parameters - are a context in which to apply the operations and the hash of the - preceding block. This function is used by the shell for accepting or - dropping operations, as well as the mining client to check that a - sequence of operations forms a valid block. *) - val preapply : - Context.t -> Block_hash.t -> bool -> operation list -> - (Context.t * error preapply_result) tzresult Lwt.t + (** A functional state that is transmitted through the steps of a + block validation sequence. It must retain the current state of + the store (that can be extracted from the outside using + {!current_context}, and whose final value is produced by + {!finalize_block}). It can also contain the information that + must be remembered during the validation, which must be + immutable (as validator or baker implementations are allowed to + pause, replay or backtrack during the validation process). *) + type validation_state + + (** Access the context at a given validation step. *) + val current_context : validation_state -> Context.t tzresult Lwt.t + + (** Checks that a block is well formed in a given context. This + function should run quickly, as its main use is to reject bad + blocks from the network as early as possible. The input context + is the one resulting of an ancestor block of same protocol + version, not necessarily the one of its predecessor. *) + val precheck_block : + ancestor_context: Context.t -> + ancestor_timestamp: Time.t -> + raw_block -> + unit tzresult Lwt.t + + (** The first step in a block validation sequence. Initializes a + validation context for validating a block. Takes as argument the + {!raw_block} to initialize the context for this block, patching + the context resulting of the application of the predecessor + block passed as parameter. The function {!precheck_block} may + not have been called before [begin_application], so all the + check performed by the former must be repeated in the latter. *) + val begin_application : + predecessor_context: Context.t -> + predecessor_timestamp: Time.t -> + raw_block -> + validation_state tzresult Lwt.t + + (** Initializes a validation context for constructing a new block + (as opposed to validating an existing block). Since there is no + {!raw_block} header available, the parts that it provides are + passed as arguments (predecessor block hash, context resulting + of the application of the predecessor block, and timestamp). *) + val begin_construction : + predecessor_context: Context.t -> + predecessor_timestamp: Time.t -> + predecessor: Block_hash.t -> + timestamp: Time.t -> + validation_state tzresult Lwt.t + + (** Called after {!begin_application} (or {!begin_construction}) and + before {!finalize_block}, with each operation in the block. *) + val apply_operation : + validation_state -> operation -> validation_state tzresult Lwt.t + + (** The last step in a block validation sequence. It produces the + context that will be used as input for the validation of its + successor block candidates. *) + val finalize_block : + validation_state -> Context.t tzresult Lwt.t (** The list of remote procedures exported by this implementation *) val rpc_services : Context.t RPC.directory diff --git a/src/proto/genesis/main.ml b/src/proto/genesis/main.ml index df315dc00..aeee3f4c5 100644 --- a/src/proto/genesis/main.ml +++ b/src/proto/genesis/main.ml @@ -32,9 +32,10 @@ let () = (function Invalid_signature -> Some () | _ -> None) (fun () -> Invalid_signature) -type operation = () +type operation = unit let max_operation_data_length = 0 let parse_operation _h _op = Error [] +let compare_operations _ _ = 0 let max_number_of_operations = 0 type block = { @@ -48,7 +49,7 @@ let max_block_length = | None -> assert false | Some len -> len -let parse_block { Updater.shell ; proto } _pred_timestamp : block tzresult = +let parse_block { Updater.shell ; proto } : block tzresult = match Data_encoding.Binary.of_bytes Data.Command.signed_encoding proto with | None -> Error [Parsing_error] | Some (command, signature) -> Ok { shell ; command ; signature } @@ -60,7 +61,36 @@ let check_signature ctxt { shell ; command ; signature } = (Ed25519.Signature.check public_key signature bytes) Invalid_signature -let apply ctxt header _ops = +type validation_state = block * Context.t + +let current_context (_, ctxt) = + return ctxt + +let precheck_block + ~ancestor_context:_ + ~ancestor_timestamp:_ + raw_block = + Lwt.return (parse_block raw_block) >>=? fun _ -> + return () + +let begin_application + ~predecessor_context:ctxt + ~predecessor_timestamp:_ + raw_block = + Lwt.return (parse_block raw_block) >>=? fun block -> + return (block, ctxt) + +let begin_construction + ~predecessor_context:_ + ~predecessor_timestamp:_ + ~predecessor:_ + ~timestamp:_ = + Lwt.return (Error []) (* absurd *) + +let apply_operation _vctxt _ = + Lwt.return (Error []) (* absurd *) + +let finalize_block (header, ctxt) = check_signature ctxt header >>=? fun () -> Data.Init.may_initialize ctxt >>=? fun ctxt -> Context.set_fitness ctxt header.shell.fitness >>= fun ctxt -> @@ -79,14 +109,6 @@ let apply ctxt header _ops = Updater.fork_test_network ctxt >>= fun ctxt -> return ctxt -let preapply ctxt _block_pred _sort _ops = - return ( ctxt, - { Updater.applied = [] ; - refused = Operation_hash.Map.empty ; - branch_refused = Operation_hash.Map.empty ; - branch_delayed = Operation_hash.Map.empty ; - } ) - let rpc_services = Services.rpc_services let configure_sandbox = Data.Init.configure_sandbox diff --git a/test/shell/test_state.ml b/test/shell/test_state.ml index 56c6e52df..de2771c0d 100644 --- a/test/shell/test_state.ml +++ b/test/shell/test_state.ml @@ -162,8 +162,14 @@ let build_valid_chain state tbl vtbl otbl pred names = State.Block_header.read_opt state hash >>= fun block' -> equal_block ~msg:__LOC__ (Some block) block' ; Hashtbl.add tbl name (hash, block) ; - Lwt.return (Proto.parse_block block pred.timestamp) >>=? fun block -> - Proto.apply pred.context block [] >>=? fun ctxt -> + begin + Proto.begin_application + ~predecessor_context: pred.context + ~predecessor_timestamp: pred.timestamp + block >>=? fun vstate -> + (* no operations *) + Proto.finalize_block vstate + end >>=? fun ctxt -> State.Valid_block.store state hash ctxt >>=? fun _vblock -> State.Valid_block.read state hash >>=? fun vblock -> Hashtbl.add vtbl name vblock ; diff --git a/test/test-basic.sh b/test/test-basic.sh index d29a749eb..c764bf9d6 100755 --- a/test/test-basic.sh +++ b/test/test-basic.sh @@ -29,7 +29,13 @@ echo "Created node, pid: ${NODE_PID}, log: $DATA_DIR/LOG" sleep 3 -${CLIENT} list versions +${CLIENT} -block genesis list versions + +${CLIENT} -block genesis \ + activate \ + protocol ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK \ + with fitness 1 \ + and key edskRhxswacLW6jF6ULavDdzwqnKJVS4UcDTNiCyiH6H8ZNnn2pmNviL7pRNz9kRxxaWQFzEQEcZExGHKbwmuaAcoMegj5T99z ${CLIENT} add identity bootstrap1 tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx ${CLIENT} add public key bootstrap1 edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav @@ -39,11 +45,6 @@ ${CLIENT} add identity bootstrap3 tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU ${CLIENT} add identity bootstrap4 tz1b7tUupMgCNw2cCLpKTkSD1NZzB5TkP2sv ${CLIENT} add identity bootstrap5 tz1ddb9NMYHZi5UzPdzTZMYQQZoMub195zgv -${CLIENT} activate \ - protocol ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK \ - with fitness 1 \ - and key edskRhxswacLW6jF6ULavDdzwqnKJVS4UcDTNiCyiH6H8ZNnn2pmNviL7pRNz9kRxxaWQFzEQEcZExGHKbwmuaAcoMegj5T99z - sleep 2 KEY1=foo From 3b5a3eb50925e350cf5e75dbc58389c99b9afcee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 10 Apr 2017 22:58:36 +0200 Subject: [PATCH 2/2] Client: minor fix in the daemon. --- src/client/client_keys.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/client/client_keys.ml b/src/client/client_keys.ml index 7178c76a0..6f5b7114c 100644 --- a/src/client/client_keys.ml +++ b/src/client/client_keys.ml @@ -83,16 +83,17 @@ let get_key cctxt pkh = let get_keys cctxt = Secret_key.load cctxt >>=? fun sks -> - map_filter_s + Lwt_list.filter_map_s (fun (name, sk) -> - Lwt.catch begin fun () -> + begin Public_key.find cctxt name >>=? fun pk -> Public_key_hash.find cctxt name >>=? fun pkh -> - return (Some (name, pkh, pk, sk)) - end begin fun _ -> - return None - end) - sks + return (name, pkh, pk, sk) + end >>= function + | Ok r -> Lwt.return (Some r) + | Error _ -> Lwt.return_none) + sks >>= fun keys -> + return keys let list_keys cctxt = Public_key_hash.load cctxt >>=? fun l ->