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

Shell: rework the preapply RPC

Browse Source 
It now takes a `proto_header` in parameter, and it returns a full
`shell_header`. This prepares the inclusion of the context's hash in the
`shell_header`.
This commit is contained in:
Grégoire Henry 2017-04-27 01:01:05 +02:00
parent 3b7a314669
commit 4bbc97aeb6
32 changed files with 475 additions and 539 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/client/client_node_rpcs.ml
View File

@ -15,9 +15,8 @@ module Services = Node_rpc_services
let errors cctxt =
call_service0 cctxt Services.Error.service ()
let forge_block cctxt ?net_id ?level ?proto_level ?predecessor ?timestamp fitness ops header =
call_service0 cctxt Services.forge_block
(net_id, level, proto_level, predecessor, timestamp, fitness, ops, header)
let forge_block_header cctxt header =
call_service0 cctxt Services.forge_block_header header
let validate_block cctxt net block =
call_err_service0 cctxt Services.validate_block (net, block)
@ -72,14 +71,14 @@ module Blocks = struct
test_network: Context.test_network;
}
type preapply_param = Services.Blocks.preapply_param = {
timestamp: Time.t ;
proto_header: MBytes.t ;
operations: operation list ;
sort: bool ;
timestamp: Time.t option ;
sort_operations: bool ;
}
type preapply_result = Services.Blocks.preapply_result = {
shell_header: Block_header.shell_header ;
operations: error Prevalidation.preapply_result ;
fitness: MBytes.t list ;
timestamp: Time.t ;
}
let net_id cctxt h =
call_service1 cctxt Services.Blocks.net_id h ()
@ -103,10 +102,11 @@ module Blocks = struct
let test_network cctxt h =
call_service1 cctxt Services.Blocks.test_network h ()
let preapply cctxt h ?timestamp ?(sort = false) operations =
let preapply cctxt h
?(timestamp = Time.now ()) ?(sort = false) ~proto_header operations =
call_err_service1
cctxt Services.Blocks.preapply h
{ operations ; sort ; timestamp }
{ timestamp ; proto_header ; sort_operations = sort ; operations }
let pending_operations cctxt block =
call_service1 cctxt Services.Blocks.pending_operations block ()
let info cctxt ?(include_ops = true) h =

20
src/client/client_node_rpcs.mli
View File

@ -12,22 +12,10 @@ open Client_rpcs
val errors:
config -> Json_schema.schema tzresult Lwt.t
val forge_block:
val forge_block_header:
config ->
?net_id:Net_id.t ->
?level:Int32.t ->
?proto_level:int ->
?predecessor:Block_hash.t ->
?timestamp:Time.t ->
Fitness.t ->
Operation_list_list_hash.t ->
MBytes.t ->
Block_header.t ->
MBytes.t tzresult Lwt.t
(** [forge_block cctxt ?net ?predecessor ?timestamp fitness ops
proto_hdr] returns the serialization of a block header with
[proto_hdr] as protocol-specific part. The arguments [?net] and
[?predecessor] are infered from the current head of main network,
and [?timestamp] defaults to [Time.now ()]. *)
val validate_block:
config ->
@ -141,9 +129,8 @@ module Blocks : sig
unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t
type preapply_result = {
shell_header: Block_header.shell_header ;
operations: error Prevalidation.preapply_result ;
fitness: MBytes.t list ;
timestamp: Time.t ;
}
val preapply:
@ -151,6 +138,7 @@ module Blocks : sig
block ->
?timestamp:Time.t ->
?sort:bool ->
proto_header:MBytes.t ->
operation list -> preapply_result tzresult Lwt.t
end

1
src/client/embedded/alpha/.merlin
View File

@ -9,4 +9,5 @@ S ../../../proto/alpha
B _tzbuild
FLG -open Client_embedded_proto_alpha
FLG -open Register_client_embedded_proto_alpha
FLG -open Environment
FLG -open Tezos_context

4
src/client/embedded/alpha/Makefile
View File

@ -51,8 +51,8 @@ NODEPENDS := webclient/webclient_proto_static.ml.deps
include ../Makefile.shared
${WEBOBJS}: OPENED_MODULES += Tezos_context
${OBJS}: OPENED_MODULES += Tezos_context
${WEBOBJS}: OPENED_MODULES += Environment Tezos_context
${OBJS}: OPENED_MODULES += Environment Tezos_context
predepend: concrete_parser.ml concrete_lexer.ml

7
src/client/embedded/alpha/baker/client_mining_daemon.ml
View File

@ -34,11 +34,8 @@ let run cctxt ?max_priority ~delay ?min_date delegates =
if Client_proto_args.Daemon.(!all || !mining) then begin
Client_mining_blocks.monitor
cctxt.rpc_config ?min_date ~min_heads:1 () >>=? fun block_stream ->
(* Temporary desactivate the monitoring of endorsement:
too slow for now. *)
(* Client_mining_operations.monitor_endorsement *)
(* cctxt >>= fun endorsement_stream -> *)
let endorsement_stream, _push = Lwt_stream.create () in
Client_mining_operations.monitor_endorsement
cctxt.rpc_config >>=? fun endorsement_stream ->
Client_mining_forge.create cctxt
?max_priority delegates block_stream endorsement_stream >>=? fun () ->
return ()

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

