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

Shell: move level in th shell part of block.

Browse Source
This commit is contained in:
Grégoire Henry 2017-04-10 13:01:22 +02:00
parent 2480bfd216
commit f805507702
52 changed files with 400 additions and 281 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Makefile
View File

@ -247,7 +247,7 @@ ${TZCLIENT}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa \
${EMBEDDED_CLIENT_VERSIONS} \
${CLIENT_IMPLS:.ml=.cmx}
@echo LINK $(notdir $@)
@${OCAMLOPT} -linkpkg ${OCAMLFLAGS} -o $@ $^
@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
clean::
-rm -f ${TZCLIENT}
@ -413,7 +413,6 @@ client/embedded/client_%.cmx: \
$(patsubst %.ml, %.cmx, $(NODE_LIB_IMPLS) $(CLIENT_LIB_IMPLS)) \
proto/client_embedded_proto_%.cmxa \
$$(shell find client/embedded/% \( -name webclient -or -name _tzbuild \) -prune -or \( -name \*.ml -print -or -name \*.mli -print \))
@echo $^
@$(MAKE) -C client/embedded/$* ../client_$*.cmx
client/embedded/webclient_%.cmx: \

8
src/client/client_node_rpcs.ml
View File

@ -15,9 +15,9 @@ module Services = Node_rpc_services
let errors cctxt =
call_service0 cctxt Services.Error.service ()
let forge_block cctxt ?net ?predecessor ?timestamp fitness ops header =
let forge_block cctxt ?net ?level ?predecessor ?timestamp fitness ops header =
call_service0 cctxt Services.forge_block
(net, predecessor, timestamp, fitness, ops, header)
(net, level, predecessor, timestamp, fitness, ops, header)
let validate_block cctxt net block =
call_err_service0 cctxt Services.validate_block (net, block)
@ -53,6 +53,7 @@ module Blocks = struct
type block_info = Services.Blocks.block_info = {
hash: Block_hash.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
@ -76,6 +77,8 @@ module Blocks = struct
}
let net cctxt h =
call_service1 cctxt Services.Blocks.net h ()
let level cctxt h =
call_service1 cctxt Services.Blocks.level h ()
let predecessor cctxt h =
call_service1 cctxt Services.Blocks.predecessor h ()
let predecessors cctxt h l =
@ -94,6 +97,7 @@ module Blocks = struct
call_service1 cctxt Services.Blocks.test_protocol h ()
let test_network cctxt h =
call_service1 cctxt Services.Blocks.test_network h ()
let preapply cctxt h ?timestamp ?(sort = false) operations =
call_err_service1
cctxt Services.Blocks.preapply h

5
src/client/client_node_rpcs.mli
View File

@ -15,6 +15,7 @@ val errors:
val forge_block:
config ->
?net:Net_id.t ->
?level:Int32.t ->
?predecessor:Block_hash.t ->
?timestamp:Time.t ->
Fitness.fitness ->
@ -67,6 +68,9 @@ module Blocks : sig
val net:
config ->
block -> Net_id.t tzresult Lwt.t
val level:
config ->
block -> Int32.t tzresult Lwt.t
val predecessor:
config ->
block -> Block_hash.t tzresult Lwt.t
@ -102,6 +106,7 @@ module Blocks : sig
type block_info = {
hash: Block_hash.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;

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

@ -22,14 +22,14 @@ let generate_seed_nonce () =
| Ok nonce -> nonce
let rec compute_stamp
cctxt block delegate_sk shell mining_slot seed_nonce_hash =
cctxt block delegate_sk shell priority seed_nonce_hash =
Client_proto_rpcs.Constants.stamp_threshold
cctxt block >>=? fun stamp_threshold ->
let rec loop () =
let proof_of_work_nonce = generate_proof_of_work_nonce () in
let unsigned_header =
Tezos_context.Block.forge_header
shell { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } in
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
@ -51,11 +51,10 @@ let inject_block cctxt block
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute operation_list) in
let shell =
{ Store.Block_header.net_id = bi.net ; predecessor = bi.hash ;
timestamp ; fitness ; operations } in
let slot = { Block.level = level.level ; priority } in
{ Store.Block_header.net_id = bi.net ; level = bi.level ;
predecessor = bi.hash ; timestamp ; fitness ; operations } in
compute_stamp cctxt block
src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce ->
src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce ->
Client_proto_rpcs.Helpers.Forge.block cctxt
block
~net:bi.net

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

@ -64,11 +64,7 @@ end
module Context = struct
let level cctxt block =
match block with
| `Genesis -> return Level.root
| `Hash h when Block_hash.equal Client_blocks.genesis h ->
return Level.root
| _ -> call_error_service1 cctxt Services.Context.level block ()
call_error_service1 cctxt Services.Context.level block ()
let next_level cctxt block =
call_error_service1 cctxt Services.Context.next_level block ()

3
src/client/embedded/genesis/client_proto_main.ml
View File

@ -26,9 +26,10 @@ let call_error_service1 rpc_config s block a1 =
let forge_block
rpc_config block net_id ?(timestamp = Time.now ()) command fitness =
Client_blocks.get_block_hash rpc_config block >>=? fun pred ->
Client_node_rpcs.Blocks.level rpc_config block >>=? fun level ->
call_service1 rpc_config
Services.Forge.block block
((net_id, pred, timestamp, fitness), command)
((net_id, Int32.succ level, pred, timestamp, fitness), command)
let mine rpc_config ?timestamp block command fitness seckey =
Client_blocks.get_block_info rpc_config block >>=? fun bi ->

14
src/node/db/store.ml
View File

