balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Reengineer the PROTOCOL signature to prepare for the multi-step validator.

Browse Source
This commit is contained in:
Benjamin Canou 2016-10-20 18:54:16 +02:00 committed by Grégoire Henry
parent efdad6eaee
commit 5a21f3c159
25 changed files with 682 additions and 521 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Makefile.files
View File

@ -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 \
\

2
src/client/client_node_rpcs.ml
View File

@ -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 ;
}

4
src/client/client_node_rpcs.mli
View File

@ -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 ;
}

6
src/client/embedded/alpha/baker/client_mining_forge.ml
View File

@ -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

59
src/node/shell/node.ml
View File

@ -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

4
src/node/shell/node.mli
View File

@ -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

8
src/node/shell/node_rpc_services.ml
View File

@ -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)

4
src/node/shell/node_rpc_services.mli
View File

@ -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 ;
}

176
src/node/shell/prevalidation.ml Normal file
View File

@ -0,0 +1,176 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

42
src/node/shell/prevalidation.mli Normal file
View File

@ -0,0 +1,42 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

164
src/node/shell/prevalidator.ml
View File

@ -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
| _ ->

10
src/node/shell/prevalidator.mli
View File

@ -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

12
src/node/shell/validator.ml
View File

@ -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

107
src/node/updater/protocol.mli
View File

@ -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

28
src/node/updater/register.ml
View File

@ -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

60
src/node/updater/updater.ml
View File

@ -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

17
src/node/updater/updater.mli
View File

@ -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

190
src/proto/alpha/apply.ml
View File

@ -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 })

77
src/proto/alpha/main.ml
View File

@ -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

12
src/proto/alpha/services_registration.ml
View File

@ -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

44
src/proto/demo/main.ml
View File

@ -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)

108
src/proto/environment/updater.mli
View File

@ -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

44
src/proto/genesis/main.ml
View File

@ -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

10
test/shell/test_state.ml
View File

@ -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 ;

13
test/test-basic.sh
View File

@ -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