@ -10,7 +10,6 @@
open Client_commands
open Logging.Client.Mining
module Ed25519 = Environment.Ed25519
let generate_proof_of_work_nonce () =
Sodium.Random.Bigbytes.generate Constants.proof_of_work_nonce_size
@ -21,7 +20,7 @@ let generate_seed_nonce () =
| Error _ -> assert false
| Ok nonce -> nonce
let rec compute_stamp
let rec forge_block_header
cctxt block delegate_sk shell priority seed_nonce_hash =
Client_proto_rpcs.Constants.stamp_threshold
cctxt block >>=? fun stamp_threshold ->
@ -34,54 +33,79 @@ let rec compute_stamp
Ed25519.Signature.append delegate_sk unsigned_header in
let block_hash = Block_hash.hash_bytes [signed_header] in
if Mining.check_hash block_hash stamp_threshold then
proof_of_work_nonce
signed_header
else
loop () in
return (loop ())
let inject_block cctxt block
?force
~priority ~timestamp ~fitness ~seed_nonce
~src_sk operations =
let block = Client_rpcs.last_mined_block block in
Client_node_rpcs.Blocks.info cctxt block >>=? fun bi ->
let seed_nonce_hash = Nonce.hash seed_nonce in
Client_proto_rpcs.Context.next_level cctxt block >>=? fun level ->
let empty_proof_of_work_nonce =
MBytes.of_string
(String.make Constants_repr.proof_of_work_nonce_size '\000')
let forge_faked_proto_header ~priority ~seed_nonce_hash =
Tezos_context.Block_header.forge_unsigned_proto_header
{ priority ; seed_nonce_hash ;
proof_of_work_nonce = empty_proof_of_work_nonce }
let assert_valid_operations_hash shell_header operations =
let operations_hash =
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute (List.map (List.map (function Client_node_rpcs.Blob op -> Tezos_data.Operation.hash op | Hash oph -> oph)) operations)) in
let shell =
{ Tezos_data.Block_header.net_id = bi.net_id ; level = bi.level ;
proto_level = bi.proto_level ;
predecessor = bi.hash ; timestamp ; fitness ; operations_hash } in
compute_stamp cctxt block
src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce ->
Client_proto_rpcs.Helpers.Forge.block cctxt
block
~net_id:bi.net_id
~predecessor:bi.hash
~timestamp
~fitness
~operations_hash
~level:level.level
~proto_level:bi.proto_level
~priority:priority
~seed_nonce_hash
~proof_of_work_nonce
() >>=? fun unsigned_header ->
let signed_header = Ed25519.Signature.append src_sk unsigned_header in
(List.map Operation_list_hash.compute
(List.map
(List.map
(function
| Client_node_rpcs.Blob op -> Tezos_data.Operation.hash op
| Hash oph -> oph)) operations)) in
fail_unless
(Operation_list_list_hash.equal
operations_hash shell_header.Tezos_data.Block_header.operations_hash)
(failure
"Client_mining_forge.inject_block: \
inconsistent header.")
let inject_block cctxt
?force ~shell_header ~priority ~seed_nonce_hash ~src_sk operations =
assert_valid_operations_hash shell_header operations >>=? fun () ->
let block = `Hash shell_header.Tezos_data.Block_header.predecessor in
forge_block_header cctxt block
src_sk shell_header priority seed_nonce_hash >>=? fun signed_header ->
Client_node_rpcs.inject_block cctxt
?force signed_header operations >>=? fun block_hash ->
return block_hash
type error +=
| Failed_to_preapply of Client_node_rpcs.operation * error list
let () =
register_error_kind
`Permanent
~id:"Client_mining_forge.failed_to_preapply"
~title: "Fail to preapply an operation"
~description: ""
~pp:(fun ppf (op, err) ->
let h =
match op with
| Client_node_rpcs.Hash h -> h
| Blob op -> Tezos_data.Operation.hash op in
Format.fprintf ppf "@[Failed to preapply %a:@ %a@]"
Operation_hash.pp_short h
pp_print_error err)
Data_encoding.
(obj2
(req "operation" (dynamic_size Client_node_rpcs.operation_encoding))
(req "error" Node_rpc_services.Error.encoding))
(function
| Failed_to_preapply (hash, err) -> Some (hash, err)
| _ -> None)
(fun (hash, err) -> Failed_to_preapply (hash, err))
let forge_block cctxt block
?force
?operations ?(best_effort = operations = None) ?(sort = best_effort)
?timestamp
~priority
~seed_nonce ~src_sk () =
~seed_nonce_hash ~src_sk () =
let block = Client_rpcs.last_mined_block block in
Client_proto_rpcs.Context.next_level cctxt block >>=? fun { level } ->
begin
match operations with
| None ->
@ -103,6 +127,7 @@ let forge_block cctxt block
return (prio, time)
end
| `Auto (src_pkh, max_priority, free_mining) ->
Client_proto_rpcs.Context.next_level cctxt block >>=? fun { level } ->
Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate cctxt
?max_priority
~first_level:level
@ -119,16 +144,16 @@ let forge_block cctxt block
List.find (fun (l,p,_) -> l = level && p >= min_prio) possibilities in
return (prio, time)
with Not_found ->
Error_monad.failwith "No slot found at level %a" Raw_level.pp level
failwith "No slot found at level %a" Raw_level.pp level
end >>=? fun (priority, minimal_timestamp) ->
lwt_log_info "Mining block at level %a prio %d"
Raw_level.pp level priority >>= fun () ->
(* lwt_log_info "Mining block at level %a prio %d" *)
(* Raw_level.pp level priority >>= fun () -> *)
begin
match timestamp, minimal_timestamp with
| None, timestamp -> return timestamp
| Some timestamp, minimal_timestamp ->
if timestamp < minimal_timestamp then
Error_monad.failwith
failwith
"Proposed timestamp %a is earlier than minimal timestamp %a"
Time.pp_hum timestamp
Time.pp_hum minimal_timestamp
@ -136,23 +161,57 @@ let forge_block cctxt block
return timestamp
end >>=? fun timestamp ->
let request = List.length operations in
let proto_header = forge_faked_proto_header ~priority ~seed_nonce_hash in
Client_node_rpcs.Blocks.preapply
cctxt block ~timestamp ~sort operations >>=?
fun { operations ; fitness ; timestamp } ->
let valid = List.length operations.applied in
cctxt block ~timestamp ~sort ~proto_header operations >>=?
fun { operations = result ; shell_header } ->
let valid = List.length result.applied in
lwt_log_info "Found %d valid operations (%d refused) for timestamp %a"
valid (request - valid)
Time.pp_hum timestamp >>= fun () ->
lwt_log_info "Computed fitness %a" Fitness.pp fitness >>= fun () ->
lwt_log_info "Computed fitness %a"
Fitness.pp shell_header.fitness >>= fun () ->
if best_effort
|| ( Operation_hash.Map.is_empty operations.refused
&& Operation_hash.Map.is_empty operations.branch_refused
&& Operation_hash.Map.is_empty operations.branch_delayed ) then
inject_block cctxt ?force ~src_sk
~priority ~timestamp ~fitness ~seed_nonce block
[List.map (fun h -> Client_node_rpcs.Hash h) operations.applied]
|| ( Operation_hash.Map.is_empty result.refused
&& Operation_hash.Map.is_empty result.branch_refused
&& Operation_hash.Map.is_empty result.branch_delayed ) then
let operations =
if not best_effort then operations
else
let map =
List.fold_left
(fun map op ->
match op with
| Client_node_rpcs.Hash _ -> map
| Blob op ->
Operation_hash.Map.add (Tezos_data.Operation.hash op) op map)
Operation_hash.Map.empty operations in
List.map
(fun h ->
try Client_node_rpcs.Blob (Operation_hash.Map.find h map)
with _ -> Client_node_rpcs.Hash h)
result.applied in
inject_block cctxt
?force ~shell_header ~priority ~seed_nonce_hash ~src_sk
[operations]
else
failwith "Cannot (fully) validate the given operations."
Lwt.return_error @@
Utils.filter_map
(fun op ->
let h =
match op with
| Client_node_rpcs.Hash h -> h
| Blob op -> Tezos_data.Operation.hash op in
try Some (Failed_to_preapply
(op, Operation_hash.Map.find h result.refused))
with Not_found ->
try Some (Failed_to_preapply
(op, Operation_hash.Map.find h result.branch_refused))
with Not_found ->
try Some (Failed_to_preapply
(op, Operation_hash.Map.find h result.branch_delayed))
with Not_found -> None)
operations
(** Worker *)
@ -350,7 +409,6 @@ let safe_get_unrevealed_nonces cctxt block =
lwt_warn "Cannot read nonces: %a@." pp_print_error err >>= fun () ->
Lwt.return []
let get_delegates cctxt state =
match state.delegates with
| [] ->
@ -406,8 +464,10 @@ let insert_blocks cctxt ?max_priority state bis =
let mine cctxt state =
let slots = pop_mining_slots state in
map_p
(fun (timestamp, (bi, prio, delegate)) ->
let seed_nonce = generate_seed_nonce () in
let seed_nonce_hash = Nonce.hash seed_nonce in
Error_monad.map_filter_s
(fun (timestamp, (bi, priority, delegate)) ->
let block = `Hash bi.Client_mining_blocks.hash in
let timestamp =
if Block_hash.equal bi.Client_mining_blocks.hash state.genesis then
@ -417,7 +477,7 @@ let mine cctxt state =
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
lwt_debug "Try mining after %a (slot %d) for %s (%a)"
Block_hash.pp_short bi.hash
prio name Time.pp_hum timestamp >>= fun () ->
priority name Time.pp_hum timestamp >>= fun () ->
Client_node_rpcs.Blocks.pending_operations cctxt.rpc_config
block >>=? fun (res, ops) ->
let operations =
@ -425,40 +485,49 @@ let mine cctxt state =
List.map (fun x -> Client_node_rpcs.Hash x) @@
elements (union ops (Prevalidation.preapply_result_operations res)) in
let request = List.length operations in
let proto_header =
forge_faked_proto_header ~priority ~seed_nonce_hash in
Client_node_rpcs.Blocks.preapply cctxt.rpc_config block
~timestamp ~sort:true operations >>= function
~timestamp ~sort:true ~proto_header operations >>= function
| Error errs ->
lwt_log_error "Error while prevalidating operations:\n%a"
pp_print_error
errs >>= fun () ->
return None
| Ok { operations ; fitness ; timestamp } ->
| Ok { operations ; shell_header } ->
lwt_debug
"Computed condidate block after %a (slot %d): %d/%d fitness: %a"
Block_hash.pp_short bi.hash prio
Block_hash.pp_short bi.hash priority
(List.length operations.applied) request
Fitness.pp fitness
Fitness.pp shell_header.fitness
>>= fun () ->
return
(Some (bi, prio, fitness, timestamp, operations, delegate)))
(Some (bi, priority, shell_header, operations, delegate)))
slots >>=? fun candidates ->
let candidates =
List.sort
(fun (_,_,f1,_,_,_) (_,_,f2,_,_,_) -> ~- (Fitness.compare f1 f2))
(Utils.unopt_list candidates) in
(fun (_,_,h1,_,_) (_,_,h2,_,_) ->
match
Fitness.compare h1.Tezos_data.Block_header.fitness h2.fitness
with
| 0 ->
Time.compare h1.timestamp h2.timestamp
| cmp -> ~- cmp)
candidates in
match candidates with
| (bi, priority, fitness, timestamp, operations, delegate) :: _
when Fitness.compare state.best.fitness fitness < 0 -> begin
| (bi, priority, shell_header, operations, delegate) :: _
when Fitness.compare state.best.fitness shell_header.fitness < 0 ||
(Fitness.compare state.best.fitness shell_header.fitness = 0 &&
Time.compare shell_header.timestamp state.best.timestamp < 0) -> begin
let level = Raw_level.succ bi.level.level in
cctxt.message
"Select candidate block after %a (slot %d) fitness: %a"
Block_hash.pp_short bi.hash priority
Fitness.pp fitness >>= fun () ->
let seed_nonce = generate_seed_nonce () in
Fitness.pp shell_header.fitness >>= fun () ->
Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) ->
inject_block cctxt.rpc_config
~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce
(`Hash bi.hash) [List.map (fun h -> Client_node_rpcs.Hash h) operations.applied]
~force:true ~shell_header ~priority ~seed_nonce_hash ~src_sk
[List.map (fun h -> Client_node_rpcs.Hash h) operations.applied]
|> trace_exn (Failure "Error while injecting block") >>=? fun block_hash ->
State.record_block cctxt level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () ->
@ -470,7 +539,7 @@ let mine cctxt state =
name
Block_hash.pp_short bi.hash
Raw_level.pp level priority
Fitness.pp fitness
Fitness.pp shell_header.fitness
(List.length operations.applied) >>= fun () ->
return ()
end

11
src/client/embedded/alpha/baker/client_mining_forge.mli
View File

@ -15,12 +15,10 @@ val generate_seed_nonce: unit -> Nonce.t
val inject_block:
Client_rpcs.config ->
Client_proto_rpcs.block ->
?force:bool ->
shell_header:Block_header.shell_header ->
priority:int ->
timestamp:Time.t ->
fitness:Fitness.t ->
seed_nonce:Nonce.t ->
seed_nonce_hash:Nonce_hash.t ->
src_sk:secret_key ->
Client_node_rpcs.operation list list ->
Block_hash.t tzresult Lwt.t
@ -30,6 +28,9 @@ val inject_block:
will be used to compute the mining slot (level is
precomputed). [src_sk] is used to sign the block header. *)
type error +=
| Failed_to_preapply of Client_node_rpcs.operation * error list
val forge_block:
Client_rpcs.config ->
Client_proto_rpcs.block ->
@ -39,7 +40,7 @@ val forge_block:
?sort:bool ->
?timestamp:Time.t ->
priority:[`Set of int | `Auto of (public_key_hash * int option * bool)] ->
seed_nonce:Nonce.t ->
seed_nonce_hash:Nonce_hash.t ->
src_sk:secret_key ->
unit ->
Block_hash.t tzresult Lwt.t

3
src/client/embedded/alpha/baker/client_mining_main.ml
View File

@ -23,10 +23,11 @@ let mine_block cctxt block
Client_proto_rpcs.Context.level cctxt.rpc_config block >>=? fun level ->
let level = Raw_level.succ level.level in
let seed_nonce = Client_mining_forge.generate_seed_nonce () in
let seed_nonce_hash = Nonce.hash seed_nonce in
Client_mining_forge.forge_block cctxt.rpc_config
~timestamp:(Time.now ())
?force
~seed_nonce ~src_sk block
~seed_nonce_hash ~src_sk block
~priority:(`Auto (delegate, max_priority, free_mining)) () >>=? fun block_hash ->
Client_mining_forge.State.record_block cctxt level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () ->