@ -258,6 +258,7 @@ module Block_header = struct
type shell_header = {
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
operations: Operation_list_list_hash.t ;
@ -267,12 +268,15 @@ module Block_header = struct
let shell_header_encoding =
let open Data_encoding in
conv
(fun { net_id ; predecessor ; timestamp ; operations ; fitness } ->
(net_id, predecessor, timestamp, operations, fitness))
(fun (net_id, predecessor, timestamp, operations, fitness) ->
{ net_id ; predecessor ; timestamp ; operations ; fitness })
(obj5
(fun { net_id ; level ; predecessor ;
timestamp ; operations ; fitness } ->
(net_id, level, predecessor, timestamp, operations, fitness))
(fun (net_id, level, predecessor, timestamp, operations, fitness) ->
{ net_id ; level ; predecessor ;
timestamp ; operations ; fitness })
(obj6
(req "net_id" Net_id.encoding)
(req "level" int32)
(req "predecessor" Block_hash.encoding)
(req "timestamp" Time.encoding)
(req "operations" Operation_list_list_hash.encoding)

1
src/node/db/store.mli
View File

@ -171,6 +171,7 @@ module Block_header : sig
type shell_header = {
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
operations: Operation_list_list_hash.t ;

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

@ -138,6 +138,7 @@ module RPC = struct
type block = Node_rpc_services.Blocks.block
type block_info = Node_rpc_services.Blocks.block_info = {
hash: Block_hash.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
@ -152,6 +153,7 @@ module RPC = struct
let convert (block: State.Valid_block.t) = {
hash = block.hash ;
level = block.level ;
predecessor = block.predecessor ;
fitness = block.fitness ;
timestamp = block.timestamp ;
@ -167,6 +169,7 @@ module RPC = struct
let convert_block hash ({ shell ; proto }: State.Block_header.t) = {
net = shell.net_id ;
hash = hash ;
level = shell.level ;
predecessor = shell.predecessor ;
fitness = shell.fitness ;
timestamp = shell.timestamp ;
@ -282,16 +285,27 @@ module RPC = struct
Context.get_protocol context >>= fun protocol ->
let operations =
let pv_result, _ = Prevalidator.operations pv in
Some [ pv_result.applied ] in
let timestamp = Prevalidator.timestamp pv in
[ pv_result.applied ] in
Lwt.return
{ (convert head) with
hash = prevalidation_hash ;
{ hash = prevalidation_hash ;
level = Int32.succ head.level ;
predecessor = head.hash ;
fitness ;
timestamp = Prevalidator.timestamp pv ;
protocol = Some protocol ;
fitness ; operations ; timestamp }
operations_hash =
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute operations) ;
operations = Some operations ;
data = None ;
net = head.net_id ;
test_protocol = None ;
test_network = None ;
}
let rpc_context block : Updater.rpc_context =
{ context = block.State.Valid_block.context ;
level = Int32.succ block.level ;
fitness = block.fitness ;
timestamp = block. timestamp }
@ -313,13 +327,16 @@ module RPC = struct
| Some block -> Some (rpc_context block)
end
| ( `Prevalidation | `Test_prevalidation ) as block ->
let validator, _net = get_net node block in
let validator, net = get_net node block in
let pv = Validator.prevalidator validator in
Prevalidator.context pv >>= function
| Error _ -> Lwt.fail Not_found
| Ok { context ; fitness } ->
let timestamp = Prevalidator.timestamp pv in
Lwt.return (Some { Updater.context ; fitness ; timestamp })
State.Valid_block.Current.head
(Distributed_db.state net) >>= fun { level } ->
let level = Int32.succ level in
Lwt.return (Some { Updater.context ; fitness ; timestamp ; level })
let operations node block =
match block with

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

@ -37,6 +37,12 @@ let register_bi_dir node dir =
RPC.Answer.return bi.net in
RPC.register1 dir
Services.Blocks.net implementation in
let dir =
let implementation b () =
Node.RPC.block_info node b >>= fun bi ->
RPC.Answer.return bi.level in
RPC.register1 dir
Services.Blocks.level implementation in
let dir =
let implementation b () =
Node.RPC.block_info node b >>= fun bi ->
@ -404,14 +410,16 @@ let build_rpc_directory node =
let dir =
RPC.register1 dir Services.Protocols.contents (get_protocols node) in
let dir =
let implementation (net_id, pred, time, fitness, operations, header) =
let implementation (net_id, level, pred, time, fitness, operations, 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 net_id in
let predecessor = Utils.unopt ~default:bi.hash pred in
let level = Utils.unopt ~default:(Int32.succ bi.level) level in
let res =
Data_encoding.Binary.to_bytes Store.Block_header.encoding {
shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ;
shell = { net_id ; predecessor ; level ;
timestamp ; fitness ; operations } ;
proto = header ;
} in
RPC.Answer.return res in

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

@ -57,6 +57,7 @@ module Blocks = struct
type block_info = {
hash: Block_hash.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
@ -71,21 +72,22 @@ module Blocks = struct
let block_info_encoding =
conv
(fun { hash ; predecessor ; fitness ; timestamp ; protocol ;
(fun { hash ; level ; predecessor ; fitness ; timestamp ; protocol ;
operations_hash ; operations ; data ; net ;
test_protocol ; test_network } ->
((hash, predecessor, fitness, timestamp, protocol),
((hash, level, predecessor, fitness, timestamp, protocol),
(operations_hash, operations, data,
net, test_protocol, test_network)))
(fun ((hash, predecessor, fitness, timestamp, protocol),
(fun ((hash, level, predecessor, fitness, timestamp, protocol),
(operations_hash, operations, data,
net, test_protocol, test_network)) ->
{ hash ; predecessor ; fitness ; timestamp ; protocol ;
{ hash ; level ; predecessor ; fitness ; timestamp ; protocol ;
operations_hash ; operations ; data ; net ;
test_protocol ; test_network })
(merge_objs
(obj5
(obj6
(req "hash" Block_hash.encoding)
(req "level" int32)
(req "predecessor" Block_hash.encoding)
(req "fitness" Fitness.encoding)
(req "timestamp" Time.encoding)
@ -193,6 +195,13 @@ module Blocks = struct
~output: (obj1 (req "net" Net_id.encoding))
RPC.Path.(block_path / "net")
let level =
RPC.service
~description:"Returns the block's level."
~input: empty
~output: (obj1 (req "level" int32))
RPC.Path.(block_path / "level")
let predecessor =
RPC.service
~description:"Returns the previous block's id."
@ -642,8 +651,9 @@ let forge_block =
RPC.service
~description: "Forge a block header"
~input:
(obj6
(obj7
(opt "net_id" Net_id.encoding)
(opt "level" int32)
(opt "predecessor" Block_hash.encoding)
(opt "timestamp" Time.encoding)
(req "fitness" Fitness.encoding)

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

@ -28,6 +28,7 @@ module Blocks : sig
type block_info = {
hash: Block_hash.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
@ -44,6 +45,8 @@ module Blocks : sig
(unit, unit * block, bool * bool, block_info) RPC.service
val net:
(unit, unit * block, unit, Net_id.t) RPC.service
val level:
(unit, unit * block, unit, Int32.t) RPC.service
val predecessor:
(unit, unit * block, unit, Block_hash.t) RPC.service
val predecessors:
@ -179,7 +182,7 @@ end
val forge_block:
(unit, unit,
Net_id.t option * Block_hash.t option * Time.t option *
Net_id.t option * Int32.t option * Block_hash.t option * Time.t option *
Fitness.fitness * Operation_list_list_hash.t * MBytes.t,
MBytes.t) RPC.service

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

@ -136,7 +136,8 @@ let start_prevalidation
hash = predecessor ;
context = predecessor_context ;
timestamp = predecessor_timestamp ;
fitness = predecessor_fitness }
fitness = predecessor_fitness ;
level = predecessor_level }
~timestamp =
let (module Proto) =
match protocol with
@ -146,6 +147,7 @@ let start_prevalidation
~predecessor_context
~predecessor_timestamp
~predecessor_fitness
~predecessor_level
~predecessor
~timestamp
>>=? fun state ->

51
src/node/shell/state.ml
View File

@ -110,6 +110,7 @@ and net_state = {
and valid_block = {
net_id: Net_id.t ;
hash: Block_hash.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
fitness: Protocol.fitness ;
@ -144,6 +145,7 @@ let build_valid_block
let valid_block = {
net_id = header.Store.Block_header.shell.net_id ;
hash ;
level = header.shell.level ;
predecessor = header.shell.predecessor ;
timestamp = header.shell.timestamp ;
discovery_time ;
@ -540,6 +542,7 @@ module Raw_block_header = struct
let store_genesis store genesis =
let shell : Store.Block_header.shell_header = {
net_id = Net_id.of_block_hash genesis.block;
level = 0l ;
predecessor = genesis.block ;
timestamp = genesis.time ;
fitness = [] ;
@ -553,22 +556,23 @@ module Raw_block_header = struct
Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () ->
Lwt.return header
let store_testnet_genesis store genesis =
let shell : Store.Block_header.shell_header = {
net_id = Net_id.of_block_hash genesis.block;
predecessor = genesis.block ;
timestamp = genesis.time ;
fitness = [] ;
operations = Operation_list_list_hash.empty ;
} in
let bytes =
Data_encoding.Binary.to_bytes Store.Block_header.encoding {
shell ;
proto = MBytes.create 0 ;
} in
Locked.store_raw store genesis.block bytes >>= fun _created ->
Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () ->
Lwt.return shell
(* let store_testnet_genesis store genesis = *)
(* let shell : Store.Block_header.shell_header = { *)
(* net_id = Net_id.of_block_hash genesis.block; *)
(* level = 0l ; *)
(* predecessor = genesis.block ; *)
(* timestamp = genesis.time ; *)
(* fitness = [] ; *)
(* operations = Operation_list_list_hash.empty ; *)
(* } in *)
(* let bytes = *)
(* Data_encoding.Binary.to_bytes Store.Block_header.encoding { *)
(* shell ; *)
(* proto = MBytes.create 0 ; *)
(* } in *)
(* Locked.store_raw store genesis.block bytes >>= fun _created -> *)
(* Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () -> *)
(* Lwt.return shell *)
end
@ -693,6 +697,7 @@ module Block_header = struct
type shell_header = Store.Block_header.shell_header = {
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
operations: Operation_list_list_hash.t ;
@ -932,6 +937,7 @@ module Valid_block = struct
type t = valid_block = {
net_id: Net_id.t ;
hash: Block_hash.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
@ -996,7 +1002,7 @@ module Valid_block = struct
block_header_store
(net_state: net_state)
valid_block_watcher
hash { Updater.context ; fitness ; message } ttl =
hash { Updater.context ; message ; fitness } ttl =
(* Read the block header. *)
Raw_block_header.Locked.read
block_header_store hash >>=? fun block ->
@ -1044,11 +1050,11 @@ module Valid_block = struct
match message with
| Some message -> message
| None ->
Format.asprintf "%a: %a"
Format.asprintf "%a(%ld): %a"
Block_hash.pp_short hash
block.shell.level
Fitness.pp fitness in
Context.commit
hash ~time:block.shell.timestamp ~message context >>= fun () ->
Context.commit hash block.shell.timestamp message context >>= fun () ->
(* Update the chain state. *)
let store = net_state.chain_store in
let predecessor = block.shell.predecessor in
@ -1083,7 +1089,7 @@ module Valid_block = struct
| Error _ -> Lwt.fail Not_found
| Ok b -> Lwt.return b
let store net hash context =
let store net hash vcontext =
Shared.use net.state begin fun net_state ->
Shared.use net.block_header_store begin fun block_header_store ->
Context.exists net_state.context_index hash >>= function
@ -1095,7 +1101,8 @@ module Valid_block = struct
| None ->
Locked.store
block_header_store net_state net.valid_block_watcher
hash context net.forked_network_ttl >>=? fun valid_block ->
hash vcontext
net.forked_network_ttl >>=? fun valid_block ->
return (Some valid_block)
end
end

3
src/node/shell/state.mli
View File

@ -144,6 +144,7 @@ module Block_header : sig
type shell_header = Store.Block_header.shell_header = {
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
operations: Operation_list_list_hash.t ;
@ -245,6 +246,8 @@ module Valid_block : sig
(** The genesis of the chain this block belongs to. *)
hash: Block_hash.t ;
(** The block hash. *)
level: Int32.t ;
(** The number of preceding block in the chain. *)
predecessor: Block_hash.t ;
(** The preceding block in the chain. *)
timestamp: Time.t ;

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

@ -142,6 +142,22 @@ type error +=
| Invalid_operation of Operation_hash.t
| Non_increasing_timestamp
| Non_increasing_fitness
| Wrong_level of Int32.t * Int32.t
let () =
register_error_kind
`Permanent
~id:"validator.wrong_level"
~title:"Wrong level"
~description:"The block level is not the expected one"
~pp:(fun ppf (e, g) ->
Format.fprintf ppf
"The declared level %ld is not %ld" g e)
Data_encoding.(obj2
(req "expected" int32)
(req "provided" int32))
(function Wrong_level (e, g) -> Some (e, g) | _ -> None)
(fun (e, g) -> Wrong_level (e, g))
let apply_block net db
(pred: State.Valid_block.t) hash (block: State.Block_header.t) =
@ -151,6 +167,9 @@ let apply_block net db
Block_hash.pp_short block.shell.predecessor
Net_id.pp id
>>= fun () ->
fail_unless
(Int32.succ pred.level = block.shell.level)
(Wrong_level (Int32.succ pred.level, block.shell.level)) >>=? fun () ->
lwt_log_info "validation of %a: looking for dependencies..."
Block_hash.pp_short hash >>= fun () ->
Distributed_db.Operation_list.fetch

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

@ -24,6 +24,7 @@ type raw_operation = Store.Operation.t = {
type shell_block = Store.Block_header.shell_header =
{ net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
operations: Operation_list_list_hash.t ;
@ -43,6 +44,7 @@ type validation_result = {
type rpc_context = {
context: Context.t ;
level: Int32.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}
@ -78,6 +80,7 @@ module type PROTOCOL = sig
val begin_construction :
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_level: Int32.t ->
predecessor_fitness: Fitness.fitness ->
predecessor: Block_hash.t ->
timestamp: Time.t ->

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

@ -49,11 +49,11 @@ let register (module Proto : Protocol.PACKED_PROTOCOL) =
raw_block >|= wrap_error
let begin_construction
~predecessor_context ~predecessor_timestamp
~predecessor_fitness
~predecessor_level ~predecessor_fitness
~predecessor ~timestamp =
begin_construction
~predecessor_context ~predecessor_timestamp
~predecessor_fitness
~predecessor_level ~predecessor_fitness
~predecessor ~timestamp >|= wrap_error
let current_context c =
current_context c >|= wrap_error

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

@ -19,6 +19,7 @@ type validation_result = Protocol.validation_result = {
type rpc_context = Protocol.rpc_context = {
context: Context.t ;
level: Int32.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}
@ -44,6 +45,7 @@ let raw_operation_encoding = Store.Operation.encoding
type shell_block = Store.Block_header.shell_header = {
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
operations: Operation_list_list_hash.t ;

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

@ -20,6 +20,7 @@ val raw_operation_encoding: raw_operation Data_encoding.t
type shell_block = Store.Block_header.shell_header = {
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
operations: Operation_list_list_hash.t ;
@ -41,6 +42,7 @@ type validation_result = Protocol.validation_result = {
type rpc_context = Protocol.rpc_context = {
context: Context.t ;
level: Int32.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}

9
src/proto/alpha/amendment.ml
View File

@ -133,12 +133,13 @@ let record_ballot ctxt delegate proposal ballot =
| Testing | Proposal ->
fail Unexpected_ballot
let first_of_a_voting_period l =
Compare.Int32.(l.Level.voting_period_position = 0l)
let last_of_a_voting_period ctxt l =
Compare.Int32.(Int32.succ l.Level.voting_period_position =
Constants.voting_period_length ctxt )
let may_start_new_voting_cycle ctxt =
Level.current ctxt >>=? fun level ->
if first_of_a_voting_period level then
let level = Level.current ctxt in
if last_of_a_voting_period ctxt level then
start_new_voting_cycle ctxt
else
return ctxt

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

@ -54,16 +54,16 @@ let apply_delegate_operation_content
let ctxt = Fitness.increase ctxt in
Mining.pay_endorsement_bond ctxt delegate >>=? fun (ctxt, bond) ->
Mining.endorsement_reward ~block_priority >>=? fun reward ->
Level.current ctxt >>=? fun { cycle = current_cycle } ->
let { cycle = current_cycle } : Level.t = Level.current ctxt in
Lwt.return Tez.(reward +? bond) >>=? fun full_reward ->
Reward.record ctxt delegate current_cycle full_reward
| Proposals { period ; proposals } ->
Level.current ctxt >>=? fun level ->
let level = Level.current ctxt in
fail_unless Voting_period.(level.voting_period = period)
(Wrong_voting_period (level.voting_period, period)) >>=? fun () ->
Amendment.record_proposals ctxt delegate proposals
| Ballot { period ; proposal ; ballot } ->
Level.current ctxt >>=? fun level ->
let level = Level.current ctxt in
fail_unless Voting_period.(level.voting_period = period)
(Wrong_voting_period (level.voting_period, period)) >>=? fun () ->
Amendment.record_ballot ctxt delegate proposal ballot
@ -228,11 +228,8 @@ let apply_operation
let may_start_new_cycle ctxt =
Mining.dawn_of_a_new_cycle ctxt >>=? function
| None -> return ctxt
| Some new_cycle ->
let last_cycle =
match Cycle.pred new_cycle with
| None -> assert false
| Some last_cycle -> last_cycle in
| Some last_cycle ->
let new_cycle = Cycle.succ last_cycle in
Bootstrap.refill ctxt >>=? fun ctxt ->
Seed.clear_cycle ctxt last_cycle >>=? fun ctxt ->
Seed.compute_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt ->
@ -259,12 +256,11 @@ let begin_application ctxt block pred_timestamp =
let finalize_application ctxt block miner =
(* end of level (from this point nothing should fail) *)
let priority = block.Block.proto.mining_slot.priority in
let priority = block.Block.proto.priority in
let reward = Mining.base_mining_reward ctxt ~priority in
Nonce.record_hash 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 ->

40
src/proto/alpha/block_repr.ml
View File

@ -19,37 +19,23 @@ type header = {
}
and proto_header = {
mining_slot: mining_slot ;
priority: int ;
seed_nonce_hash: Nonce_hash.t ;
proof_of_work_nonce: MBytes.t ;
}
and mining_slot = {
level: Raw_level_repr.t ;
priority: int ;
}
let mining_slot_encoding =
let open Data_encoding in
conv
(fun { level ; priority } -> level, priority)
(fun (level, priority) -> { level ; priority })
(obj2
(req "level" Raw_level_repr.encoding)
(req "priority" uint16))
let proto_header_encoding =
let open Data_encoding in
conv
(fun { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } ->
(mining_slot, (seed_nonce_hash, proof_of_work_nonce)))
(fun (mining_slot, (seed_nonce_hash, proof_of_work_nonce)) ->
{ mining_slot ; seed_nonce_hash ; proof_of_work_nonce })
(merge_objs
mining_slot_encoding
(obj2
(req "seed_nonce_hash" Nonce_hash.encoding)
(req "proof_of_work_nonce" (Fixed.bytes Constants_repr.proof_of_work_nonce_size))))
(fun { priority ; seed_nonce_hash ; proof_of_work_nonce } ->
(priority, seed_nonce_hash, proof_of_work_nonce))
(fun (priority, seed_nonce_hash, proof_of_work_nonce) ->
{ priority ; seed_nonce_hash ; proof_of_work_nonce })
(obj3
(req "priority" uint16)
(req "seed_nonce_hash" Nonce_hash.encoding)
(req "proof_of_work_nonce"
(Fixed.bytes Constants_repr.proof_of_work_nonce_size)))
let signed_proto_header_encoding =
let open Data_encoding in
@ -76,13 +62,15 @@ type error +=
| Cant_parse_proto_header
let parse_header
({ shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ;
({ shell = { net_id ; level ; predecessor ;
timestamp ; fitness ; operations } ;
proto } : Updater.raw_block) : header tzresult =
match Data_encoding.Binary.of_bytes signed_proto_header_encoding proto with
| None -> Error [Cant_parse_proto_header]
| Some (proto, signature) ->
let shell =
{ Updater.net_id ; predecessor ; timestamp ; fitness ; operations } in
{ Updater.net_id ; level ; predecessor ;
timestamp ; fitness ; operations } in
Ok { shell ; proto ; signature }
let forge_header shell proto =

9
src/proto/alpha/block_repr.mli
View File

@ -17,18 +17,11 @@ type header = {
}
and proto_header = {
mining_slot: mining_slot ;
priority: int ;
seed_nonce_hash: Nonce_hash.t ;
proof_of_work_nonce: MBytes.t ;
}
and mining_slot = {
level: Raw_level_repr.t ;
priority: int ;
}
val mining_slot_encoding: mining_slot Data_encoding.encoding
(** The maximum size of block headers in bytes *)
val max_header_length: int

39
src/proto/alpha/init_storage.ml
View File

@ -7,19 +7,9 @@
(* *)
(**************************************************************************)
let version_key = ["version"]
(* This key should always be populated for every version of the
protocol. It's absence meaning that the context is empty. *)
let version_value = "alpha"
(* This is the genesis protocol: initialise the state *)
let initialize ~timestamp ~fitness (ctxt: Context.t) =
Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
Storage.prepare ~timestamp ~fitness ctxt >>=? fun store ->
Level_storage.init store >>=? fun store ->
let initialize store =
Roll_storage.init store >>=? fun store ->
Nonce_storage.init store >>=? fun store ->
Seed_storage.init store >>=? fun store ->
Contract_storage.init store >>=? fun store ->
Reward_storage.init store >>=? fun store ->
@ -32,34 +22,25 @@ let initialize ~timestamp ~fitness (ctxt: Context.t) =
return store
type error +=
| Incompatiple_protocol_version
| Unimplemented_sandbox_migration
let may_initialize ctxt ~timestamp ~fitness =
Context.get ctxt version_key >>= function
| None ->
(* This is the genesis protocol: The only acceptable preceding
version is an empty context *)
initialize ~timestamp ~fitness ctxt
| Some bytes ->
let s = MBytes.to_string bytes in
if Compare.String.(s = version_value) then
Storage.prepare ~timestamp ~fitness ctxt
else if Compare.String.(s = "genesis") then
initialize ~timestamp ~fitness ctxt
else
fail Incompatiple_protocol_version
let may_initialize ctxt ~level ~timestamp ~fitness =
Storage.prepare ~level ~timestamp ~fitness ctxt >>=? fun (ctxt, first_block) ->
if first_block then
initialize ctxt
else
return ctxt
let configure_sandbox ctxt json =
let json =
match json with
| None -> `O []
| Some json -> json in
Context.get ctxt version_key >>= function
| None ->
Storage.is_first_block ctxt >>=? function
| true ->
Storage.set_sandboxed ctxt json >>= fun ctxt ->
return ctxt
| Some _ ->
| false ->
Storage.get_sandboxed ctxt >>=? function
| None ->
fail Unimplemented_sandbox_migration

42
src/proto/alpha/level_repr.ml
View File

@ -10,6 +10,7 @@
type t = {
level: Raw_level_repr.t ;
level_position: int32 ;
cycle: Cycle_repr.t ;
cycle_position: int32 ;
voting_period: Voting_period_repr.t ;
@ -22,47 +23,58 @@ let pp ppf { level } = Raw_level_repr.pp ppf level
let pp_full ppf l =
Format.fprintf ppf
"%a (cycle %a.%ld) (vote %a.%ld)"
Raw_level_repr.pp l.level
"%a.%ld (cycle %a.%ld) (vote %a.%ld)"
Raw_level_repr.pp l.level l.level_position
Cycle_repr.pp l.cycle l.cycle_position
Voting_period_repr.pp l.voting_period l.voting_period_position
let encoding =
let open Data_encoding in
conv
(fun { level ; cycle ; cycle_position ;
(fun { level ; level_position ;
cycle ; cycle_position ;
voting_period; voting_period_position } ->
(level, cycle, cycle_position,
(level, level_position,
cycle, cycle_position,
voting_period, voting_period_position))
(fun (level, cycle, cycle_position,
(fun (level, level_position,
cycle, cycle_position,
voting_period, voting_period_position) ->
{ level ; cycle ; cycle_position ;
{ level ; level_position ;
cycle ; cycle_position ;
voting_period ; voting_period_position })
(obj5
(obj6
(req "level" Raw_level_repr.encoding)
(req "level_position" int32)
(req "cycle" Cycle_repr.encoding)
(req "cycle_position" int32)
(req "voting_period" Voting_period_repr.encoding)
(req "voting_period_position" int32))
let root =
{ level = Raw_level_repr.root ;
let root first_level =
{ level = first_level ;
level_position = 0l ;
cycle = Cycle_repr.root ;
cycle_position = 0l ;
voting_period = Voting_period_repr.root ;
voting_period_position = 0l ;
}
let from_raw ~cycle_length ~voting_period_length level =
let from_raw ~first_level ~cycle_length ~voting_period_length level =
let raw_level = Raw_level_repr.to_int32 level in
let cycle = Cycle_repr.of_int32_exn (Int32.div raw_level cycle_length) in
let cycle_position = Int32.rem raw_level cycle_length in
let first_level = Raw_level_repr.to_int32 first_level in
let level_position =
Compare.Int32.max 0l (Int32.sub raw_level first_level) in
let cycle =
Cycle_repr.of_int32_exn (Int32.div level_position cycle_length) in
let cycle_position = Int32.rem level_position cycle_length in
let voting_period =
Voting_period_repr.of_int32_exn
(Int32.div raw_level voting_period_length) in
(Int32.div level_position voting_period_length) in
let voting_period_position =
Int32.rem raw_level voting_period_length in
{ level ; cycle ; cycle_position ;
Int32.rem level_position voting_period_length in
{ level ; level_position ;
cycle ; cycle_position ;
voting_period ; voting_period_position }
let diff { level = l1 } { level = l2 } =

7
src/proto/alpha/level_repr.mli
View File

@ -9,6 +9,7 @@
type t = private {
level: Raw_level_repr.t ;
level_position: int32 ;
cycle: Cycle_repr.t ;
cycle_position: int32 ;
voting_period: Voting_period_repr.t ;
@ -21,10 +22,12 @@ val pp: Format.formatter -> level -> unit
val pp_full: Format.formatter -> level -> unit
include Compare.S with type t := level
val root: level
val root: Raw_level_repr.t -> level
val from_raw:
cycle_length:int32 -> voting_period_length:int32 ->
first_level:Raw_level_repr.t ->
cycle_length:int32 ->
voting_period_length:int32 ->
Raw_level_repr.t -> level
val diff: level -> level -> int32

25
src/proto/alpha/level_storage.ml
View File

@ -15,31 +15,29 @@ let from_raw c ?offset l =
| None -> l
| Some o -> Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) in
let constants = Storage.constants c in
let first_level = Storage.first_level c in
Level_repr.from_raw
~first_level
~cycle_length:constants.Constants_repr.cycle_length
~voting_period_length:constants.Constants_repr.voting_period_length
l
let root c =
Level_repr.root (Storage.first_level c)
let succ c l = from_raw c (Raw_level_repr.succ l.level)
let pred c l =
match Raw_level_repr.pred l.Level_repr.level with
| None -> None
| Some l -> Some (from_raw c l)
let current ctxt =
Storage.Current_level.get ctxt >>=? fun l ->
return (from_raw ctxt l)
let current ctxt = Storage.current_level ctxt
let previous ctxt =
current ctxt >>=? fun l ->
let l = current ctxt in
match pred ctxt l with
| None -> assert false (* Context inited with level = 1. *)
| Some p -> return p
let increment_current ctxt =
Storage.Current_level.get ctxt >>=? fun l ->
Storage.Current_level.set ctxt (Raw_level_repr.succ l)
| None -> assert false (* We never validate the Genesis... *)
| Some p -> p
let first_level_in_cycle ctxt c =
let constants = Storage.constants ctxt in
@ -60,8 +58,3 @@ let levels_in_cycle ctxt c =
else acc
in
loop first []
let init ctxt =
Storage.Current_level.init ctxt Raw_level_repr.(succ root)

7
src/proto/alpha/level_storage.mli
View File

@ -7,11 +7,10 @@
(* *)
(**************************************************************************)
val init: Storage.t -> Storage.t tzresult Lwt.t
val current: Storage.t -> Level_repr.t
val previous: Storage.t -> Level_repr.t
val increment_current: Storage.t -> Storage.t tzresult Lwt.t
val current: Storage.t -> Level_repr.t tzresult Lwt.t
val previous: Storage.t -> Level_repr.t tzresult Lwt.t
val root: Storage.t -> Level_repr.t
val from_raw: Storage.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t
val pred: Storage.t -> Level_repr.t -> Level_repr.t option

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

@ -50,8 +50,10 @@ let begin_application
~predecessor_fitness:pred_fitness
raw_block =
Lwt.return (Tezos_context.Block.parse_header raw_block) >>=? fun header ->
let level = header.shell.level in
let fitness = pred_fitness in
let timestamp = header.shell.timestamp in
Tezos_context.init ~timestamp ~fitness:pred_fitness ctxt >>=? fun ctxt ->
Tezos_context.init ~level ~timestamp ~fitness 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 }
@ -59,11 +61,14 @@ let begin_application
let begin_construction
~predecessor_context:ctxt
~predecessor_timestamp:_
~predecessor_level:pred_level
~predecessor_fitness:pred_fitness
~predecessor:pred_block
~timestamp =
let mode = Construction { pred_block ; timestamp } in
Tezos_context.init ~timestamp ~fitness:pred_fitness ctxt >>=? fun ctxt ->
let level = Int32.succ pred_level in
let fitness = pred_fitness in
Tezos_context.init ~timestamp ~level ~fitness ctxt >>=? fun ctxt ->
let ctxt = Apply.begin_construction ctxt in
return { mode ; ctxt ; op_count = 0 }
@ -74,7 +79,7 @@ let apply_operation ({ mode ; ctxt ; op_count } as data) operation =
pred_block, 0, None
| Application (block, delegate) ->
block.shell.predecessor,
block.proto.mining_slot.priority,
block.proto.priority,
Some (Tezos_context.Contract.default_contract delegate) in
Apply.apply_operation
ctxt miner_contract pred_block block_prio operation
@ -88,8 +93,9 @@ let finalize_block { mode ; ctxt ; op_count } = match mode with
return ctxt
| Application (block, miner) ->
Apply.finalize_application ctxt block miner >>=? fun ctxt ->
Tezos_context.Level.current ctxt >>=? fun { level } ->
let priority = block.proto.mining_slot.priority in
let { level } : Tezos_context.Level.t =
Tezos_context. Level.current ctxt in
let priority = block.proto.priority in
let level = Tezos_context.Raw_level.to_int32 level in
let fitness = Tezos_context.Fitness.current ctxt in
let commit_message =

39
src/proto/alpha/mining.ml
View File

@ -14,7 +14,6 @@ open Misc
type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
type error += Invalid_endorsement_slot of int * int (* `Permanent *)
type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *)
type error += Wrong_level of Raw_level.t * Raw_level.t (* `Permanent *)
type error += Wrong_delegate of public_key_hash * public_key_hash (* `Permanent *)
type error += Cannot_pay_mining_bond (* `Permanent *)
type error += Cannot_pay_endorsement_bond (* `Permanent *)
@ -60,20 +59,6 @@ let () =
(req "provided" int16))
(function Invalid_endorsement_slot (m, g) -> Some (m, g) | _ -> None)
(fun (m, g) -> Invalid_endorsement_slot (m, g)) ;
register_error_kind
`Permanent
~id:"mining.wrong_level"
~title:"Wrong level"
~description:"The block level is not the expected one"
~pp:(fun ppf (e, g) ->
Format.fprintf ppf
"The declared level %a is not %a"
Raw_level.pp g Raw_level.pp e)
Data_encoding.(obj2
(req "expected" Raw_level.encoding)
(req "provided" Raw_level.encoding))
(function Wrong_level (e, g) -> Some (e, g) | _ -> None)
(fun (e, g) -> Wrong_level (e, g)) ;
register_error_kind
`Permanent
~id:"mining.wrong_delegate"
@ -133,21 +118,14 @@ let check_timestamp c priority pred_timestamp =
fail_unless Timestamp.(minimal_time <= timestamp)
(Timestamp_too_early (minimal_time, timestamp))
let check_mining_rights c
{ Block.proto = { mining_slot = { level = raw_level ; priority } } }
let check_mining_rights c { Block.proto = { priority } }
pred_timestamp =
Level.current c >>=? fun current_level ->
fail_unless
Raw_level.(raw_level = current_level.level)
(Wrong_level (current_level.Level.level, raw_level)) >>=? fun () ->
let level = Level.from_raw c raw_level in
let level = Level.current c in
Roll.mining_rights_owner c level ~priority >>=? fun delegate ->
check_timestamp c priority pred_timestamp >>=? fun () ->
return delegate
let pay_mining_bond c
{ Block.proto = { mining_slot = { priority} } }
id =
let pay_mining_bond c { Block.proto = { priority } } id =
if Compare.Int.(priority >= Constants.first_free_mining_slot c)
then return c
else
@ -163,7 +141,7 @@ let pay_endorsement_bond c id =
let check_signing_rights c slot delegate =
fail_unless Compare.Int.(0 <= slot && slot <= Constants.max_signing_slot c)
(Invalid_endorsement_slot (Constants.max_signing_slot c, slot)) >>=? fun () ->
Level.current c >>=? fun level ->
let level = Level.current c in
Roll.endorsement_rights_owner c level ~slot >>=? fun owning_delegate ->
fail_unless (Ed25519.Public_key_hash.equal owning_delegate delegate)
(Wrong_delegate (owning_delegate, delegate))
@ -281,12 +259,13 @@ let check_fitness_gap ctxt (block : Block.header) =
else
return ()
let first_of_a_cycle l =
Compare.Int32.(l.Level.cycle_position = 0l)
let last_of_a_cycle ctxt l =
Compare.Int32.(Int32.succ l.Level.cycle_position =
Constants.cycle_length ctxt)
let dawn_of_a_new_cycle ctxt =
Level.current ctxt >>=? fun level ->
if first_of_a_cycle level then
let level = Level.current ctxt in
if last_of_a_cycle ctxt level then
return (Some level.cycle)
else
return None

1
src/proto/alpha/mining.mli
View File

@ -14,7 +14,6 @@ open Misc
type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
type error += Invalid_endorsement_slot of int * int (* `Permanent *)
type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *)
type error += Wrong_level of Raw_level.t * Raw_level.t (* `Permanent *)
type error += Wrong_delegate of public_key_hash * public_key_hash (* `Permanent *)
type error += Cannot_pay_mining_bond (* `Permanent *)
type error += Cannot_pay_endorsement_bond (* `Permanent *)

7
src/proto/alpha/nonce_storage.ml
View File

@ -18,7 +18,7 @@ type error +=
| Unexpected_nonce
let get_unrevealed c level =
Level_storage.current c >>=? fun cur_level ->
let cur_level = Level_storage.current c in
let min_cycle =
match Cycle_repr.pred cur_level.cycle with
| None -> Cycle_repr.root
@ -40,7 +40,7 @@ let get_unrevealed c level =
(* return nonce_hash *)
let record_hash c delegate_to_reward reward_amount nonce_hash =
Level_storage.current c >>=? fun level ->
let level = Level_storage.current c in
Storage.Seed.Nonce.init c level
(Unrevealed { nonce_hash; delegate_to_reward ; reward_amount })
@ -65,6 +65,3 @@ let get c level = Storage.Seed.Nonce.get c level
let of_bytes = Seed_repr.make_nonce
let hash = Seed_repr.hash
let check_hash = Seed_repr.check_hash
let init c =
Storage.Seed.Nonce.init c Level_repr.root (Revealed Seed_repr.initial_nonce_0)

3
src/proto/alpha/nonce_storage.mli
View File

@ -41,6 +41,3 @@ val get: Storage.t -> Level_repr.t -> status tzresult Lwt.t
val of_bytes: MBytes.t -> nonce tzresult
val hash: nonce -> Nonce_hash.t
val check_hash: nonce -> Nonce_hash.t -> bool
val init:
Storage.t -> Storage.t tzresult Lwt.t

6
src/proto/alpha/raw_level_repr.ml
View File

@ -39,3 +39,9 @@ let of_int32_exn l =
if Compare.Int32.(l >= 0l)
then l
else invalid_arg "Level_repr.of_int32"
type error += Unexpected_level of Int32.t
let of_int32 l =
try Ok (of_int32_exn l)
with _ -> Error [Unexpected_level l]

1
src/proto/alpha/raw_level_repr.mli
View File

@ -16,6 +16,7 @@ include Compare.S with type t := raw_level
val to_int32: raw_level -> int32
val of_int32_exn: int32 -> raw_level
val of_int32: int32 -> raw_level tzresult
val diff: raw_level -> raw_level -> int32

2
src/proto/alpha/seed_storage.ml
View File

@ -45,7 +45,7 @@ let compute_for_cycle c cycle =
| c -> Lwt.return c
let for_cycle c cycle =
Level_storage.current c >>=? fun current_level ->
let current_level = Level_storage.current c in
let current_cycle = current_level.cycle in
let next_cycle = (Level_storage.succ c current_level).cycle in
fail_unless

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

@ -9,8 +9,8 @@
open Tezos_context
let rpc_init { Updater.context ; timestamp ; fitness } =
Tezos_context.init ~timestamp ~fitness context
let rpc_init { Updater.context ; level ; timestamp ; fitness } =
Tezos_context.init ~level ~timestamp ~fitness context
let rpc_services = ref (RPC.empty : Updater.rpc_context RPC.directory)
let register0 s f =
@ -95,7 +95,7 @@ let () =
type error += Unexpected_level_in_context
let level ctxt =
Level.current ctxt >>=? fun level ->
let level = Level.current ctxt in
match Level.pred ctxt level with
| None -> fail Unexpected_level_in_context
| Some level -> return level
@ -103,7 +103,7 @@ let level ctxt =
let () = register0 Services.Context.level level
let next_level ctxt =
Level.current ctxt
return (Level.current ctxt)
let () = register0 Services.Context.next_level next_level
@ -193,7 +193,7 @@ let () =
| None -> Error_monad.fail Operation.Cannot_parse_operation
| Some (shell, contents) ->
let operation = { hash ; shell ; contents ; signature } in
Tezos_context.Level.current ctxt >>=? fun level ->
let level = Tezos_context.Level.current ctxt in
Mining.mining_priorities ctxt level >>=? fun (Misc.LCons (miner_pkh, _)) ->
let miner_contract = Contract.default_contract miner_pkh in
let block_prio = 0 in
@ -302,7 +302,7 @@ let mining_rights ctxt level max =
let () =
register1 Services.Helpers.Rights.mining_rights
(fun ctxt max ->
Level.current ctxt >>=? fun level ->
let level = Level.current ctxt in
mining_rights ctxt level max >>=? fun (raw_level, slots) ->
begin
Lwt_list.filter_map_p (fun x -> x) @@
@ -325,7 +325,7 @@ let () =
let mining_rights_for_delegate
ctxt contract (max_priority, min_level, max_level) =
let max_priority = default_max_mining_priority ctxt max_priority in
Level.current ctxt >>=? fun current_level ->
let current_level = Level.current ctxt in
let max_level =
match max_level with
| None ->
@ -381,7 +381,7 @@ let endorsement_rights ctxt level max =
let () =
register1 Services.Helpers.Rights.endorsement_rights
(fun ctxt max ->
Level.current ctxt >>=? fun level ->
let level = Level.current ctxt in
endorsement_rights ctxt (Level.succ ctxt level) max) ;
register2 Services.Helpers.Rights.endorsement_rights_for_level
(fun ctxt raw_level max ->
@ -390,7 +390,7 @@ let () =
let endorsement_rights_for_delegate
ctxt contract (max_priority, min_level, max_level) =
Level.current ctxt >>=? fun current_level ->
let current_level = Level.current ctxt in
let max_priority = default_max_endorsement_priority ctxt max_priority in
let max_level =
match max_level with
@ -435,11 +435,12 @@ let () = register1 Services.Helpers.Forge.operations forge_operations
let forge_block _ctxt
(net_id, predecessor, timestamp, fitness, operations,
raw_level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t =
let mining_slot = { Block.level = raw_level ; priority } in
level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t =
let level = Raw_level.to_int32 level in
return (Block.forge_header
{ net_id ; predecessor ; timestamp ; fitness ; operations }
{ mining_slot ; seed_nonce_hash ; proof_of_work_nonce })
{ net_id ; level ; predecessor ;
timestamp ; fitness ; operations }
{ priority ; seed_nonce_hash ; proof_of_work_nonce })
let () = register1 Services.Helpers.Forge.block forge_block

78
src/proto/alpha/storage.ml
View File

@ -10,17 +10,55 @@
open Tezos_hash
open Storage_functors
(* This key should always be populated for every version of the
protocol. It's absence meaning that the context is empty. *)
let version_key = ["version"]
let version_value = "alpha"
type error += Incompatiple_protocol_version
let is_first_block ctxt =
Context.get ctxt version_key >>= function
| None ->
return true
| Some bytes ->
let s = MBytes.to_string bytes in
if Compare.String.(s = version_value) then
return false
else if Compare.String.(s = "genesis") then
return true
else
fail Incompatiple_protocol_version
let version = "v1"
let first_level_key = [ version ; "first_level" ]
let sandboxed_key = [ version ; "sandboxed" ]
type t = Storage_functors.context
type error += Invalid_sandbox_parameter
let current_level { level } = level
let current_timestamp { timestamp } = timestamp
let current_fitness { fitness } = fitness
let set_current_fitness c fitness = { c with fitness }
let get_first_level ctxt =
Context.get ctxt first_level_key >>= function
| None -> failwith "Invalid context"
| Some bytes ->
match
Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes
with
| None -> failwith "Invalid context"
| Some level -> return level
let set_first_level ctxt level =
let bytes =
Data_encoding.Binary.to_bytes Raw_level_repr.encoding level in
Context.set ctxt first_level_key bytes >>= fun ctxt ->
return ctxt
let get_sandboxed c =
Context.get c sandboxed_key >>= function
| None -> return None
@ -33,21 +71,41 @@ let set_sandboxed c json =
Context.set c sandboxed_key
(Data_encoding.Binary.to_bytes Data_encoding.json json)
let prepare ~timestamp ~fitness (c : Context.t) : t tzresult Lwt.t =
let may_tag_first_block ctxt level =
is_first_block ctxt >>=? function
| false ->
get_first_level ctxt >>=? fun level ->
return (ctxt, false, level)
| true ->
Context.set ctxt version_key
(MBytes.of_string version_value) >>= fun ctxt ->
set_first_level ctxt level >>=? fun ctxt ->
return (ctxt, true, level)
let prepare ~level ~timestamp ~fitness ctxt =
Lwt.return (Raw_level_repr.of_int32 level ) >>=? fun level ->
Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
get_sandboxed c >>=? fun sandbox ->
may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) ->
get_sandboxed ctxt >>=? fun sandbox ->
Constants_repr.read sandbox >>=? function constants ->
return { context = c ; constants ; timestamp ; fitness }
let level =
Level_repr.from_raw
~first_level
~cycle_length:constants.Constants_repr.cycle_length
~voting_period_length:constants.Constants_repr.voting_period_length
level in
return ({ context = ctxt ; constants ; level ;
timestamp ; fitness ; first_level},
first_block)
let recover { context } : Context.t = context
let first_level { first_level } = first_level
let constants { constants } = constants
module Key = struct
let store_root tail = version :: "store" :: tail
let current_level = store_root ["level"]
let global_counter = store_root ["global_counter"]
let next_cycle_to_be_rewarded = store_root ["next_cycle_to_be_rewarded"]
@ -119,16 +177,6 @@ module Key = struct
end
(** Global *)
module Current_level =
Make_single_data_storage(struct
type value = Raw_level_repr.t
let name = "level"
let key = Key.current_level
let encoding = Raw_level_repr.encoding
end)
(** Rolls *)
module Roll = struct

17
src/proto/alpha/storage.mli
View File

@ -24,11 +24,17 @@
(** Abstract view of the database *)
type t
(** Rerieves the state of the database and gives its abstract view *)
(** Is first block validated with this version of the protocol ? *)
val is_first_block: Context.t -> bool tzresult Lwt.t
(** Retrieves the state of the database and gives its abstract view.
It also returns wether this is the first block validated
with this version of the protocol. *)
val prepare :
level: Int32.t ->
timestamp: Time.t ->
fitness: Fitness.fitness ->
Context.t -> t tzresult Lwt.t
Context.t -> (t * bool) tzresult Lwt.t
(** Returns the state of the database resulting of operations on its
abstract view *)
@ -37,22 +43,19 @@ val recover : t -> Context.t
val get_sandboxed : Context.t -> Data_encoding.json option tzresult Lwt.t
val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t
val current_level : t -> Level_repr.t
val current_timestamp : t -> Time.t
val current_fitness : t -> Int64.t
val set_current_fitness : t -> Int64.t -> t
val constants : t -> Constants_repr.constants
val first_level : t -> Raw_level_repr.t
(** {1 Entity Accessors} *****************************************************)
open Storage_sigs
(** The level of the current block *)
module Current_level : Single_data_storage
with type value = Raw_level_repr.t
and type context := t
module Roll : sig
(** Storage from this submodule must only be accessed through the

2
src/proto/alpha/storage_functors.ml
View File

@ -14,6 +14,8 @@ open Misc
type context = {
context: Context.t ;
constants: Constants_repr.constants ;
first_level: Raw_level_repr.t ;
level: Level_repr.t ;
timestamp: Time.t ;
fitness: Int64.t ;
}

2
src/proto/alpha/storage_functors.mli
View File

@ -17,6 +17,8 @@
type context = {
context: Context.t ;
constants: Constants_repr.constants ;
first_level: Raw_level_repr.t ;
level: Level_repr.t ;
timestamp: Time.t ;
fitness: Int64.t ;
}

16
src/proto/alpha/tezos_context.mli
View File

@ -219,6 +219,7 @@ module Level : sig
type t = private {
level: Raw_level.t ;
level_position: int32 ;
cycle: Cycle.t ;
cycle_position: int32 ;
voting_period: Voting_period.t ;
@ -228,7 +229,7 @@ module Level : sig
val pp_full: Format.formatter -> t -> unit
type level = t
val root: level
val root: context -> level
val succ: context -> level -> level
val pred: context -> level -> level option
@ -237,8 +238,7 @@ module Level : sig
val diff: level -> level -> int32
val current: context -> level tzresult Lwt.t
val increment_current: context -> context tzresult Lwt.t
val current: context -> level
val last_level_in_cycle: context -> Cycle.t -> level
val levels_in_cycle: context -> Cycle.t -> level list
@ -523,18 +523,11 @@ module Block : sig
}
and proto_header = {
mining_slot: mining_slot ;
priority: int ;
seed_nonce_hash: Nonce_hash.t ;
proof_of_work_nonce: MBytes.t ;
}
and mining_slot = {
level: Raw_level.t ;
priority: int ;
}
val mining_slot_encoding: mining_slot Data_encoding.encoding
val max_header_length: int
val parse_header: Updater.raw_block -> header tzresult
@ -580,6 +573,7 @@ end
val init:
Context.t ->
level:Int32.t ->
timestamp:Time.t ->
fitness:Fitness.t ->
context tzresult Lwt.t

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

@ -71,6 +71,7 @@ let begin_application
let begin_construction
~predecessor_context:context
~predecessor_timestamp:_
~predecessor_level:_
~predecessor_fitness:pred_fitness
~predecessor:_
~timestamp:_ =

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

@ -19,6 +19,8 @@ val raw_operation_encoding: raw_operation Data_encoding.t
type shell_block = {
net_id: Net_id.t ;
(** The genesis of the chain this block belongs to. *)
level: Int32.t ;
(** The number of predecessing block in the chain. *)
predecessor: Block_hash.t ;
(** The preceding block in the chain. *)
timestamp: Time.t ;
@ -46,6 +48,7 @@ type validation_result = {
type rpc_context = {
context: Context.t ;
level: Int32.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}
@ -124,6 +127,7 @@ module type PROTOCOL = sig
val begin_construction :
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_level: Int32.t ->
predecessor_fitness: Fitness.fitness ->
predecessor: Block_hash.t ->
timestamp: Time.t ->

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

@ -98,6 +98,7 @@ let begin_application
let begin_construction
~predecessor_context:context
~predecessor_timestamp:_
~predecessor_level:_
~predecessor_fitness:fitness
~predecessor:_
~timestamp:_ =

9
src/proto/genesis/services.ml
View File

@ -38,8 +38,9 @@ module Forge = struct
~description: "Forge a block"
~input:
(merge_objs
(obj4
(obj5
(req "net_id" Net_id.encoding)
(req "level" int32)
(req "predecessor" Block_hash.encoding)
(req "timestamp" Time.encoding)
(req "fitness" Fitness.encoding))
@ -62,9 +63,9 @@ let rpc_services : Updater.rpc_context RPC.directory =
RPC.register
dir
(Forge.block RPC.Path.root)
(fun _ctxt ((net_id, predecessor, timestamp, fitness), command) ->
let shell = { Updater.net_id ; predecessor ; timestamp ; fitness ;
operations } in
(fun _ctxt ((net_id, level, predecessor, timestamp, fitness), command) ->
let shell = { Updater.net_id ; level ; predecessor ;
timestamp ; fitness ; operations } in
let bytes = Data.Command.forge shell command in
RPC.Answer.return bytes) in
dir

14
test/proto_alpha/proto_alpha_helpers.ml
View File

@ -361,7 +361,7 @@ module Mining = struct
block
delegate_sk
shell
mining_slot
priority
seed_nonce_hash =
Client_proto_rpcs.Constants.stamp_threshold
rpc_config block >>=? fun stamp_threshold ->
@ -370,7 +370,7 @@ module Mining = struct
Sodium.Random.Bigbytes.generate Constants.proof_of_work_nonce_size in
let unsigned_header =
Block.forge_header
shell { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } in
shell { priority ; seed_nonce_hash ; proof_of_work_nonce } in
let signed_header =
Environment.Ed25519.Signature.append delegate_sk unsigned_header in
let block_hash = Block_hash.hash_bytes [signed_header] in
@ -398,10 +398,9 @@ module Mining = struct
[Operation_list_hash.compute operation_list] in
let shell =
{ Store.Block_header.net_id = bi.net ; predecessor = bi.hash ;
timestamp ; fitness ; operations } in
let slot = { Block.level = level.level ; priority } in
timestamp ; fitness ; operations ; level = Raw_level.to_int32 level.level } in
mine_stamp
block src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce ->
block src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce ->
Client_proto_rpcs.Helpers.Forge.block rpc_config
block
~net:bi.net
@ -553,3 +552,8 @@ module Endorse = struct
block delegate ()
end
let display_level block =
Client_proto_rpcs.Context.level rpc_config block >>=? fun lvl ->
Format.eprintf "Level: %a@." Level.pp_full lvl ;
return ()

6
test/proto_alpha/proto_alpha_helpers.mli
View File

@ -105,7 +105,7 @@ module Mining : sig
Client_proto_rpcs.block ->
secret_key ->
Updater.shell_block ->
Block.mining_slot ->
int ->
Nonce_hash.t ->
MBytes.t tzresult Lwt.t
@ -192,3 +192,7 @@ module Assert : sig
val invalid_endorsement_slot : msg:string -> 'a tzresult -> unit
end
val rpc_config: Client_rpcs.config
val display_level: Client_proto_rpcs.block -> unit tzresult Lwt.t

23
test/proto_alpha/test_endorsement.ml
View File

@ -9,6 +9,7 @@
open Client_embedded_proto_alpha
open Tezos_context
open Client_alpha
module Helpers = Proto_alpha_helpers
module Assert = Helpers.Assert
@ -77,7 +78,7 @@ let test_invalid_endorsement_slot contract block =
return ()
let test_endorsement_rewards
block ({ Helpers.Account.b1 ; _ } as baccounts) =
block ({ Helpers.Account.b5 = b1 ; _ } as baccounts) =
let get_endorser_except_b1 accounts =
let account, cpt = ref accounts.(0), ref 0 in
while !account = b1 do
@ -95,9 +96,11 @@ let test_endorsement_rewards
Helpers.Account.balance account0 >>=? fun balance0 ->
Helpers.Endorse.endorse ~slot:slot0 ~force:true account0 block >>=? fun ops ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 block >>=? fun head0 ->
Helpers.display_level (`Hash head0) >>=? fun () ->
Assert.balance_equal ~msg:__LOC__ account0
(Int64.sub (Tez.to_cents balance0) bond) >>=? fun () ->
(* #2 endorse & inject in a block *)
let block0 = `Hash head0 in
Helpers.Endorse.endorsers_list block0 baccounts >>=? fun accounts ->
@ -105,9 +108,11 @@ let test_endorsement_rewards
Helpers.Account.balance account1 >>=? fun balance1 ->
Helpers.Endorse.endorse ~slot:slot1 ~force:true account1 block0 >>=? fun ops ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 block0 >>=? fun head1 ->
Helpers.display_level (`Hash head1) >>=? fun () ->
Assert.balance_equal ~msg:__LOC__ account1
(Int64.sub (Tez.to_cents balance1) bond) >>=? fun () ->
(* #3 endorse but the operation is not included in a block, so no reward *)
let block1 = `Hash head1 in
Helpers.Endorse.endorsers_list block1 baccounts >>=? fun accounts ->
@ -118,7 +123,11 @@ let test_endorsement_rewards
(Int64.sub (Tez.to_cents balance2) bond) >>=? fun () ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head1) >>=? fun head2 ->
Helpers.display_level (`Hash head2) >>=? fun () ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head2) >>=? fun head3 ->
Helpers.display_level (`Hash head3) >>=? fun () ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun head4 ->
Helpers.display_level (`Hash head4) >>=? fun () ->
(* Check rewards after one cycle for account0 *)
Helpers.Mining.endorsement_reward b1 block0 >>=? fun rw0 ->
@ -135,8 +144,10 @@ let test_endorsement_rewards
~msg:__LOC__ account2 (Tez.to_cents balance2) >>=? fun () ->
(* #2 endorse and check reward only on the good chain *)
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun head ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun fork ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head4) >>=? fun head ->
Helpers.display_level (`Hash head) >>=? fun () ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head4) >>=? fun fork ->
Helpers.display_level (`Hash fork) >>=? fun () ->
(* working on head *)
Helpers.Endorse.endorsers_list (`Hash head) baccounts >>=? fun accounts ->
@ -145,6 +156,7 @@ let test_endorsement_rewards
Helpers.Endorse.endorse
~slot:slot3 ~force:true account3 (`Hash head) >>=? fun ops ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash head) >>=? fun new_head ->
Helpers.display_level (`Hash new_head) >>=? fun () ->
(* working on fork *)
Helpers.Endorse.endorsers_list (`Hash fork) baccounts >>=? fun accounts ->
@ -152,10 +164,13 @@ let test_endorsement_rewards
Helpers.Account.balance account4 >>=? fun _balance4 ->
Helpers.Endorse.endorse ~slot:slot4 ~force:true account4 (`Hash fork) >>=? fun ops ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash fork) >>=? fun _new_fork ->
Helpers.display_level (`Hash _new_fork) >>=? fun () ->
Helpers.Account.balance account4 >>=? fun balance4 ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash new_head) >>=? fun head ->
Helpers.display_level (`Hash head) >>=? fun () ->
Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head) >>=? fun head ->
Helpers.display_level (`Hash head) >>=? fun () ->
(* Check rewards after one cycle *)
Helpers.Mining.endorsement_reward b1 (`Hash new_head) >>=? fun reward ->
@ -209,7 +224,7 @@ let run head (({ b1 ; b2 ; b3 ; b4 ; b5 } : Helpers.Account.bootstrap_accounts)
(* FIXME: cannot inject double endorsement operation yet, but the
code is still here
Double endorsement *)
test_double_endorsement b5 (`Hash head) >>=? fun new_head ->
test_double_endorsement b4 (`Hash head) >>=? fun new_head ->
return new_head

2
test/shell/test_state.ml
View File

@ -69,6 +69,7 @@ let block _state ?(operations = []) pred_hash pred name : Store.Block_header.t =
let timestamp = incr_timestamp pred.shell.timestamp in
{ shell = {
net_id = pred.shell.net_id ;
level = Int32.succ pred.shell.level ;
predecessor = pred_hash ;
timestamp ; operations; fitness } ;
proto = MBytes.of_string name ;
@ -139,6 +140,7 @@ let block _state ?(operations = []) (pred: State.Valid_block.t) name
let fitness = incr_fitness pred.fitness in
let timestamp = incr_timestamp pred.timestamp in
{ shell = { net_id = pred.net_id ;
level = Int32.succ pred.level ;
predecessor = pred.hash ;
timestamp ; operations; fitness } ;
proto = MBytes.of_string name ;

1
test/shell/test_store.ml
View File

@ -94,6 +94,7 @@ let lolblock ?(operations = []) header =
[Operation_list_hash.compute operations] in
{ Store.Block_header.shell =
{ timestamp = Time.of_seconds (Random.int64 1500L) ;
level = 0l ; (* dummy *)
net_id ;
predecessor = genesis_block ; operations ;
fitness = [MBytes.of_string @@ string_of_int @@ String.length header;