9
src/client/embedded/alpha/baker/client_mining_operations.ml
View File

@ -44,6 +44,7 @@ type valid_endorsement = {
slots: int list ;
}
(*
let filter_valid_endorsement cctxt ({ hash ; content } : operation) =
let open Tezos_context in
match content with
@ -115,3 +116,11 @@ let monitor_endorsement cctxt =
ops_stream
end ;
return endorsement_stream
*)
(* Temporary desactivate the monitoring of endorsement:
too slow for now. *)
let monitor_endorsement _ =
let stream, _push = Lwt_stream.create () in
return stream

3
src/client/embedded/alpha/baker/client_mining_operations.mli
View File

@ -24,10 +24,13 @@ type valid_endorsement = {
slots: int list ;
}
(*
val filter_valid_endorsement:
Client_rpcs.config ->
operation -> valid_endorsement option Lwt.t
*)
val monitor_endorsement:
Client_rpcs.config ->
valid_endorsement tzresult Lwt_stream.t tzresult Lwt.t

15
src/client/embedded/alpha/client_proto_rpcs.ml
View File

@ -266,12 +266,15 @@ module Helpers = struct
let nonce = Sodium.Random.Bigbytes.generate 16 in
operations cctxt block ~net_id [Faucet { id ; counter ; nonce }]
end
let block cctxt
block ~net_id ~predecessor ~timestamp ~fitness ~operations_hash
~level ~priority ~proto_level ~seed_nonce_hash ~proof_of_work_nonce () =
call_error_service1 cctxt Services.Helpers.Forge.block block
((net_id, predecessor, timestamp, fitness, operations_hash),
(level, priority, proto_level, seed_nonce_hash, proof_of_work_nonce))
let empty_proof_of_work_nonce =
MBytes.of_string
(String.make Constants_repr.proof_of_work_nonce_size '\000')
let block_proto_header cctxt
block
~priority ~seed_nonce_hash
?(proof_of_work_nonce = empty_proof_of_work_nonce) () =
call_error_service1 cctxt Services.Helpers.Forge.block_proto_header
block (priority, seed_nonce_hash, proof_of_work_nonce)
end
module Parse = struct

15
src/client/embedded/alpha/client_proto_rpcs.mli
View File

@ -328,19 +328,12 @@ module Helpers : sig
id:public_key_hash ->
int32 -> MBytes.t tzresult Lwt.t
end
val block:
val block_proto_header:
Client_rpcs.config ->
block ->
net_id:Net_id.t ->
predecessor:Block_hash.t ->
timestamp:Time.t ->
fitness:Fitness.t ->
operations_hash:Operation_list_list_hash.t ->
level:Raw_level.t ->
priority:int ->
proto_level:int ->
seed_nonce_hash:Nonce_hash.t ->
proof_of_work_nonce:MBytes.t ->
priority: int ->
seed_nonce_hash: Nonce_hash.t ->
?proof_of_work_nonce: MBytes.t ->
unit -> MBytes.t tzresult Lwt.t
(** [block cctxt root ~net ~predecessor ~timestamp ~fitness
~operations ~level ~priority ~seed_nonce_hash

12
src/client/embedded/demo/client_proto_main.ml
View File

@ -46,9 +46,15 @@ let mine cctxt =
Lwt.ignore_result
(cctxt.message "Cannot parse fitness: %a" Fitness.pp bi.fitness);
exit 2 in
Client_node_rpcs.forge_block cctxt.rpc_config
~net_id:bi.net_id ~predecessor:bi.hash
fitness Operation_list_list_hash.empty (MBytes.create 0) >>=? fun bytes ->
Client_node_rpcs.forge_block_header cctxt.rpc_config
{ shell = { net_id = bi.net_id ;
predecessor = bi.hash ;
proto_level = bi.proto_level ;
level = Int32.succ bi.level ;
timestamp = Time.now () ;
fitness ;
operations_hash = Operation_list_list_hash.empty } ;
proto = MBytes.create 0 } >>=? fun bytes ->
Client_node_rpcs.inject_block cctxt.rpc_config bytes [] >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return ()

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

@ -451,7 +451,9 @@ module RPC = struct
let protocol_content node hash =
State.Protocol.read node.state hash
let preapply node block ~timestamp ~sort ops =
let preapply
node block
~timestamp ~proto_header ~sort_operations:sort ops =
begin
match block with
| `Genesis ->
@ -477,11 +479,32 @@ module RPC = struct
let net_db = Validator.net_db node.mainnet_validator in
map_p (Distributed_db.resolve_operation net_db) ops >>=? fun rops ->
Prevalidation.start_prevalidation
~predecessor ~timestamp >>=? fun validation_state ->
~proto_header ~predecessor ~timestamp () >>=? fun validation_state ->
Prevalidation.prevalidate
validation_state ~sort rops >>=? fun (validation_state, r) ->
Prevalidation.end_prevalidation validation_state >>=? fun { fitness } ->
return (fitness, { r with applied = List.rev r.applied })
validation_state ~sort rops >>= fun (validation_state, r) ->
let operations_hash =
Operation_list_list_hash.compute
[Operation_list_hash.compute r.applied] in
Prevalidation.end_prevalidation
validation_state >>=? fun { fitness ; context } ->
let pred_shell_header = State.Block.shell_header predecessor in
State.Block.protocol_hash predecessor >>= fun pred_protocol ->
Context.get_protocol context >>= fun protocol ->
let proto_level =
if Protocol_hash.equal protocol pred_protocol then
pred_shell_header.proto_level
else
((pred_shell_header.proto_level + 1) mod 256) in
let shell_header : Block_header.shell_header = {
net_id = pred_shell_header.net_id ;
level = Int32.succ pred_shell_header.level ;
proto_level ;
predecessor = State.Block.hash predecessor ;
timestamp ;
operations_hash ;
fitness ;
} in
return (shell_header, r)
let complete node ?block str =
match block with

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

@ -80,9 +80,9 @@ module RPC : sig
val preapply:
t -> block ->
timestamp:Time.t -> sort:bool ->
Distributed_db.operation list ->
(Fitness.t * error Prevalidation.preapply_result) tzresult Lwt.t
timestamp:Time.t -> proto_header:MBytes.t ->
sort_operations:bool -> Distributed_db.operation list ->
(Block_header.shell_header * error Prevalidation.preapply_result) tzresult Lwt.t
val validate: t -> Net_id.t -> Block_hash.t -> unit tzresult Lwt.t

33
src/node/shell/node_rpc.ml
View File

@ -128,16 +128,13 @@ let register_bi_dir node dir =
implementation in
let dir =
let implementation
b { Services.Blocks.operations ; sort ; timestamp } =
let timestamp =
match timestamp with
| None -> Time.now ()
| Some x -> x in
Node.RPC.preapply ~timestamp ~sort
node b operations >>= function
| Ok (fitness, operations) ->
b { Services.Blocks.operations ; sort_operations ;
timestamp ; proto_header} =
Node.RPC.preapply node b
~timestamp ~proto_header ~sort_operations operations >>= function
| Ok (shell_header, operations) ->
RPC.Answer.return
(Ok { Services.Blocks.fitness ; operations ; timestamp })
(Ok { Services.Blocks.shell_header ; operations })
| Error _ as err -> RPC.Answer.return err in
RPC.register1 dir
Services.Blocks.preapply implementation in
@ -389,23 +386,11 @@ let build_rpc_directory node =
let dir =
RPC.register1 dir Services.Protocols.contents (get_protocols node) in
let dir =
let implementation
(net_id, level, proto_level, pred, time,
fitness, operations_hash, header) =
Node.RPC.block_info node (`Head 0) >>= fun bi ->
let timestamp = Utils.unopt ~default:(Time.now ()) time in
let net_id = Utils.unopt ~default:bi.net_id net_id in
let predecessor = Utils.unopt ~default:bi.hash pred in
let level = Utils.unopt ~default:(Int32.succ bi.level) level in
let proto_level = Utils.unopt ~default:bi.proto_level proto_level in
let implementation header =
let res =
Data_encoding.Binary.to_bytes Block_header.encoding {
shell = { net_id ; predecessor ; level ; proto_level ;
timestamp ; fitness ; operations_hash } ;
proto = header ;
} in
Data_encoding.Binary.to_bytes Block_header.encoding header in
RPC.Answer.return res in
RPC.register0 dir Services.forge_block implementation in
RPC.register0 dir Services.forge_block_header implementation in
let dir =
let implementation (net_id, block_hash) =
Node.RPC.validate node net_id block_hash >>= fun res ->

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

@ -150,44 +150,6 @@ module Blocks = struct
let destruct = parse_block in
RPC.Arg.make ~name ~descr ~construct ~destruct ()
type preapply_param = {
operations: operation list ;
sort: bool ;
timestamp: Time.t option ;
}
let preapply_param_encoding =
(conv
(fun { operations ; sort ; timestamp } ->
(operations, Some sort, timestamp))
(fun (operations, sort, timestamp) ->
let sort =
match sort with
| None -> true
| Some x -> x in
{ operations ; sort ; timestamp })
(obj3
(req "operations" (list (dynamic_size operation_encoding)))
(opt "sort" bool)
(opt "timestamp" Time.encoding)))
type preapply_result = {
operations: error Prevalidation.preapply_result ;
fitness: MBytes.t list ;
timestamp: Time.t ;
}
let preapply_result_encoding =
(conv
(fun { operations ; timestamp ; fitness } ->
(timestamp, fitness, operations))
(fun (timestamp, fitness, operations) ->
{ operations ; timestamp ; fitness })
(obj3
(req "timestamp" Time.encoding)
(req "fitness" Fitness.encoding)
(req "operations" (Prevalidation.preapply_result_encoding Error.encoding))))
let block_path : (unit, unit * block) RPC.Path.path =
RPC.Path.(root / "blocks" /: blocks_arg )
@ -329,6 +291,41 @@ module Blocks = struct
let proto_path =
RPC.Path.(block_path / "proto")
type preapply_param = {
timestamp: Time.t ;
proto_header: MBytes.t ;
operations: operation list ;
sort_operations: bool ;
}
let preapply_param_encoding =
(conv
(fun { timestamp ; proto_header ; operations ; sort_operations } ->
(timestamp, proto_header, operations, sort_operations))
(fun (timestamp, proto_header, operations, sort_operations) ->
{ timestamp ; proto_header ; operations ; sort_operations })
(obj4
(req "timestamp" Time.encoding)
(req "proto_header" bytes)
(req "operations" (list (dynamic_size operation_encoding)))
(dft "sort_operations" bool false)))
type preapply_result = {
shell_header: Block_header.shell_header ;
operations: error Prevalidation.preapply_result ;
}
let preapply_result_encoding =
(conv
(fun { shell_header ; operations } ->
(shell_header, operations))
(fun (shell_header, operations) ->
{ shell_header ; operations })
(obj2
(req "shell_header" Block_header.shell_header_encoding)
(req "operations"
(Prevalidation.preapply_result_encoding Error.encoding))))
let preapply =
RPC.service
~description:
@ -612,21 +609,12 @@ module Network = struct
end
let forge_block =
let forge_block_header =
RPC.service
~description: "Forge a block header"
~input:
(obj8
(opt "net_id" Net_id.encoding)
(opt "level" int32)
(opt "proto_level" uint8)
(opt "predecessor" Block_hash.encoding)
(opt "timestamp" Time.encoding)
(req "fitness" Fitness.encoding)
(req "operations" Operation_list_list_hash.encoding)
(req "header" bytes))
~input: Block_header.encoding
~output: (obj1 (req "block" bytes))
RPC.Path.(root / "forge_block")
RPC.Path.(root / "forge_block_header")
let validate_block =
RPC.service

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

@ -93,14 +93,15 @@ module Blocks : sig
(unit, unit, list_param, block_info list list) RPC.service
type preapply_param = {
operations: operation list ;
sort: bool ;
timestamp: Time.t option ;
}
type preapply_result = {
operations: error Prevalidation.preapply_result ;
fitness: MBytes.t list ;
timestamp: Time.t ;
proto_header: MBytes.t ;
operations: operation list ;
sort_operations: bool ;
}
type preapply_result = {
shell_header: Block_header.shell_header ;
operations: error Prevalidation.preapply_result ;
}
val preapply:
(unit, unit * block, preapply_param, preapply_result tzresult) RPC.service
@ -109,6 +110,7 @@ module Blocks : sig
val proto_path: (unit, unit * block) RPC.Path.path
end
module Protocols : sig
@ -173,11 +175,8 @@ module Network : sig
end
val forge_block:
(unit, unit,
Net_id.t option * Int32.t option * int option * Block_hash.t option *
Time.t option * Fitness.t * Operation_list_list_hash.t * MBytes.t,
MBytes.t) RPC.service
val forge_block_header:
(unit, unit, Block_header.t, MBytes.t) RPC.service
val validate_block:
(unit, unit, Net_id.t * Block_hash.t, unit tzresult) RPC.service

80
src/node/shell/prevalidation.ml
View File

@ -73,21 +73,7 @@ let empty_result =
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 =
let rec apply_operations apply_operation state r ~sort ops =
Lwt_list.fold_left_s
(fun (state, r) (hash, op) ->
apply_operation state op >>= function
@ -108,7 +94,7 @@ let rec apply_operations apply_operation state ~sort ops =
let branch_delayed =
Operation_hash.Map.add hash errors r.branch_delayed in
Lwt.return (state, { r with branch_delayed }))
(state, empty_result)
(state, r)
ops >>= fun (state, r) ->
match r.applied with
| _ :: _ when sort ->
@ -116,11 +102,13 @@ let rec apply_operations apply_operation state ~sort ops =
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')
let remaining = List.length rechecked_operations in
if remaining = 0 || remaining = List.length ops then
Lwt.return (state, r)
else
apply_operations apply_operation state r ~sort rechecked_operations
| _ ->
return (state, r)
Lwt.return (state, r)
type prevalidation_state =
State : { proto : 'a proto ; state : 'a }
@ -130,9 +118,7 @@ and 'a proto =
(module Updater.REGISTRED_PROTOCOL
with type validation_state = 'a)
let start_prevalidation
~predecessor
~timestamp =
let start_prevalidation ?proto_header ~predecessor ~timestamp () =
let { Block_header.shell =
{ fitness = predecessor_fitness ;
timestamp = predecessor_timestamp ;
@ -155,33 +141,47 @@ let start_prevalidation
~predecessor_level
~predecessor
~timestamp
?proto_header
()
>>=? fun state ->
return (State { proto = (module Proto) ; state })
type error += Parse_error
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 =
List.map
(fun (h, op) ->
(h, Proto.parse_operation h op |> record_trace Parse_error))
ops in
let invalid_ops =
Utils.filter_map
(fun (h, op) -> match op with
| Ok _ -> None
| Error err -> Some (h, err)) ops
and parsed_ops =
Utils.filter_map
(fun (h, op) -> match op with
| Ok op -> Some (h, op)
| Error _ -> None) ops in
let sorted_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)
List.sort compare parsed_ops
else parsed_ops in
apply_operations
Proto.apply_operation
state empty_result ~sort sorted_ops >>= fun (state, r) ->
let r =
{ r with
applied = List.rev r.applied ;
branch_refused =
List.fold_left
(fun map (h, err) -> Operation_hash.Map.add h err map)
r.branch_refused invalid_ops } in
Lwt.return (State { proto = (module Proto) ; state }, r)
let end_prevalidation (State { proto = (module Proto) ; state }) =
Proto.finalize_block state

5
src/node/shell/prevalidation.mli
View File

@ -29,14 +29,15 @@ val preapply_result_encoding :
type prevalidation_state
val start_prevalidation :
?proto_header: MBytes.t ->
predecessor: State.Block.t ->
timestamp: Time.t ->
prevalidation_state tzresult Lwt.t
unit -> prevalidation_state tzresult Lwt.t
val prevalidate :
prevalidation_state -> sort:bool ->
(Operation_hash.t * Operation.t) list ->
(prevalidation_state * error preapply_result) tzresult Lwt.t
(prevalidation_state * error preapply_result) Lwt.t
val end_prevalidation :
prevalidation_state -> Updater.validation_result tzresult Lwt.t

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

@ -73,7 +73,7 @@ let create net_db =
Chain.head net_state >>= fun head ->
let timestamp = ref (Time.now ()) in
(start_prevalidation head !timestamp >|= ref) >>= fun validation_state ->
(start_prevalidation head !timestamp () >|= ref) >>= fun validation_state ->
let pending = Operation_hash.Table.create 53 in
let head = ref head in
let operations = ref empty_result in
@ -86,7 +86,7 @@ let create net_db =
Lwt.return_unit in
let reset_validation_state head timestamp =
start_prevalidation head timestamp >>= fun state ->
start_prevalidation head timestamp () >>= fun state ->
validation_state := state;
Lwt.return_unit in
@ -109,12 +109,13 @@ let create net_db =
Lwt_list.map_p
(fun h ->
Distributed_db.Operation.read_opt net_db h >>= function
| None -> Lwt.return_none
| Some po -> Lwt.return_some (h, po))
| Some po ->
Lwt.return_some (h, po)
| None -> Lwt.return_none)
(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
(prevalidate validation_state ~sort:true rops >>= return)) >>= function
| Ok (state, r) -> Lwt.return (Ok state, r)
| Error err ->
let r =
@ -129,16 +130,16 @@ let create net_db =
List.fold_right Operation_hash.Map.remove s m in
operations := {
applied = List.rev_append r.applied !operations.applied ;
refused = Operation_hash.Map.empty ;
branch_refused =
Operation_hash.Map.merge merge
(* filter_out should not be required here, TODO warn ? *)
(filter_out r.applied !operations.branch_refused)
r.branch_refused ;
branch_delayed =
Operation_hash.Map.merge merge
(filter_out r.applied !operations.branch_delayed)
r.branch_delayed ;
refused = Operation_hash.Map.empty ;
branch_refused =
Operation_hash.Map.merge merge
(* filter_out should not be required here, TODO warn ? *)
(filter_out r.applied !operations.branch_refused)
r.branch_refused ;
branch_delayed =
Operation_hash.Map.merge merge
(filter_out r.applied !operations.branch_delayed)
r.branch_delayed ;
} ;
if broadcast then broadcast_operation r.applied ;
Lwt_list.iter_s
@ -181,7 +182,8 @@ let create net_db =
let result =
let rops = Operation_hash.Map.bindings ops in
Lwt.return !validation_state >>=? fun validation_state ->
prevalidate validation_state ~sort:true rops >>=? fun (state, res) ->
prevalidate validation_state
~sort:true rops >>= fun (state, res) ->
let register h =
let op = Operation_hash.Map.find h ops in
Distributed_db.inject_operation

22
src/proto/alpha/services.ml
View File

@ -622,28 +622,6 @@ module Helpers = struct
~output: (wrap_tzerror bytes)
RPC.Path.(custom_root / "helpers" / "forge" / "block_proto_header")
let block custom_root =
RPC.service
~description: "Forge a block header"
~input:
(merge_objs
(obj5
(req "net_id" Net_id.encoding)
(req "predecessor" Block_hash.encoding)
(req "timestamp" Timestamp.encoding)
(req "fitness" Fitness.encoding)
(req "operations" Operation_list_list_hash.encoding))
(obj5
(req "level" Raw_level.encoding)
(req "priority" uint16)
(req "proto_level" uint8)
(req "nonce_hash" Nonce_hash.encoding)
(req "proof_of_work_nonce"
(Fixed.bytes
Tezos_context.Constants.proof_of_work_nonce_size))))
~output: (wrap_tzerror bytes)
RPC.Path.(custom_root / "helpers" / "forge" / "block")
end
module Parse = struct

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

@ -496,17 +496,6 @@ let forge_block_proto_header _ctxt
let () =
register1 Services.Helpers.Forge.block_proto_header forge_block_proto_header
let forge_block _ctxt
((net_id, predecessor, timestamp, fitness, operations_hash),
(level, priority, proto_level, seed_nonce_hash, proof_of_work_nonce)) : MBytes.t tzresult Lwt.t =
let level = Raw_level.to_int32 level in
return (Block_header.forge_unsigned
{ net_id ; level ; proto_level ; predecessor ;
timestamp ; fitness ; operations_hash }
{ priority ; seed_nonce_hash ; proof_of_work_nonce })
let () = register1 Services.Helpers.Forge.block forge_block
(*-- Helpers.Parse -----------------------------------------------------------*)
let dummy_hash = Operation_hash.hash_bytes []

12
src/utils/error_monad.ml
View File

@ -279,6 +279,18 @@ module Make() = struct
map_filter_s f t >>=? fun rt ->
return (rh :: rt)
let rec map_filter_p f l =
match l with
| [] -> return []
| h :: t ->
let th = f h
and tt = map_filter_s f t in
th >>=? function
| None -> tt
| Some rh ->
tt >>=? fun rt ->
return (rh :: rt)
let rec iter_s f l =
match l with
| [] -> return ()

2
src/utils/error_monad_sig.ml
View File

@ -137,6 +137,8 @@ module type S = sig
(** A {!List.map_filter} in the monad *)
val map_filter_s :
('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
val map_filter_p :
('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
(** A {!List.fold_left} in the monad *)
val fold_left_s :

3
test/proto_alpha/.merlin
View File

@ -18,8 +18,9 @@ B ../../src/proto
S ../../src/client
B ../../src/client
S ../../src/client/embedded/alpha
B ../../src/client/embedded/alpha
S ../../src/client/embedded/alpha/baker
B ../../src/client/embedded
B ../../src/client/embedded/alpha/baker
S ../lib
B ../lib
FLG -open Error_monad -open Hash -open Utils -open Environment -open Tezos_data

162
test/proto_alpha/proto_alpha_helpers.ml
View File

@ -13,6 +13,8 @@ open Client_alpha
let (//) = Filename.concat
let () = Random.self_init ()
let rpc_config : Client_rpcs.config = {
host = "localhost" ;
port = 8192 + Random.int 8192 ;
@ -33,7 +35,6 @@ let activate_alpha () =
fitness dictator_sk
let init ?(sandbox = "sandbox.json") () =
Random.self_init () ;
Unix.chdir (Filename.dirname (Filename.dirname Sys.executable_name)) ;
let pid =
Node_helpers.fork_node
@ -311,6 +312,23 @@ module Assert = struct
List.exists f errors
| _ -> false
let hash = function
| Client_node_rpcs.Hash h -> h
| Blob op -> Tezos_data.Operation.hash op
let failed_to_preapply ~msg ?op f =
Assert.contain_error ~msg ~f:begin function
| Client_mining_forge.Failed_to_preapply (op', err) ->
begin
match op with
| None -> true
| Some op ->
let h = hash op and h' = hash op' in
Operation_hash.equal h h'
end && List.exists (ecoproto_error f) err
| _ -> false
end
let generic_economic_error ~msg =
Assert.contain_error ~msg ~f:(ecoproto_error (fun _ -> true))
@ -363,12 +381,6 @@ module Assert = struct
| _ -> false)
end
let invalid_endorsement_slot ~msg =
Assert.contain_error ~msg ~f:begin ecoproto_error (function
| Mining.Invalid_endorsement_slot _ -> true
| _ -> false)
end
let check_protocol ?msg ~block h =
Client_node_rpcs.Blocks.protocol rpc_config block >>=? fun block_proto ->
return @@ Assert.equal
@ -388,128 +400,28 @@ end
module Mining = struct
let get_first_priority
?(max_priority=1024)
level
(contract : Account.t)
block =
Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate
rpc_config
~max_priority
~first_level:level
~last_level:level
block contract.Account.pkh () >>=? fun possibilities ->
try
let _, prio, _ =
List.find (fun (l,_,_) -> l = level) possibilities in
return prio
with Not_found ->
failwith "No slot found at level %a" Raw_level.pp level
let rec mine_stamp
block
delegate_sk
shell
priority
seed_nonce_hash =
Client_proto_rpcs.Constants.stamp_threshold
rpc_config block >>=? fun stamp_threshold ->
let rec loop () =
let proof_of_work_nonce =
Sodium.Random.Bigbytes.generate Constants.proof_of_work_nonce_size in
let unsigned_header =
Block_header.forge_unsigned
shell { priority ; seed_nonce_hash ; proof_of_work_nonce } in
let signed_header =
Ed25519.Signature.append delegate_sk unsigned_header in
let block_hash = Block_hash.hash_bytes [signed_header] in
if Mining.check_hash block_hash stamp_threshold then
proof_of_work_nonce
else
loop () in
return (loop ())
let inject_block
block
?force
?proto_level
~priority
~timestamp
~fitness
~seed_nonce
~src_sk
operations =
let block = match block with `Prevalidation -> `Head 0 | block -> block in
Client_node_rpcs.Blocks.info rpc_config block >>=? fun bi ->
let proto_level = Utils.unopt ~default:bi.proto_level proto_level in
let mine block (contract: Account.t) operations =
let operations = List.map (fun op -> Client_node_rpcs.Blob op) operations in
let seed_nonce =
match Nonce.of_bytes @@
Sodium.Random.Bigbytes.generate Constants.nonce_length with
| Error _ -> assert false
| Ok nonce -> nonce in
let seed_nonce_hash = Nonce.hash seed_nonce in
Client_proto_rpcs.Context.next_level rpc_config block >>=? fun level ->
let operation_hashes = List.map Tezos_data.Operation.hash operations in
let operations_hash =
Operation_list_list_hash.compute
[Operation_list_hash.compute operation_hashes] in
let shell =
{ Tezos_data.Block_header.net_id = bi.net_id ; predecessor = bi.hash ;
timestamp ; fitness ; operations_hash ;
level = Raw_level.to_int32 level.level ;
proto_level } in
mine_stamp
block src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce ->
Client_proto_rpcs.Helpers.Forge.block rpc_config
Client_mining_forge.forge_block
rpc_config
block
~net_id:bi.net_id
~predecessor:bi.hash
~timestamp
~fitness
~operations_hash
~level:level.level
~proto_level
~priority
~operations
~force:true
~best_effort:false
~sort:false
~priority:(`Auto (contract.pkh, Some 1024, false))
~seed_nonce_hash
~proof_of_work_nonce
() >>=? fun unsigned_header ->
let signed_header = Ed25519.Signature.append src_sk unsigned_header in
Client_node_rpcs.inject_block rpc_config
?force signed_header
[List.map (fun h -> Client_node_rpcs.Blob h) operations] >>=? fun block_hash ->
return block_hash
~src_sk:contract.sk
()
let mine
?(force = true)
?(operations = [])
?(fitness_gap = 1)
?proto_level
contract
block =
Client_mining_blocks.info rpc_config block >>=? fun bi ->
let seed_nonce =
match Nonce.of_bytes @@
Sodium.Random.Bigbytes.generate Constants.nonce_length with
| Error _ -> assert false
| Ok nonce -> nonce in
let timestamp = Time.add (Time.now ()) 1L in
Client_proto_rpcs.Context.level rpc_config block >>=? fun level ->
let level = Raw_level.succ level.level in
get_first_priority level contract block >>=? fun priority ->
(Lwt.return (Fitness_repr.to_int64 bi.fitness) >|=
Register_client_embedded_proto_alpha.wrap_error) >>=? fun fitness ->
let fitness =
Fitness_repr.from_int64 @@
Int64.add fitness (Int64.of_int fitness_gap) in
inject_block
~force
?proto_level
~priority
~timestamp
~fitness
~seed_nonce
~src_sk:contract.sk
block
operations
let endorsement_reward contract block =
Client_mining_blocks.info rpc_config block >>=? fun bi ->
get_first_priority bi.level.level contract block >>=? fun prio ->
let endorsement_reward block =
Client_proto_rpcs.Header.priority rpc_config block >>=? fun prio ->
Mining.endorsement_reward ~block_priority:prio >|=
Register_client_embedded_proto_alpha.wrap_error >>|?
Tez.to_cents

52
test/proto_alpha/proto_alpha_helpers.mli
View File

@ -93,48 +93,15 @@ end
module Mining : sig
val get_first_priority :
?max_priority:int ->
Raw_level.t ->
Account.t ->
Client_proto_rpcs.block ->
int tzresult Lwt.t
(** [get_first_priority ?max_prio level account block] is the
best (first) mining priority on [block] for [account] at
[level]. *)
val mine_stamp :
Client_proto_rpcs.block ->
secret_key ->
Block_header.shell_header ->
int ->
Nonce_hash.t ->
MBytes.t tzresult Lwt.t
val inject_block :
val mine:
Client_node_rpcs.Blocks.block ->
?force:bool ->
?proto_level:int ->
priority:int ->
timestamp:Time.t ->
fitness:Fitness.t ->
seed_nonce:Nonce.nonce ->
src_sk:secret_key ->
Operation.raw list -> Block_hash.t tzresult Lwt.t
val mine :
?force:bool ->
?operations:Operation.raw list ->
?fitness_gap:int ->
?proto_level:int ->
Account.t ->
Client_node_rpcs.Blocks.block ->
Operation.raw list ->
Block_hash.t tzresult Lwt.t
val endorsement_reward :
Account.t ->
Client_node_rpcs.Blocks.block ->
int64 tzresult Lwt.t
val endorsement_reward:
Client_node_rpcs.Blocks.block -> int64 tzresult Lwt.t
end
module Endorse : sig
@ -186,6 +153,13 @@ module Assert : sig
?block:Client_node_rpcs.Blocks.block ->
msg:string -> Contract.t -> public_key_hash option -> unit tzresult Lwt.t
val failed_to_preapply:
msg:string ->
?op:Client_node_rpcs.operation ->
(Register_client_embedded_proto_alpha.Packed_protocol.error ->
bool) ->
'a tzresult -> unit
val ecoproto_error:
(Register_client_embedded_proto_alpha.Packed_protocol.error -> bool) ->
error -> bool
@ -211,8 +185,6 @@ module Assert : sig
val wrong_delegate : msg:string -> 'a tzresult -> unit
val invalid_endorsement_slot : msg:string -> 'a tzresult -> unit
val check_protocol :
?msg:string -> block:Client_node_rpcs.Blocks.block ->
Protocol_hash.t -> unit tzresult Lwt.t

93
test/proto_alpha/test_endorsement.ml
View File

@ -17,25 +17,25 @@ module Assert = Helpers.Assert
let test_double_endorsement contract block =
(* Double endorsement for the same level *)
Helpers.Mining.mine ~fitness_gap:1 contract block >>=? fun b1 ->
Helpers.Mining.mine block contract [] >>=? fun b1 ->
(* branch root *)
Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b1) >>=? fun b2 ->
Helpers.Mining.mine (`Hash b1) contract [] >>=? fun b2 ->
(* changing branch *)
Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b1) >>=? fun b2' ->
Helpers.Mining.mine (`Hash b1) contract [] >>=? fun b2' ->
(* branch root *)
Helpers.Endorse.endorse contract (`Hash b2) >>=? fun op ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ op ] contract (`Hash b2) >>=? fun _b3 ->
Helpers.Mining.mine (`Hash b2) contract [ op ] >>=? fun _b3 ->
Helpers.Endorse.endorse contract (`Hash b2') >>=? fun op ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ op ] contract (`Hash b2') >>=? fun b3' ->
Helpers.Mining.mine (`Hash b2') contract [ op ] >>=? fun b3' ->
Helpers.Endorse.endorse contract (`Hash b3') >>=? fun op ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ op ] contract (`Hash b3') >>=? fun b4' ->
Helpers.Mining.mine (`Hash b3') contract [ op ] >>=? fun b4' ->
(* TODO: Inject double endorsement op ! *)
Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b4')
Helpers.Mining.mine (`Hash b4') contract []
(* FIXME: Mining.Invalid_signature is unclassified *)
let test_invalid_signature block =
@ -48,7 +48,7 @@ let test_invalid_signature block =
DYfTKhq7rDQujdn5WWzwUMeV3agaZ6J2vPQT58jJAJPi" in
let account =
Helpers.Account.create ~keys:(secret_key, public_key) "WRONG SIGNATURE" in
Helpers.Mining.mine ~fitness_gap:1 account block >>= fun res ->
Helpers.Mining.mine block account [] >>= fun res ->
Assert.generic_economic_error ~msg:__LOC__ res ;
return ()
@ -61,37 +61,38 @@ let contain_tzerror ?(msg="") ~f t =
let test_wrong_delegate ~miner contract head =
let block = `Hash head in
contain_tzerror ~msg:__LOC__ ~f:begin Assert.ecoproto_error (function
| Mining.Wrong_delegate _ -> true
| _ -> false)
end begin
begin
Helpers.Endorse.endorse ~slot:1 contract block >>=? fun op ->
Helpers.Mining.mine
~fitness_gap:2 ~operations:[ op ] miner block >>=? fun _ ->
Helpers.Mining.mine block miner [ op ] >>=? fun _ ->
Helpers.Endorse.endorse ~slot:2 contract block >>=? fun op ->
Helpers.Mining.mine
~fitness_gap:2 ~operations:[ op ] miner block >>=? fun _ ->
Helpers.Mining.mine block miner [ op ] >>=? fun _ ->
Helpers.Endorse.endorse ~slot:3 contract block >>=? fun op ->
Helpers.Mining.mine
~fitness_gap:2 ~operations:[ op ] miner block >>=? fun _ ->
Helpers.Mining.mine block miner [ op ] >>=? fun _ ->
Helpers.Endorse.endorse ~slot:4 contract block >>=? fun op ->
Helpers.Mining.mine
~fitness_gap:2 ~operations:[ op ] miner block >>=? fun _ ->
Helpers.Mining.mine block miner [ op ] >>=? fun _ ->
Helpers.Endorse.endorse ~slot:5 contract block >>=? fun op ->
Helpers.Mining.mine
~fitness_gap:2 ~operations:[ op ] miner block >>=? fun _ ->
Helpers.Mining.mine block miner [ op ] >>=? fun _ ->
return ()
end
end >>= fun res ->
Assert.failed_to_preapply ~msg:__LOC__ begin function
| Mining.Wrong_delegate _ -> true
| _ -> false
end res ;
Lwt.return_unit
let test_invalid_endorsement_slot contract block =
Helpers.Endorse.endorse ~slot:~-1 contract block >>=? fun op ->
Helpers.Mining.mine
~fitness_gap:2 ~operations:[ op ] contract block >>= fun res ->
Assert.invalid_endorsement_slot ~msg:__LOC__ res ;
Helpers.Mining.mine block contract [ op ] >>= fun res ->
Assert.failed_to_preapply ~msg:__LOC__ ~op:(Blob op) begin function
| Mining.Invalid_endorsement_slot _ -> true
| _ -> false
end res ;
Helpers.Endorse.endorse ~slot:16 contract block >>=? fun op ->
Helpers.Mining.mine
~fitness_gap:2 ~operations:[ op ] contract block >>= fun res ->
Assert.invalid_endorsement_slot ~msg:__LOC__ res ;
Helpers.Mining.mine block contract [ op ] >>= fun res ->
Assert.failed_to_preapply ~msg:__LOC__ ~op:(Blob op) begin function
| Mining.Invalid_endorsement_slot _ -> true
| _ -> false
end res ;
return ()
let test_endorsement_rewards
@ -112,8 +113,7 @@ let test_endorsement_rewards
get_endorser_except [ b1 ] accounts >>=? fun (account0, slot0) ->
Helpers.Account.balance ~block account0 >>=? fun balance0 ->
Helpers.Endorse.endorse ~slot:slot0 account0 block >>=? fun ops ->
Helpers.Mining.mine
~fitness_gap:2 ~operations:[ ops ] b1 block >>=? fun head0 ->
Helpers.Mining.mine block b1 [ ops ] >>=? fun head0 ->
Helpers.display_level (`Hash head0) >>=? fun () ->
Assert.balance_equal ~block:(`Hash head0) ~msg:__LOC__ account0
(Int64.sub (Tez.to_cents balance0) bond) >>=? fun () ->
@ -125,32 +125,31 @@ let test_endorsement_rewards
get_endorser_except [ b1 ; account0 ] accounts >>=? fun (account1, slot1) ->
Helpers.Account.balance ~block:block0 account1 >>=? fun balance1 ->
Helpers.Endorse.endorse ~slot:slot1 account1 block0 >>=? fun ops ->
Helpers.Mining.mine
~fitness_gap:2 ~operations:[ ops ] b1 block0 >>=? fun head1 ->
Helpers.Mining.mine block0 b1 [ ops ] >>=? fun head1 ->
Helpers.display_level (`Hash head1) >>=? fun () ->
Assert.balance_equal ~block:(`Hash head1) ~msg:__LOC__ account1
(Int64.sub (Tez.to_cents balance1) bond) >>=? fun () ->
(* Check rewards after one cycle for account0 *)
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head1) >>=? fun head2 ->
Helpers.Mining.mine (`Hash head1) b1 [] >>=? fun head2 ->
Helpers.display_level (`Hash head2) >>=? fun () ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head2) >>=? fun head3 ->
Helpers.Mining.mine (`Hash head2) b1 [] >>=? fun head3 ->
Helpers.display_level (`Hash head3) >>=? fun () ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun head4 ->
Helpers.Mining.mine (`Hash head3) b1 [] >>=? fun head4 ->
Helpers.display_level (`Hash head4) >>=? fun () ->
Helpers.Mining.endorsement_reward b1 block0 >>=? fun rw0 ->
Helpers.Mining.endorsement_reward block0 >>=? fun rw0 ->
Assert.balance_equal ~block:(`Hash head4) ~msg:__LOC__ account0
(Int64.add (Tez.to_cents balance0) rw0) >>=? fun () ->
(* Check rewards after one cycle for account1 *)
Helpers.Mining.endorsement_reward b1 (`Hash head1) >>=? fun rw1 ->
Helpers.Mining.endorsement_reward (`Hash head1) >>=? fun rw1 ->
Assert.balance_equal ~block:(`Hash head4) ~msg:__LOC__ account1
(Int64.add (Tez.to_cents balance1) rw1) >>=? fun () ->
(* #2 endorse and check reward only on the good chain *)
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head4) >>=? fun head ->
Helpers.Mining.mine (`Hash head4) b1 []>>=? fun head ->
Helpers.display_level (`Hash head) >>=? fun () ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head4) >>=? fun fork ->
Helpers.Mining.mine (`Hash head4) b1 [] >>=? fun fork ->
Helpers.display_level (`Hash fork) >>=? fun () ->
(* working on head *)
@ -159,7 +158,7 @@ let test_endorsement_rewards
Helpers.Account.balance ~block:(`Hash head) account3 >>=? fun balance3 ->
Helpers.Endorse.endorse
~slot:slot3 account3 (`Hash head) >>=? fun ops ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash head) >>=? fun new_head ->
Helpers.Mining.mine (`Hash head) b1 [ ops ] >>=? fun new_head ->
Helpers.display_level (`Hash new_head) >>=? fun () ->
(* working on fork *)
@ -167,17 +166,17 @@ let test_endorsement_rewards
get_endorser_except [ b1 ] accounts >>=? fun (account4, slot4) ->
Helpers.Account.balance ~block:(`Hash new_head) account4 >>=? fun _balance4 ->
Helpers.Endorse.endorse ~slot:slot4 account4 (`Hash fork) >>=? fun ops ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash fork) >>=? fun _new_fork ->
Helpers.Mining.mine (`Hash fork) b1 [ ops ] >>=? fun _new_fork ->
Helpers.display_level (`Hash _new_fork) >>=? fun () ->
Helpers.Account.balance ~block:(`Hash new_head) account4 >>=? fun balance4 ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash new_head) >>=? fun head ->
Helpers.Mining.mine (`Hash new_head) b1 [] >>=? fun head ->
Helpers.display_level (`Hash head) >>=? fun () ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head) >>=? fun head ->
Helpers.Mining.mine (`Hash head) b1 [] >>=? fun head ->
Helpers.display_level (`Hash head) >>=? fun () ->
(* Check rewards after one cycle *)
Helpers.Mining.endorsement_reward b1 (`Hash new_head) >>=? fun reward ->
Helpers.Mining.endorsement_reward (`Hash new_head) >>=? fun reward ->
Assert.balance_equal ~block:(`Hash head) ~msg:__LOC__ account3
(Int64.add (Tez.to_cents balance3) reward) >>=? fun () ->
@ -217,8 +216,8 @@ let run head (({ b1 ; b2 ; b3 ; b4 ; b5 } : Helpers.Account.bootstrap_accounts)
(* Endorse with a contract with wrong delegate:
- contract with no endorsement rights
- contract which signs at every available slots *)
test_wrong_delegate ~miner:b1 default_account head >>=? fun () ->
test_wrong_delegate ~miner:b1 b5 head >>=? fun () ->
test_wrong_delegate ~miner:b1 default_account head >>= fun () ->
test_wrong_delegate ~miner:b1 b5 head >>= fun () ->
(* Endorse with a wrong slot : -1 and max (16) *)
test_invalid_endorsement_slot b3 (`Hash head) >>=? fun () ->

2
test/proto_alpha/test_origination.ml
View File

@ -15,7 +15,7 @@ module Assert = Helpers.Assert
let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Mining.mine ~fitness_gap:1 b1 blkid >>=? fun blkh ->
Helpers.Mining.mine blkid b1 [] >>=? fun blkh ->
let foo = Helpers.Account.create "foo" in
(* Origination with amount = 0 tez *)

2
test/proto_alpha/test_transaction.ml
View File

@ -15,7 +15,7 @@ module Assert = Helpers.Assert
let run blkid ({ b1 ; b2 ; b3 ; _ } : Helpers.Account.bootstrap_accounts) =
Helpers.Mining.mine ~fitness_gap:1 b1 blkid >>=? fun blkh ->
Helpers.Mining.mine blkid b1 [] >>=? fun blkh ->
let foo = Helpers.Account.create "foo" in
let bar = Helpers.Account.create "bar" in

30
test/proto_alpha/test_vote.ml
View File

@ -20,12 +20,13 @@ let print_level head =
return @@ Format.eprintf "voting_period = %a.%ld@."
Voting_period.pp lvl.voting_period lvl.voting_period_position
let run_change_to_demo_proto block ({ b1 ; b2 ; b3 ; b4 ; b5 } : Account.bootstrap_accounts) =
Mining.mine b1 block >>=? fun head ->
let run_change_to_demo_proto block
({ b1 ; b2 ; b3 ; b4 ; b5 } : Account.bootstrap_accounts) =
Mining.mine block b1 [] >>=? fun head ->
Format.eprintf "Entering `Proposal` voting period@.";
Assert.check_voting_period_kind ~msg:__LOC__ ~block:(`Hash head)
Voting_period.Proposal >>=? fun () ->
Mining.mine b2 (`Hash head) >>=? fun head ->
Mining.mine (`Hash head) b2 [] >>=? fun head ->
(* 1. Propose the 'demo' protocol as b1 (during the Proposal period) *)
Protocol.proposals
@ -34,9 +35,9 @@ let run_change_to_demo_proto block ({ b1 ; b2 ; b3 ; b4 ; b5 } : Account.bootstr
[demo_protocol] >>=? fun op ->
(* Mine blocks to switch to next vote period (Testing_vote) *)
Mining.mine ~operations:[op] b3 (`Hash head) >>=? fun head ->
Mining.mine (`Hash head) b3 [op] >>=? fun head ->
Format.eprintf "Entering `Testing_vote` voting period@.";
Mining.mine b4 (`Hash head) >>=? fun head ->
Mining.mine (`Hash head) b4 [] >>=? fun head ->
Assert.check_voting_period_kind ~msg:__LOC__ ~block:(`Hash head)
Voting_period.Testing_vote >>=? fun () ->
@ -55,18 +56,18 @@ let run_change_to_demo_proto block ({ b1 ; b2 ; b3 ; b4 ; b5 } : Account.bootstr
all_accounts >>=? fun operations ->
(* Mine blocks to switch to next vote period (Testing) *)
Mining.mine ~operations b5 (`Hash head) >>=? fun head ->
Mining.mine (`Hash head) b5 operations >>=? fun head ->
Format.eprintf "Entering `Testing` voting period@.";
Mining.mine b1 (`Hash head) >>=? fun head ->
Mining.mine (`Hash head) b1 [] >>=? fun head ->
Assert.check_voting_period_kind ~msg:__LOC__ ~block:(`Hash head)
Voting_period.Testing >>=? fun () ->
(* 3. Test the proposed protocol *)
(* Mine blocks to switch to next vote period (Promotion_vote) *)
Mining.mine b2 (`Hash head) >>=? fun head ->
Format.eprintf "Entering `Promotion_vote` voting period@.";
Mining.mine b3 (`Hash head) >>=? fun head ->
(* Mine blocks to switch to next vote period (Promote_vote) *)
Mining.mine (`Hash head) b2 [] >>=? fun head ->
Format.eprintf "Entering `Promote_vote` voting period@.";
Mining.mine (`Hash head) b3 [] >>=? fun head ->
Assert.check_voting_period_kind ~msg:__LOC__ ~block:(`Hash head)
Voting_period.Promotion_vote >>=? fun () ->
@ -76,10 +77,11 @@ let run_change_to_demo_proto block ({ b1 ; b2 ; b3 ; b4 ; b5 } : Account.bootstr
(* Mine blocks to switch to end the vote cycle (back to Proposal) *)
Format.eprintf "Switching to `demo` protocol@.";
Mining.mine ~operations b4 (`Hash head) >>=? fun head ->
Mining.mine ~proto_level:2 b5 (`Hash head) >>=? fun head ->
Mining.mine (`Hash head) b4 operations >>=? fun head ->
Mining.mine (`Hash head) b5 [] >>=? fun head ->
Assert.check_protocol ~msg:__LOC__ ~block:(`Hash head) demo_protocol >>=? fun () ->
Assert.check_protocol
~msg:__LOC__ ~block:(`Hash head) demo_protocol >>=? fun () ->
return (`Hash head)