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

Merge branch 'level_in_block_header' into 'master'

Browse Source 
Move the `level` in the shell part of the block header

See merge request !177
This commit is contained in:
Grégoire Henry 2017-04-12 16:36:49 +02:00
commit f9f5bca5a0
84 changed files with 1253 additions and 1240 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: \

33
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_id ?level ?predecessor ?timestamp fitness ops header =
call_service0 cctxt Services.forge_block
(net, predecessor, timestamp, fitness, ops, header)
(net_id, level, predecessor, timestamp, fitness, ops, header)
let validate_block cctxt net block =
call_err_service0 cctxt Services.validate_block (net, block)
@ -53,16 +53,16 @@ module Blocks = struct
type block_info = Services.Blocks.block_info = {
hash: Block_hash.t ;
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
protocol: Protocol_hash.t option ;
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
data: MBytes.t ;
operations: Operation_hash.t list list option ;
data: MBytes.t option ;
net: Net_id.t ;
test_protocol: Protocol_hash.t option ;
test_network: (Net_id.t * Time.t) option ;
protocol: Protocol_hash.t ;
test_network: Context.test_network;
}
type preapply_param = Services.Blocks.preapply_param = {
operations: Operation_hash.t list ;
@ -76,6 +76,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 =
@ -90,29 +92,28 @@ module Blocks = struct
call_service1 cctxt Services.Blocks.operations h ()
let protocol cctxt h =
call_service1 cctxt Services.Blocks.protocol h ()
let test_protocol cctxt h =
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
{ operations ; sort ; timestamp }
let pending_operations cctxt block =
call_service1 cctxt Services.Blocks.pending_operations block ()
let info cctxt ?(operations = true) ?(data = true) h =
call_service1 cctxt Services.Blocks.info h (operations, data)
let info cctxt ?(include_ops = true) h =
call_service1 cctxt Services.Blocks.info h include_ops
let complete cctxt block prefix =
call_service2 cctxt Services.Blocks.complete block prefix ()
let list cctxt ?(operations = false) ?(data = false)
let list cctxt ?(include_ops = false)
?length ?heads ?delay ?min_date ?min_heads () =
call_service0 cctxt Services.Blocks.list
{ operations ; data ; length ; heads ; monitor = Some false ; delay ;
{ include_ops ; length ; heads ; monitor = Some false ; delay ;
min_date ; min_heads }
let monitor cctxt ?(operations = false) ?(data = false)
let monitor cctxt ?(include_ops = false)
?length ?heads ?delay ?min_date ?min_heads () =
call_streamed_service0 cctxt Services.Blocks.list
{ operations ; data ; length ; heads ; monitor = Some true ; delay ;
{ include_ops ; length ; heads ; monitor = Some true ; delay ;
min_date ; min_heads }
end

29
src/client/client_node_rpcs.mli
View File

@ -14,7 +14,8 @@ val errors:
val forge_block:
config ->
?net:Net_id.t ->
?net_id: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
@ -88,12 +92,9 @@ module Blocks : sig
val protocol:
config ->
block -> Protocol_hash.t tzresult Lwt.t
val test_protocol:
config ->
block -> Protocol_hash.t option tzresult Lwt.t
val test_network:
config ->
block -> (Net_id.t * Time.t) option tzresult Lwt.t
block -> Context.test_network tzresult Lwt.t
val pending_operations:
config ->
@ -102,31 +103,31 @@ module Blocks : sig
type block_info = {
hash: Block_hash.t ;
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
protocol: Protocol_hash.t option ;
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
data: MBytes.t ;
operations: Operation_hash.t list list option ;
data: MBytes.t option ;
net: Net_id.t ;
test_protocol: Protocol_hash.t option ;
test_network: (Net_id.t * Time.t) option ;
protocol: Protocol_hash.t ;
test_network: Context.test_network;
}
val info:
config ->
?operations:bool -> ?data:bool -> block -> block_info tzresult Lwt.t
?include_ops:bool -> block -> block_info tzresult Lwt.t
val list:
config ->
?operations:bool -> ?data:bool -> ?length:int -> ?heads:Block_hash.t list ->
?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
unit -> block_info list list tzresult Lwt.t
val monitor:
config ->
?operations:bool -> ?data:bool -> ?length:int -> ?heads:Block_hash.t list ->
?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t

13
src/client/embedded/alpha/baker/client_mining_blocks.ml
View File

@ -12,7 +12,7 @@ type block_info = {
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
protocol: Protocol_hash.t option ;
protocol: Protocol_hash.t ;
level: Level.t ;
}
@ -21,7 +21,8 @@ let convert_block_info cctxt
: Client_node_rpcs.Blocks.block_info ) =
Client_proto_rpcs.Context.level cctxt (`Hash hash) >>= function
| Ok level ->
Lwt.return (Some { hash ; predecessor ; fitness ; timestamp ; protocol ; level })
Lwt.return
(Some { hash ; predecessor ; fitness ; timestamp ; protocol ; level })
| Error _ ->
(* TODO log error *)
Lwt.return_none
@ -32,8 +33,8 @@ let convert_block_info_err cctxt
Client_proto_rpcs.Context.level cctxt (`Hash hash) >>=? fun level ->
return { hash ; predecessor ; fitness ; timestamp ; protocol ; level }
let info cctxt ?operations block =
Client_node_rpcs.Blocks.info cctxt ?operations block >>=? fun block ->
let info cctxt ?include_ops block =
Client_node_rpcs.Blocks.info cctxt ?include_ops block >>=? fun block ->
convert_block_info_err cctxt block
let compare (bi1 : block_info) (bi2 : block_info) =
@ -54,10 +55,10 @@ let sort_blocks cctxt ?(compare = compare) blocks =
List.sort compare blocks
let monitor cctxt
?operations ?length ?heads ?delay
?include_ops ?length ?heads ?delay
?min_date ?min_heads ?compare () =
Client_node_rpcs.Blocks.monitor cctxt
?operations ?length ?heads ?delay ?min_date ?min_heads
?include_ops ?length ?heads ?delay ?min_date ?min_heads
() >>=? fun block_stream ->
let convert blocks =
Lwt.return blocks >>=? fun blocks ->

6
src/client/embedded/alpha/baker/client_mining_blocks.mli
View File

@ -12,20 +12,20 @@ type block_info = {
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
protocol: Protocol_hash.t option ;
protocol: Protocol_hash.t ;
level: Level.t ;
}
val info:
Client_rpcs.config ->
?operations:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t
?include_ops:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t
val compare:
block_info -> block_info -> int
val monitor:
Client_rpcs.config ->
?operations:bool -> ?length:int -> ?heads:Block_hash.t list ->
?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
?compare:(block_info -> block_info -> int) ->
unit -> block_info list tzresult Lwt_stream.t tzresult Lwt.t

24
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
@ -42,28 +42,26 @@ let rec compute_stamp
let inject_block cctxt block
?force
~priority ~timestamp ~fitness ~seed_nonce
~src_sk operation_list =
~src_sk operations =
let block = match block with `Prevalidation -> `Head 0 | 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 operations =
let operations_hash =
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute operation_list) in
(List.map Operation_list_hash.compute operations) in
let shell =
{ Store.Block_header.net_id = bi.net ; predecessor = bi.hash ;
timestamp ; fitness ; operations } in
let slot =
{ Block.level = level.level ; priority = Int32.of_int priority } in
{ Store.Block_header.net_id = bi.net_id ; level = bi.level ;
predecessor = bi.hash ; timestamp ; fitness ; operations_hash } 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
~net:bi.net_id
~predecessor:bi.hash
~timestamp
~fitness
~operations
~operations_hash
~level:level.level
~priority:priority
~seed_nonce_hash
@ -71,7 +69,7 @@ let inject_block cctxt block
() >>=? fun unsigned_header ->
let signed_header = Ed25519.Signature.append src_sk unsigned_header in
Client_node_rpcs.inject_block cctxt
?force signed_header operation_list >>=? fun block_hash ->
?force signed_header operations >>=? fun block_hash ->
return block_hash
let forge_block cctxt block

10
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 ()
@ -249,10 +245,10 @@ module Helpers = struct
operations cctxt block ~net [Faucet { id ; nonce }]
end
let block cctxt
block ~net ~predecessor ~timestamp ~fitness ~operations
block ~net ~predecessor ~timestamp ~fitness ~operations_hash
~level ~priority ~seed_nonce_hash ~proof_of_work_nonce () =
call_error_service1 cctxt Services.Helpers.Forge.block block
(net, predecessor, timestamp, fitness, operations,
(net, predecessor, timestamp, fitness, operations_hash,
level, priority, seed_nonce_hash, proof_of_work_nonce)
end

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

@ -35,7 +35,7 @@ module Constants : sig
block -> (Period.t list) tzresult Lwt.t
val first_free_mining_slot:
Client_rpcs.config ->
block -> int32 tzresult Lwt.t
block -> int tzresult Lwt.t
val max_signing_slot:
Client_rpcs.config ->
block -> int tzresult Lwt.t
@ -298,7 +298,7 @@ module Helpers : sig
predecessor:Block_hash.t ->
timestamp:Time.t ->
fitness:Fitness.t ->
operations:Operation_list_list_hash.t ->
operations_hash:Operation_list_list_hash.t ->
level:Raw_level.t ->
priority:int ->
seed_nonce_hash:Nonce_hash.t ->

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

@ -51,7 +51,7 @@ let mine cctxt =
(cctxt.message "Cannot parse fitness: %a" Fitness.pp bi.fitness);
exit 2 in
Client_node_rpcs.forge_block cctxt.rpc_config
~net:bi.net ~predecessor:bi.hash
~net_id:bi.net_id ~predecessor:bi.hash
fitness Operation_list_list_hash.empty (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 () ->

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

@ -26,13 +26,15 @@ 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 ->
forge_block rpc_config ?timestamp block bi.net command fitness >>=? fun blk ->
forge_block
rpc_config ?timestamp block bi.net_id command fitness >>=? fun blk ->
let signed_blk = Environment.Ed25519.Signature.append seckey blk in
Client_node_rpcs.inject_block rpc_config signed_blk [[]]
@ -86,7 +88,8 @@ let commands () =
let fitness =
Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in
mine cctxt.rpc_config ?timestamp cctxt.config.block
(Activate_testnet hash) fitness seckey >>=? fun hash ->
(Activate_testnet (hash, Int64.mul 24L 3600L))
fitness seckey >>=? fun hash ->
cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
return ()
end ;

230
src/node/db/context.ml
View File

@ -84,14 +84,7 @@ type t = context
(*-- Version Access and Update -----------------------------------------------*)
let current_protocol_key = ["protocol"]
let current_fitness_key = ["fitness"]
let current_timestamp_key = ["timestamp"]
let current_test_protocol_key = ["test_protocol"]
let current_test_network_key = ["test_network"]
let current_test_network_expiration_key = ["test_network_expiration"]
let current_fork_test_network_key = ["fork_test_network"]
let transient_commit_message_key = ["message"]
let exists { repo } key =
GitStore.of_branch_id
@ -134,59 +127,17 @@ let exists index key =
Block_hash.pp_short key exists >>= fun () ->
Lwt.return exists
let get_and_erase_commit_message ctxt =
GitStore.FunView.get ctxt.view transient_commit_message_key >>= function
| None -> Lwt.return (None, ctxt)
| Some bytes ->
GitStore.FunView.del ctxt.view transient_commit_message_key >>= fun view ->
Lwt.return (Some (MBytes.to_string bytes), { ctxt with view })
let set_commit_message ctxt msg =
GitStore.FunView.set ctxt.view
transient_commit_message_key
(MBytes.of_string msg) >>= fun view ->
Lwt.return { ctxt with view }
let get_fitness { view } =
GitStore.FunView.get view current_fitness_key >>= function
| None -> assert false
| Some data ->
match Data_encoding.Binary.of_bytes Fitness.encoding data with
| None -> assert false
| Some data -> Lwt.return data
let set_fitness ctxt data =
GitStore.FunView.set ctxt.view current_fitness_key
(Data_encoding.Binary.to_bytes Fitness.encoding data) >>= fun view ->
Lwt.return { ctxt with view }
let get_timestamp { view } =
GitStore.FunView.get view current_timestamp_key >>= function
| None -> assert false
| Some time ->
Lwt.return (Time.of_notation_exn (MBytes.to_string time))
let set_timestamp ctxt time =
GitStore.FunView.set ctxt.view current_timestamp_key
(MBytes.of_string (Time.to_notation time)) >>= fun view ->
Lwt.return { ctxt with view }
exception Preexistent_context of Block_hash.t
exception Empty_head of Block_hash.t
let commit key context =
get_timestamp context >>= fun timestamp ->
get_fitness context >>= fun fitness ->
let task =
Irmin.Task.create ~date:(Time.to_seconds timestamp) ~owner:"Tezos" in
let commit key ~time ~message context =
let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in
GitStore.clone task context.store (Block_hash.to_b58check key) >>= function
| `Empty_head -> Lwt.fail (Empty_head key)
| `Duplicated_branch -> Lwt.fail (Preexistent_context key)
| `Ok store ->
get_and_erase_commit_message context >>= fun (msg, context) ->
let msg = match msg with
| None ->
Format.asprintf "%a %a"
Fitness.pp fitness Block_hash.pp_short key
| Some msg -> msg in
GitStore.FunView.update_path (store msg) [] context.view >>= fun () ->
GitStore.FunView.update_path
(store message) [] context.view >>= fun () ->
context.index.commits <- context.index.commits + 1 ;
if context.index.commits mod 200 = 0 then
Lwt_utils.Idle_waiter.force_idle
@ -250,6 +201,77 @@ let remove_rec ctxt key =
GitStore.FunView.remove_rec ctxt.view (data_key key) >>= fun view ->
Lwt.return { ctxt with view }
(*-- Predefined Fields -------------------------------------------------------*)
let get_protocol v =
raw_get v current_protocol_key >>= function
| None -> assert false
| Some data -> Lwt.return (Protocol_hash.of_bytes_exn data)
let set_protocol v key =
raw_set v current_protocol_key (Protocol_hash.to_bytes key)
type test_network =
| Not_running
| Forking of {
protocol: Protocol_hash.t ;
expiration: Time.t ;
}
| Running of {
net_id: Net_id.t ;
genesis: Block_hash.t ;
protocol: Protocol_hash.t ;
expiration: Time.t ;
}
let test_network_encoding =
let open Data_encoding in
union [
case ~tag:0
(obj1 (req "status" (constant "not_running")))
(function Not_running -> Some () | _ -> None)
(fun () -> Not_running) ;
case ~tag:1
(obj3
(req "status" (constant "forking"))
(req "protocol" Protocol_hash.encoding)
(req "expiration" Time.encoding))
(function
| Forking { protocol ; expiration } ->
Some ((), protocol, expiration)
| _ -> None)
(fun ((), protocol, expiration) ->
Forking { protocol ; expiration }) ;
case ~tag:2
(obj5
(req "status" (constant "running"))
(req "net_id" Net_id.encoding)
(req "genesis" Block_hash.encoding)
(req "protocol" Protocol_hash.encoding)
(req "expiration" Time.encoding))
(function
| Running { net_id ; genesis ; protocol ; expiration } ->
Some ((), net_id, genesis, protocol, expiration)
| _ -> None)
(fun ((), net_id, genesis, protocol, expiration) ->
Running { net_id ; genesis ;protocol ; expiration }) ;
]
let get_test_network v =
raw_get v current_test_network_key >>= function
| None -> Lwt.fail (Failure "Unexpected error (Context.get_test_network)")
| Some data ->
match Data_encoding.Binary.of_bytes test_network_encoding data with
| None -> Lwt.fail (Failure "Unexpected error (Context.get_test_network)")
| Some r -> Lwt.return r
let set_test_network v id =
raw_set v current_test_network_key
(Data_encoding.Binary.to_bytes test_network_encoding id)
let del_test_network v = raw_del v current_test_network_key
let fork_test_network v ~protocol ~expiration =
set_test_network v (Forking { protocol ; expiration })
(*-- Initialisation ----------------------------------------------------------*)
let init ?patch_context ~root =
@ -266,86 +288,48 @@ let init ?patch_context ~root =
| Some patch_context -> patch_context
}
let commit_genesis index ~id:block ~time ~protocol ~test_protocol =
let commit_genesis index ~id:block ~time ~protocol =
let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in
GitStore.of_branch_id
Irmin.Task.none (Block_hash.to_b58check block)
task (Block_hash.to_b58check block)
index.repo >>= fun t ->
let store = t () in
let store = t "Genesis" in
GitStore.FunView.of_path store [] >>= fun view ->
let view = (view, index.repack_scheduler) in
GitStore.FunView.set view current_timestamp_key
(MBytes.of_string (Time.to_notation time)) >>= fun view ->
GitStore.FunView.set view current_protocol_key
(Protocol_hash.to_bytes protocol) >>= fun view ->
GitStore.FunView.set view current_fitness_key
(Data_encoding.Binary.to_bytes Fitness.encoding []) >>= fun view ->
GitStore.FunView.set view current_test_protocol_key
(Protocol_hash.to_bytes test_protocol) >>= fun view ->
let ctxt = { index ; store ; view } in
set_protocol ctxt protocol >>= fun ctxt ->
set_test_network ctxt Not_running >>= fun ctxt ->
index.patch_context ctxt >>= fun ctxt ->
GitStore.FunView.update_path ctxt.store [] ctxt.view >>= fun () ->
Lwt.return ctxt
(*-- Predefined Fields -------------------------------------------------------*)
let compute_testnet_genesis forked_block =
let genesis = Block_hash.hash_bytes [Block_hash.to_bytes forked_block] in
let net_id = Net_id.of_block_hash genesis in
net_id, genesis
let get_protocol v =
raw_get v current_protocol_key >>= function
| None -> assert false
| Some data -> Lwt.return (Protocol_hash.of_bytes_exn data)
let set_protocol v key =
raw_set v current_protocol_key (Protocol_hash.to_bytes key)
let get_test_protocol v =
raw_get v current_test_protocol_key >>= function
| None -> assert false
| Some data -> Lwt.return (Protocol_hash.of_bytes_exn data)
let set_test_protocol v data =
raw_set v current_test_protocol_key (Protocol_hash.to_bytes data)
let get_test_network v =
raw_get v current_test_network_key >>= function
| None -> Lwt.return_none
| Some data -> Lwt.return (Some (Net_id.of_bytes_exn data))
let set_test_network v id =
raw_set v current_test_network_key (Net_id.to_bytes id)
let del_test_network v = raw_del v current_test_network_key
let get_test_network_expiration v =
raw_get v current_test_network_expiration_key >>= function
| None -> Lwt.return_none
| Some data -> Lwt.return (Time.of_notation @@ MBytes.to_string data)
let set_test_network_expiration v data =
raw_set v current_test_network_expiration_key
(MBytes.of_string @@ Time.to_notation data)
let del_test_network_expiration v =
raw_del v current_test_network_expiration_key
let read_and_reset_fork_test_network v =
raw_get v current_fork_test_network_key >>= function
| None -> Lwt.return (false, v)
| Some _ ->
raw_del v current_fork_test_network_key >>= fun v ->
Lwt.return (true, v)
let fork_test_network v =
raw_set v current_fork_test_network_key (MBytes.of_string "fork")
let init_test_network v ~time ~genesis =
get_test_protocol v >>= fun test_protocol ->
del_test_network_expiration v >>= fun v ->
set_protocol v test_protocol >>= fun v ->
set_timestamp v time >>= fun v ->
let task =
Irmin.Task.create
~date:(Time.to_seconds time)
~owner:"tezos" in
GitStore.clone task v.store (Block_hash.to_b58check genesis) >>= function
| `Empty_head -> Lwt.return (Error [Exn (Empty_head genesis)])
| `Duplicated_branch -> Lwt.return (Error [Exn (Preexistent_context genesis)])
let commit_test_network_genesis forked_block time ctxt =
let net_id, genesis = compute_testnet_genesis forked_block in
let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in
GitStore.clone task ctxt.store (Block_hash.to_b58check genesis) >>= function
| `Empty_head -> fail (Exn (Empty_head genesis))
| `Duplicated_branch -> fail (Exn (Preexistent_context genesis))
| `Ok store ->
let msg =
Format.asprintf "Fake block. Forking testnet: %a."
Block_hash.pp_short genesis in
GitStore.FunView.update_path (store msg) [] v.view >>= fun () ->
return v
Format.asprintf "Forking testnet: %a." Net_id.pp_short net_id in
GitStore.FunView.update_path (store msg) [] ctxt.view >>= fun () ->
return (net_id, genesis)
let reset_test_network ctxt forked_block timestamp =
get_test_network ctxt >>= function
| Not_running -> Lwt.return ctxt
| Running { expiration } ->
if Time.(expiration <= timestamp) then
set_test_network ctxt Not_running
else
Lwt.return ctxt
| Forking { protocol ; expiration } ->
let net_id, genesis = compute_testnet_genesis forked_block in
set_test_network ctxt
(Running { net_id ; genesis ;
protocol ; expiration })

50
src/node/db/context.mli
View File

@ -27,9 +27,12 @@ val commit_genesis:
id:Block_hash.t ->
time:Time.t ->
protocol:Protocol_hash.t ->
test_protocol:Protocol_hash.t ->
context Lwt.t
val commit_test_network_genesis:
Block_hash.t -> Time.t -> context ->
(Net_id.t * Block_hash.t) tzresult Lwt.t
(** {2 Generic interface} ****************************************************)
include Persist.STORE with type t := context
@ -40,34 +43,37 @@ exception Preexistent_context of Block_hash.t
val exists: index -> Block_hash.t -> bool Lwt.t
val checkout: index -> Block_hash.t -> context option Lwt.t
val checkout_exn: index -> Block_hash.t -> context Lwt.t
val commit: Block_hash.t -> context -> unit Lwt.t
val commit:
Block_hash.t ->
time:Time.t ->
message:string ->
context -> unit Lwt.t
(** {2 Predefined Fields} ****************************************************)
val get_protocol: context -> Protocol_hash.t Lwt.t
val set_protocol: context -> Protocol_hash.t -> context Lwt.t
val get_test_protocol: context -> Protocol_hash.t Lwt.t
val set_test_protocol: context -> Protocol_hash.t -> context Lwt.t
type test_network =
| Not_running
| Forking of {
protocol: Protocol_hash.t ;
expiration: Time.t ;
}
| Running of {
net_id: Net_id.t ;
genesis: Block_hash.t ;
protocol: Protocol_hash.t ;
expiration: Time.t ;
}
val get_test_network: context -> Net_id.t option Lwt.t
val set_test_network: context -> Net_id.t -> context Lwt.t
val test_network_encoding: test_network Data_encoding.t
val get_test_network: context -> test_network Lwt.t
val set_test_network: context -> test_network -> context Lwt.t
val del_test_network: context -> context Lwt.t
val get_test_network_expiration: context -> Time.t option Lwt.t
val set_test_network_expiration: context -> Time.t -> context Lwt.t
val del_test_network_expiration: context -> context Lwt.t
val reset_test_network: context -> Block_hash.t -> Time.t -> context Lwt.t
val read_and_reset_fork_test_network: context -> (bool * context) Lwt.t
val fork_test_network: context -> context Lwt.t
val set_fitness: context -> Fitness.fitness -> context Lwt.t
val get_fitness: context -> Fitness.fitness Lwt.t
val set_timestamp: context -> Time.t -> context Lwt.t
val get_timestamp: context -> Time.t Lwt.t
val set_commit_message: context -> string -> context Lwt.t
val init_test_network:
context -> time:Time.t -> genesis:Block_hash.t -> context tzresult Lwt.t
val fork_test_network:
context -> protocol:Protocol_hash.t -> expiration:Time.t -> context Lwt.t

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

@ -61,14 +61,8 @@ module Net = struct
(struct let name = ["expiration"] end)
(Store_helpers.Make_value(Time))
module Forked_network_ttl =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct let name = ["forked_network_ttl"] end)
(Store_helpers.Make_value(struct
type t = Int64.t
let encoding = Data_encoding.int64
end))
module Allow_forked_network =
Indexed_store.Make_set (struct let name = ["allow_forked_network"] end)
end
@ -258,24 +252,30 @@ 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 ;
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
}
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_hash ; fitness } ->
(net_id, level, predecessor,
timestamp, operations_hash, fitness))
(fun (net_id, level, predecessor,
timestamp, operations_hash, fitness) ->
{ net_id ; level ; predecessor ;
timestamp ; operations_hash ; 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)
(req "operations_hash" Operation_list_list_hash.encoding)
(req "fitness" Fitness.encoding))
module Encoding = struct
@ -307,7 +307,7 @@ module Block_header = struct
Block_hash.compare b1.shell.predecessor b2.shell.predecessor >> fun () ->
compare b1.proto b2.proto >> fun () ->
Operation_list_list_hash.compare
b1.shell.operations b2.shell.operations >> fun () ->
b1.shell.operations_hash b2.shell.operations_hash >> fun () ->
Time.compare b1.shell.timestamp b2.shell.timestamp >> fun () ->
list compare b1.shell.fitness b2.shell.fitness

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

@ -46,9 +46,9 @@ module Net : sig
with type t := store
and type value := Time.t
module Forked_network_ttl : SINGLE_STORE
with type t := store
and type value := Int64.t
module Allow_forked_network : SET_STORE
with type t := t
and type elt := Net_id.t
end
@ -171,9 +171,10 @@ 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 ;
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
}
val shell_header_encoding: shell_header Data_encoding.t

4
src/node/main/node_run_command.ml
View File

@ -27,8 +27,6 @@ let context_dir data_dir = data_dir // "context"
let protocol_dir data_dir = data_dir // "protocol"
let lock_file data_dir = data_dir // "lock"
let test_protocol = None
let init_logger ?verbosity (log_config : Node_config_file.log) =
let open Logging in
begin
@ -116,11 +114,11 @@ let init_node ?sandbox (config : Node_config_file.t) =
end >>=? fun p2p_config ->
let node_config : Node.config = {
genesis ;
test_protocol ;
patch_context ;
store_root = store_dir config.data_dir ;
context_root = context_dir config.data_dir ;
p2p = p2p_config ;
test_network_max_tll = Some (48 * 3600) ; (* 2 days *)
} in
Node.create node_config

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

@ -348,7 +348,7 @@ module P2p_reader = struct
| None -> Lwt.return_unit
| Some bh ->
if Operation_list_list_hash.compare
found_hash bh.shell.operations <> 0 then
found_hash bh.shell.operations_hash <> 0 then
Lwt.return_unit
else
Raw_operation_list.Table.notify
@ -624,7 +624,7 @@ let inject_block t bytes operations =
(List.map Operation_list_hash.compute operations) in
fail_unless
(Operation_list_list_hash.compare
computed_hash block.shell.operations = 0)
computed_hash block.shell.operations_hash = 0)
(Exn (Failure "Incoherent operation list")) >>=? fun () ->
Raw_block_header.Table.inject
net_db.block_header_db.table hash block >>= function

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

@ -87,29 +87,28 @@ type config = {
genesis: State.Net.genesis ;
store_root: string ;
context_root: string ;
test_protocol: Protocol_hash.t option ;
patch_context: (Context.t -> Context.t Lwt.t) option ;
p2p: (P2p.config * P2p.limits) option ;
test_network_max_tll: int option ;
}
let may_create_net state ?test_protocol genesis =
let may_create_net state genesis =
State.Net.get state (Net_id.of_block_hash genesis.State.Net.block) >>= function
| Ok net -> Lwt.return net
| Error _ ->
State.Net.create state
?test_protocol
~forked_network_ttl:(48 * 3600) (* 2 days *)
genesis
State.Net.create state genesis
let create { genesis ; store_root ; context_root ;
test_protocol ; patch_context ; p2p = net_params } =
patch_context ; p2p = net_params ;
test_network_max_tll = max_ttl } =
init_p2p net_params >>= fun p2p ->
State.read
~store_root ~context_root ?patch_context () >>=? fun state ->
let distributed_db = Distributed_db.create state p2p in
let validator = Validator.create_worker state distributed_db in
may_create_net state ?test_protocol genesis >>= fun mainnet_net ->
let validator =
Validator.create_worker ?max_ttl state distributed_db in
may_create_net state genesis >>= fun mainnet_net ->
Validator.activate validator mainnet_net >>= fun mainnet_validator ->
let mainnet_db = Validator.net_db mainnet_validator in
let shutdown () =
@ -138,46 +137,32 @@ module RPC = struct
type block = Node_rpc_services.Blocks.block
type block_info = Node_rpc_services.Blocks.block_info = {
hash: Block_hash.t ;
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
protocol: Protocol_hash.t option ;
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
data: MBytes.t ;
operations: Operation_hash.t list list option ;
data: MBytes.t option ;
net: Net_id.t ;
test_protocol: Protocol_hash.t option ;
test_network: (Net_id.t * Time.t) option ;
protocol: Protocol_hash.t ;
test_network: Context.test_network;
}
let convert (block: State.Valid_block.t) = {
let convert (block: State.Valid_block.t) = {
hash = block.hash ;
predecessor = block.pred ;
fitness = block.fitness ;
net_id = block.net_id ;
level = block.level ;
predecessor = block.predecessor ;
timestamp = block.timestamp ;
protocol = Some block.protocol_hash ;
operations_hash = block.operations_hash ;
fitness = block.fitness ;
data = block.proto_header ;
operations = Some block.operations ;
data = Some block.proto_header ;
net = block.net_id ;
test_protocol = Some block.test_protocol_hash ;
protocol = block.protocol_hash ;
test_network = block.test_network ;
}
let convert_block hash ({ shell ; proto }: State.Block_header.t) = {
net = shell.net_id ;
hash = hash ;
predecessor = shell.predecessor ;
fitness = shell.fitness ;
timestamp = shell.timestamp ;
protocol = None ;
operations_hash = shell.operations ;
operations = None ;
data = Some proto ;
test_protocol = None ;
test_network = None ;
}
let inject_block node = node.inject_block
let inject_operation node = node.inject_operation
let inject_protocol node = node.inject_protocol
@ -278,42 +263,62 @@ module RPC = struct
State.Valid_block.Current.head net_state >>= fun head ->
Prevalidator.context pv >>= function
| Error _ -> Lwt.fail Not_found
| Ok ctxt ->
Context.get_fitness ctxt >>= fun fitness ->
Context.get_protocol ctxt >>= fun protocol ->
| Ok { context ; fitness } ->
Context.get_protocol context >>= fun protocol ->
Context.get_test_network context >>= fun test_network ->
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 ;
protocol = Some protocol ;
fitness ; operations ; timestamp }
{ hash = prevalidation_hash ;
level = Int32.succ head.level ;
predecessor = head.hash ;
fitness ;
timestamp = Prevalidator.timestamp pv ;
protocol ;
operations_hash =
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute operations) ;
operations = Some operations ;
data = MBytes.of_string "" ;
net_id = head.net_id ;
test_network ;
}
let get_context node block =
let rpc_context block : Updater.rpc_context =
{ context = block.State.Valid_block.context ;
level = Int32.succ block.level ;
fitness = block.fitness ;
timestamp = block. timestamp }
let get_rpc_context node block =
match block with
| `Genesis ->
State.Valid_block.Current.genesis node.mainnet_net >>= fun block ->
Lwt.return (Some block.context)
Lwt.return (Some (rpc_context block))
| ( `Head n | `Test_head n ) as block ->
let validator = get_validator node block in
let net_state = Validator.net_state validator in
let net_db = Validator.net_db validator in
State.Valid_block.Current.head net_state >>= fun head ->
get_pred net_db n head >>= fun { context } ->
Lwt.return (Some context)
get_pred net_db n head >>= fun block ->
Lwt.return (Some (rpc_context block))
| `Hash hash-> begin
read_valid_block node hash >|= function
| None -> None
| Some { context } -> Some context
| 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 ctxt -> Lwt.return (Some ctxt)
| Ok { context ; fitness } ->
let timestamp = Prevalidator.timestamp pv in
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
@ -417,8 +422,7 @@ module RPC = struct
~predecessor ~timestamp >>=? fun validation_state ->
Prevalidation.prevalidate
validation_state ~sort rops >>=? fun (validation_state, r) ->
Prevalidation.end_prevalidation validation_state >>=? fun ctxt ->
Context.get_fitness ctxt >>= fun fitness ->
Prevalidation.end_prevalidation validation_state >>=? fun { fitness } ->
return (fitness, { r with applied = List.rev r.applied })
let complete node ?block str =
@ -426,9 +430,9 @@ module RPC = struct
| None ->
Base58.complete str
| Some block ->
get_context node block >>= function
get_rpc_context node block >>= function
| None -> Lwt.fail Not_found
| Some ctxt ->
| Some { context = ctxt } ->
Context.get_protocol ctxt >>= fun protocol_hash ->
let (module Proto) = Updater.get_exn protocol_hash in
Base58.complete str >>= fun l1 ->
@ -436,12 +440,12 @@ module RPC = struct
Lwt.return (l1 @ l2)
let context_dir node block =
get_context node block >>= function
get_rpc_context node block >>= function
| None -> Lwt.return None
| Some ctxt ->
Context.get_protocol ctxt >>= fun protocol_hash ->
| Some rpc_context ->
Context.get_protocol rpc_context.context >>= fun protocol_hash ->
let (module Proto) = Updater.get_exn protocol_hash in
let dir = RPC.map (fun () -> ctxt) Proto.rpc_services in
let dir = RPC.map (fun () -> rpc_context) Proto.rpc_services in
Lwt.return (Some (RPC.map (fun _ -> ()) dir))
let heads node =
@ -512,12 +516,7 @@ module RPC = struct
heads >>= fun (_, blocks) ->
Lwt.return (List.rev blocks)
let block_watcher node =
let stream, shutdown = Distributed_db.watch_block node.distributed_db in
Lwt_stream.map
(fun (hash, block) -> convert_block hash block)
stream,
shutdown
let block_watcher node = Distributed_db.watch_block node.distributed_db
let valid_block_watcher node =
let stream, shutdown = Validator.global_watcher node.validator in

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

@ -13,9 +13,9 @@ type config = {
genesis: State.Net.genesis ;
store_root: string ;
context_root: string ;
test_protocol: Protocol_hash.t option ;
patch_context: (Context.t -> Context.t Lwt.t) option ;
p2p: (P2p.config * P2p.limits) option ;
test_network_max_tll: int option ;
}
val create: config -> t tzresult Lwt.t
@ -44,7 +44,7 @@ module RPC : sig
val raw_block_info:
t -> Block_hash.t -> block_info Lwt.t
val block_watcher:
t -> block_info Lwt_stream.t * Watcher.stopper
t -> (Block_hash.t * Store.Block_header.t) Lwt_stream.t * Watcher.stopper
val valid_block_watcher:
t -> (block_info Lwt_stream.t * Watcher.stopper)
val heads: t -> block_info Block_hash.Map.t Lwt.t

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

@ -12,9 +12,8 @@ open Logging.RPC
module Services = Node_rpc_services
let filter_bi (operations, data) (bi: Services.Blocks.block_info) =
let filter_bi operations (bi: Services.Blocks.block_info) =
let bi = if operations then bi else { bi with operations = None } in
let bi = if data then bi else { bi with data = None } in
bi
let register_bi_dir node dir =
@ -34,9 +33,15 @@ let register_bi_dir node dir =
let dir =
let implementation b () =
Node.RPC.block_info node b >>= fun bi ->
RPC.Answer.return bi.net in
RPC.Answer.return bi.net_id 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 ->
@ -65,17 +70,9 @@ let register_bi_dir node dir =
let dir =
let implementation b () =
Node.RPC.block_info node b >>= fun bi ->
match bi.protocol with
| None -> raise Not_found
| Some p -> RPC.Answer.return p in
RPC.Answer.return bi.protocol in
RPC.register1 dir
Services.Blocks.protocol implementation in
let dir =
let implementation b () =
Node.RPC.block_info node b >>= fun bi ->
RPC.Answer.return bi.test_protocol in
RPC.register1 dir
Services.Blocks.test_protocol implementation in
let dir =
let implementation b () =
Node.RPC.block_info node b >>= fun bi ->
@ -214,11 +211,10 @@ let create_delayed_stream
let list_blocks
node
{ Services.Blocks.operations ; data ; length ; heads ; monitor ; delay ;
{ Services.Blocks.include_ops ; length ; heads ; monitor ; delay ;
min_date; min_heads} =
let len = match length with None -> 1 | Some x -> x in
let monitor = match monitor with None -> false | Some x -> x in
let include_ops = (operations, data) in
let time =
match delay with
| None -> None
@ -404,14 +400,17 @@ 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_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 net_id 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 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_hash } ;
proto = header ;
} in
RPC.Answer.return res in

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

@ -57,46 +57,45 @@ module Blocks = struct
type block_info = {
hash: Block_hash.t ;
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
protocol: Protocol_hash.t option ;
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
data: MBytes.t ;
operations: Operation_hash.t list list option ;
data: MBytes.t option ;
net: Net_id.t ;
test_protocol: Protocol_hash.t option ;
test_network: (Net_id.t * Time.t) option ;
protocol: Protocol_hash.t ;
test_network: Context.test_network;
}
let block_info_encoding =
conv
(fun { hash ; predecessor ; fitness ; timestamp ; protocol ;
operations_hash ; operations ; data ; net ;
test_protocol ; test_network } ->
((hash, predecessor, fitness, timestamp, protocol),
(operations_hash, operations, data,
net, test_protocol, test_network)))
(fun ((hash, predecessor, fitness, timestamp, protocol),
(operations_hash, operations, data,
net, test_protocol, test_network)) ->
{ hash ; predecessor ; fitness ; timestamp ; protocol ;
operations_hash ; operations ; data ; net ;
test_protocol ; test_network })
(merge_objs
(obj5
(req "hash" Block_hash.encoding)
(req "predecessor" Block_hash.encoding)
(req "fitness" Fitness.encoding)
(req "timestamp" Time.encoding)
(opt "protocol" Protocol_hash.encoding))
(obj6
(req "operations_hash" Operation_list_list_hash.encoding)
(opt "operations" (list (list Operation_hash.encoding)))
(opt "data" bytes)
(req "net" Net_id.encoding)
(opt "test_protocol" Protocol_hash.encoding)
(opt "test_network" (tup2 Net_id.encoding Time.encoding))))
(fun { hash ; net_id ; level ; predecessor ;
fitness ; timestamp ; protocol ; operations_hash ; data ;
operations ; test_network } ->
({ Store.Block_header.shell =
{ net_id ; level ; predecessor ;
timestamp ; operations_hash ; fitness } ;
proto = data },
(hash, operations, protocol, test_network)))
(fun ({ Store.Block_header.shell =
{ net_id ; level ; predecessor ;
timestamp ; operations_hash ; fitness } ;
proto = data },
(hash, operations, protocol, test_network)) ->
{ hash ; net_id ; level ; predecessor ;
fitness ; timestamp ; protocol ; operations_hash ; data ;
operations ; test_network })
(dynamic_size
(merge_objs
Store.Block_header.encoding
(obj4
(req "hash" Block_hash.encoding)
(opt "operations" (list (list Operation_hash.encoding)))
(req "protocol" Protocol_hash.encoding)
(dft "test_network"
Context.test_network_encoding Context.Not_running))))
let parse_block s =
try
@ -179,10 +178,7 @@ module Blocks = struct
let info =
RPC.service
~description:"All the information about a block."
~input:
(obj2
(dft "operations" bool true)
(dft "data" bool true))
~input: (obj1 (dft "operations" bool true))
~output: block_info_encoding
block_path
@ -193,6 +189,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."
@ -244,18 +247,11 @@ module Blocks = struct
~output: (obj1 (req "protocol" Protocol_hash.encoding))
RPC.Path.(block_path / "protocol")
let test_protocol =
RPC.service
~description:"List the block test protocol."
~input: empty
~output: (obj1 (opt "protocol" Protocol_hash.encoding))
RPC.Path.(block_path / "test_protocol")
let test_network =
RPC.service
~description:"Returns the associated test network."
~description:"Returns the status of the associated test network."
~input: empty
~output: (obj1 (opt "net" (tup2 Net_id.encoding Time.encoding)))
~output: Context.test_network_encoding
RPC.Path.(block_path / "test_network")
let pending_operations =
@ -320,8 +316,7 @@ module Blocks = struct
RPC.Path.(block_path / "complete" /: prefix_arg )
type list_param = {
operations: bool ;
data: bool ;
include_ops: bool ;
length: int option ;
heads: Block_hash.t list option ;
monitor: bool option ;
@ -331,25 +326,20 @@ module Blocks = struct
}
let list_param_encoding =
conv
(fun { operations ; data ; length ; heads ; monitor ;
(fun { include_ops ; length ; heads ; monitor ;
delay ; min_date ; min_heads } ->
(operations, data, length, heads, monitor, delay, min_date, min_heads))
(fun (operations, data, length, heads, monitor, delay, min_date, min_heads) ->
{ operations ; data ; length ; heads ; monitor ;
(include_ops, length, heads, monitor, delay, min_date, min_heads))
(fun (include_ops, length, heads, monitor,
delay, min_date, min_heads) ->
{ include_ops ; length ; heads ; monitor ;
delay ; min_date ; min_heads })
(obj8
(dft "operations"
(obj7
(dft "include_ops"
(Data_encoding.describe
~description:
"Whether the resulting block informations should include the \
list of operations' hashes. Default false."
bool) false)
(dft "data"
(Data_encoding.describe
~description:
"Whether the resulting block informations should include the \
raw protocol dependent data. Default false."
bool) false)
(opt "length"
(Data_encoding.describe
~description:
@ -642,8 +632,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)

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

@ -28,22 +28,24 @@ module Blocks : sig
type block_info = {
hash: Block_hash.t ;
net_id: Net_id.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
fitness: MBytes.t list ;
timestamp: Time.t ;
protocol: Protocol_hash.t option ;
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
data: MBytes.t ;
operations: Operation_hash.t list list option ;
data: MBytes.t option ;
net: Net_id.t ;
test_protocol: Protocol_hash.t option ;
test_network: (Net_id.t * Time.t) option ;
protocol: Protocol_hash.t ;
test_network: Context.test_network;
}
val info:
(unit, unit * block, bool * bool, block_info) RPC.service
(unit, unit * block, 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:
@ -58,17 +60,14 @@ module Blocks : sig
(unit, unit * block, unit, Operation_hash.t list list) RPC.service
val protocol:
(unit, unit * block, unit, Protocol_hash.t) RPC.service
val test_protocol:
(unit, unit * block, unit, Protocol_hash.t option) RPC.service
val test_network:
(unit, unit * block, unit, (Net_id.t * Time.t) option) RPC.service
(unit, unit * block, unit, Context.test_network) RPC.service
val pending_operations:
(unit, unit * block, unit,
error Prevalidation.preapply_result * Hash.Operation_hash.Set.t) RPC.service
type list_param = {
operations: bool ;
data: bool ;
include_ops: bool ;
length: int option ;
heads: Block_hash.t list option ;
monitor: bool option ;
@ -179,7 +178,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

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

@ -135,17 +135,25 @@ let start_prevalidation
{ State.Valid_block.protocol ;
hash = predecessor ;
context = predecessor_context ;
timestamp = predecessor_timestamp }
timestamp = predecessor_timestamp ;
fitness = predecessor_fitness ;
level = predecessor_level }
~timestamp =
let (module Proto) =
match protocol with
| None -> assert false (* FIXME, this should not happen! *)
| Some protocol -> protocol in
Context.reset_test_network
predecessor_context predecessor
timestamp >>= fun predecessor_context ->
Proto.begin_construction
~predecessor_context
~predecessor_timestamp
~predecessor_fitness
~predecessor_level
~predecessor
~timestamp >>=? fun state ->
~timestamp
>>=? fun state ->
return (State { proto = (module Proto) ; state })
let prevalidate

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

@ -39,4 +39,4 @@ val prevalidate :
(prevalidation_state * error preapply_result) tzresult Lwt.t
val end_prevalidation :
prevalidation_state -> Context.t tzresult Lwt.t
prevalidation_state -> Updater.validation_result tzresult Lwt.t

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

@ -54,7 +54,7 @@ type t = {
operations: unit -> error preapply_result * Operation_hash.Set.t ;
pending: ?block:State.Valid_block.t -> unit -> Operation_hash.Set.t Lwt.t ;
timestamp: unit -> Time.t ;
context: unit -> Context.t tzresult Lwt.t ;
context: unit -> Updater.validation_result tzresult Lwt.t ;
shutdown: unit -> unit Lwt.t ;
}

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

@ -44,6 +44,6 @@ val inject_operation:
val flush: t -> State.Valid_block.t -> unit
val timestamp: t -> Time.t
val operations: t -> error Prevalidation.preapply_result * Operation_hash.Set.t
val context: t -> Context.t tzresult Lwt.t
val context: t -> Updater.validation_result tzresult Lwt.t
val pending: ?block:State.Valid_block.t -> t -> Operation_hash.Set.t Lwt.t

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

@ -89,7 +89,7 @@ and net = {
state: net_state Shared.t ;
genesis: genesis ;
expiration: Time.t option ;
forked_network_ttl: Int64.t option ;
allow_forked_network: bool ;
operation_store: Store.Operation.store Shared.t ;
block_header_store: Store.Block_header.store Shared.t ;
valid_block_watcher: valid_block Watcher.input ;
@ -110,7 +110,8 @@ and net_state = {
and valid_block = {
net_id: Net_id.t ;
hash: Block_hash.t ;
pred: Block_hash.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
fitness: Protocol.fitness ;
operations_hash: Operation_list_list_hash.t ;
@ -118,9 +119,7 @@ and valid_block = {
discovery_time: Time.t ;
protocol_hash: Protocol_hash.t ;
protocol: (module Updater.REGISTRED_PROTOCOL) option ;
test_protocol_hash: Protocol_hash.t ;
test_protocol: (module Updater.REGISTRED_PROTOCOL) option ;
test_network: (Net_id.t * Time.t) option ;
test_network: Context.test_network ;
context: Context.t ;
successors: Block_hash.Set.t ;
invalid_successors: Block_hash.Set.t ;
@ -131,29 +130,20 @@ let build_valid_block
hash header operations
context discovery_time successors invalid_successors =
Context.get_protocol context >>= fun protocol_hash ->
Context.get_test_protocol context >>= fun test_protocol_hash ->
Context.get_test_network context >>= fun test_network ->
Context.get_test_network_expiration
context >>= fun test_network_expiration ->
let test_network =
match test_network, test_network_expiration with
| None, _ | _, None -> None
| Some net_id, Some time -> Some (net_id, time) in
let protocol = Updater.get protocol_hash in
let test_protocol = Updater.get test_protocol_hash in
let valid_block = {
net_id = header.Store.Block_header.shell.net_id ;
hash ;
pred = header.shell.predecessor ;
level = header.shell.level ;
predecessor = header.shell.predecessor ;
timestamp = header.shell.timestamp ;
discovery_time ;
operations_hash = header.shell.operations ;
operations_hash = header.shell.operations_hash ;
operations ;
fitness = header.shell.fitness ;
protocol_hash ;
protocol ;
test_protocol_hash ;
test_protocol ;
test_network ;
context ;
successors ;
@ -540,10 +530,11 @@ 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 = [] ;
operations = Operation_list_list_hash.empty ;
operations_hash = Operation_list_list_hash.empty ;
} in
let header =
{ Store.Block_header.shell ; proto = MBytes.create 0 } in
@ -553,22 +544,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,9 +685,10 @@ 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 ;
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
}
@ -852,7 +845,7 @@ module Raw_net = struct
~genesis
~genesis_block
~expiration
~forked_network_ttl
~allow_forked_network
context_index
chain_store
block_header_store
@ -867,18 +860,16 @@ module Raw_net = struct
state = Shared.create net_state ;
genesis ;
expiration ;
allow_forked_network ;
operation_store = Shared.create operation_store ;
forked_network_ttl ;
block_header_store = Shared.create block_header_store ;
valid_block_watcher = Watcher.create_input ();
} in
net
let locked_create
data
?initial_context ?forked_network_ttl
?test_protocol ?expiration genesis =
let net_id = Net_id.of_block_hash genesis.block in
data ?initial_context ?expiration ?(allow_forked_network = false)
net_id genesis =
let net_store = Store.Net.get data.global_store net_id in
let operation_store = Store.Operation.get net_store
and block_header_store = Store.Block_header.get net_store
@ -886,8 +877,6 @@ module Raw_net = struct
Store.Net.Genesis_hash.store net_store genesis.block >>= fun () ->
Store.Net.Genesis_time.store net_store genesis.time >>= fun () ->
Store.Net.Genesis_protocol.store net_store genesis.protocol >>= fun () ->
let test_protocol = Utils.unopt ~default:genesis.protocol test_protocol in
Store.Net.Genesis_test_protocol.store net_store test_protocol >>= fun () ->
Store.Chain.Current_head.store chain_store genesis.block >>= fun () ->
Store.Chain.Known_heads.store chain_store genesis.block >>= fun () ->
data.init_index net_id >>= fun context_index ->
@ -896,6 +885,12 @@ module Raw_net = struct
| None -> Lwt.return_unit
| Some time -> Store.Net.Expiration.store net_store time
end >>= fun () ->
begin
if allow_forked_network then
Store.Net.Allow_forked_network.store data.global_store net_id
else
Lwt.return_unit
end >>= fun () ->
Raw_block_header.store_genesis
block_header_store genesis >>= fun header ->
begin
@ -906,7 +901,6 @@ module Raw_net = struct
~id:genesis.block
~time:genesis.time
~protocol:genesis.protocol
~test_protocol
| Some context ->
Lwt.return context
end >>= fun context ->
@ -918,7 +912,7 @@ module Raw_net = struct
~genesis
~genesis_block
~expiration
~forked_network_ttl
~allow_forked_network
context_index
chain_store
block_header_store
@ -932,7 +926,8 @@ module Valid_block = struct
type t = valid_block = {
net_id: Net_id.t ;
hash: Block_hash.t ;
pred: Block_hash.t ;
level: Int32.t ;
predecessor: Block_hash.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
operations_hash: Operation_list_list_hash.t ;
@ -940,9 +935,7 @@ module Valid_block = struct
discovery_time: Time.t ;
protocol_hash: Protocol_hash.t ;
protocol: (module Updater.REGISTRED_PROTOCOL) option ;
test_protocol_hash: Protocol_hash.t ;
test_protocol: (module Updater.REGISTRED_PROTOCOL) option ;
test_network: (Net_id.t * Time.t) option ;
test_network: Context.test_network ;
context: Context.t ;
successors: Block_hash.Set.t ;
invalid_successors: Block_hash.Set.t ;
@ -996,14 +989,13 @@ module Valid_block = struct
block_header_store
(net_state: net_state)
valid_block_watcher
hash context ttl =
hash { Updater.context ; message ; fitness } =
(* Read the block header. *)
Raw_block_header.Locked.read
block_header_store hash >>=? fun block ->
Raw_block_header.Locked.read_discovery_time
block_header_store hash >>=? fun discovery_time ->
(* Check fitness coherency. *)
Context.get_fitness context >>= fun fitness ->
fail_unless
(Fitness.equal fitness block.Store.Block_header.shell.fitness)
(Invalid_fitness
@ -1011,37 +1003,21 @@ module Valid_block = struct
expected = block.Store.Block_header.shell.fitness ;
found = fitness ;
}) >>=? fun () ->
begin (* Patch context about the associated test network. *)
Context.read_and_reset_fork_test_network
context >>= fun (fork, context) ->
if fork then
match ttl with
| None ->
(* Ignore fork on forked networks. *)
Context.del_test_network context >>= fun context ->
Context.del_test_network_expiration context
| Some ttl ->
let eol = Time.(add block.shell.timestamp ttl) in
Context.set_test_network
context (Net_id.of_block_hash hash) >>= fun context ->
Context.set_test_network_expiration
context eol >>= fun context ->
Lwt.return context
else
Context.get_test_network_expiration context >>= function
| Some eol when Time.(eol <= now ()) ->
Context.del_test_network context >>= fun context ->
Context.del_test_network_expiration context
| None | Some _ ->
Lwt.return context
end >>= fun context ->
Raw_block_header.Locked.mark_valid
block_header_store hash >>= fun _marked ->
(* TODO fail if the block was previsouly stored ... ??? *)
Operation_list.Locked.read_all
block_header_store hash >>=? fun operations ->
(* Let's commit the context. *)
Context.commit hash context >>= fun () ->
let message =
match message with
| Some message -> message
| None ->
Format.asprintf "%a(%ld): %a"
Block_hash.pp_short hash
block.shell.level
Fitness.pp fitness in
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
@ -1076,7 +1052,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
@ -1088,7 +1064,7 @@ 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 >>=? fun valid_block ->
return (Some valid_block)
end
end
@ -1096,26 +1072,22 @@ module Valid_block = struct
let watcher net =
Watcher.create_stream net.valid_block_watcher
let fork_testnet state net block expiration =
let fork_testnet state net block protocol expiration =
assert (Net_id.equal block.net_id (Net_id.of_block_hash net.genesis.block)) ;
let hash = Block_hash.hash_bytes [Block_hash.to_bytes block.hash] in
let genesis : genesis = {
block = hash ;
time = Time.add block.timestamp 1L ;
protocol = block.test_protocol_hash ;
} in
Shared.use state.global_data begin fun data ->
if Net_id.Table.mem data.nets (Net_id.of_block_hash hash) then
assert false (* This would mean a block is validated twice... *)
else
Context.init_test_network block.context
~time:genesis.time
~genesis:genesis.block >>=? fun initial_context ->
Raw_net.locked_create data
~initial_context
~expiration
genesis >>= fun net ->
return net
let context = block.context in
Context.set_test_network context Not_running >>= fun context ->
Context.set_protocol context protocol >>= fun context ->
Context.commit_test_network_genesis
block.hash block.timestamp context >>=? fun (net_id, genesis) ->
let genesis = {
block = genesis ;
time = Time.add block.timestamp 1L ;
protocol ;
} in
Raw_net.locked_create data
net_id ~initial_context:context ~expiration genesis >>= fun net ->
return net
end
module Helpers = struct
@ -1159,10 +1131,10 @@ module Valid_block = struct
end
| res -> res in
let predecessor state b =
if Block_hash.equal b.hash b.pred then
if Block_hash.equal b.hash b.predecessor then
Lwt.return None
else
read_opt state b.pred in
read_opt state b.predecessor in
Raw_helpers.iter_predecessors compare predecessor
(fun b -> b.timestamp) (fun b -> b.fitness)
@ -1320,15 +1292,14 @@ module Net = struct
(req "block" Block_hash.encoding)
(req "protocol" Protocol_hash.encoding))
let create state ?test_protocol ?forked_network_ttl genesis =
let create state ?allow_forked_network genesis =
let net_id = Net_id.of_block_hash genesis.block in
let forked_network_ttl = map_option Int64.of_int forked_network_ttl in
Shared.use state.global_data begin fun data ->
if Net_id.Table.mem data.nets net_id then
Pervasives.failwith "State.Net.create"
else
Raw_net.locked_create data
?test_protocol ?forked_network_ttl genesis >>= fun net ->
Raw_net.locked_create
data ?allow_forked_network net_id genesis >>= fun net ->
Net_id.Table.add data.nets net_id net ;
Lwt.return net
end
@ -1342,7 +1313,8 @@ module Net = struct
Store.Net.Genesis_time.read net_store >>=? fun time ->
Store.Net.Genesis_protocol.read net_store >>=? fun protocol ->
Store.Net.Expiration.read_opt net_store >>= fun expiration ->
Store.Net.Forked_network_ttl.read_opt net_store >>= fun forked_network_ttl ->
Store.Net.Allow_forked_network.known
data.global_store id >>= fun allow_forked_network ->
let genesis = { time ; protocol ; block = genesis_hash } in
Store.Chain.Current_head.read chain_store >>=? fun genesis_hash ->
data.init_index id >>= fun context_index ->
@ -1358,7 +1330,7 @@ module Net = struct
~genesis
~genesis_block
~expiration
~forked_network_ttl
~allow_forked_network
context_index
chain_store
block_header_store
@ -1393,7 +1365,7 @@ module Net = struct
let id { id } = id
let genesis { genesis } = genesis
let expiration { expiration } = expiration
let forked_network_ttl { forked_network_ttl } = forked_network_ttl
let allow_forked_network { allow_forked_network } = allow_forked_network
let destroy state net =
lwt_debug "destroy %a" Net_id.pp (id net) >>= fun () ->

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

@ -62,12 +62,12 @@ module Net : sig
}
val genesis_encoding: genesis Data_encoding.t
(** Initialize a network for a given [genesis]. By default the network
never expirate and the test_protocol is the genesis protocol. *)
(** Initialize a network for a given [genesis]. By default,
the network does accept forking test network. When
[~allow_forked_network:true] is provided, test network are allowed. *)
val create:
global_state ->
?test_protocol: Protocol_hash.t ->
?forked_network_ttl: int ->
?allow_forked_network:bool ->
genesis -> net Lwt.t
(** Look up for a network by the hash of its genesis block. *)
@ -88,7 +88,7 @@ module Net : sig
val id: net -> Net_id.t
val genesis: net -> genesis
val expiration: net -> Time.t option
val forked_network_ttl: net -> Int64.t option
val allow_forked_network: net -> bool
end
@ -144,9 +144,10 @@ 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 ;
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
}
@ -245,7 +246,9 @@ module Valid_block : sig
(** The genesis of the chain this block belongs to. *)
hash: Block_hash.t ;
(** The block hash. *)
pred: Block_hash.t ;
level: Int32.t ;
(** The number of preceding block in the chain. *)
predecessor: Block_hash.t ;
(** The preceding block in the chain. *)
timestamp: Time.t ;
(** The date at which this block has been forged. *)
@ -261,14 +264,8 @@ module Valid_block : sig
protocol: (module Updater.REGISTRED_PROTOCOL) option ;
(** The actual implementation of the protocol to be used for
validating the following blocks. *)
test_protocol_hash: Protocol_hash.t ;
(** The protocol to be used for the next test network. *)
test_protocol: (module Updater.REGISTRED_PROTOCOL) option ;
(** The actual implementatino of the protocol to be used for the
next test network. *)
test_network: (Net_id.t * Time.t) option ;
(** The current test network associated to the block, and the date
of its expiration date. *)
test_network: Context.test_network ;
(** The current test network associated to the block. *)
context: Context.t ;
(** The validation context that was produced by the block validation. *)
successors: Block_hash.Set.t ;
@ -284,7 +281,8 @@ module Valid_block : sig
val read_opt: Net.t -> Block_hash.t -> valid_block option Lwt.t
val read_exn: Net.t -> Block_hash.t -> valid_block Lwt.t
val store:
Net.t -> Block_hash.t -> Context.t -> valid_block option tzresult Lwt.t
Net.t -> Block_hash.t -> Updater.validation_result ->
valid_block option tzresult Lwt.t
val watcher: Net.t -> valid_block Lwt_stream.t * Watcher.stopper
@ -292,7 +290,10 @@ module Valid_block : sig
val known_heads: Net.t -> valid_block list Lwt.t
val fork_testnet:
global_state -> Net.t -> valid_block -> Time.t -> Net.t tzresult Lwt.t
global_state ->
Net.t -> valid_block ->
Protocol_hash.t -> Time.t ->
Net.t tzresult Lwt.t
module Current : sig

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

@ -33,7 +33,11 @@ and t = {
net_db: Distributed_db.net ;
notify_block: Block_hash.t -> Store.Block_header.t -> unit Lwt.t ;
fetch_block: Block_hash.t -> State.Valid_block.t tzresult Lwt.t ;
create_child: State.Valid_block.t -> unit tzresult Lwt.t ;
create_child:
State.Valid_block.t -> Protocol_hash.t -> Time.t -> unit tzresult Lwt.t ;
check_child:
Block_hash.t -> Protocol_hash.t -> Time.t -> Time.t -> unit tzresult Lwt.t ;
deactivate_child: unit -> unit Lwt.t ;
test_validator: unit -> (t * Distributed_db.net) option ;
shutdown: unit -> unit Lwt.t ;
valid_block_input: State.Valid_block.t Watcher.input ;
@ -59,29 +63,10 @@ let bootstrapped v = v.bootstrapped
(** Current block computation *)
let may_change_test_network v (block: State.Valid_block.t) =
let change =
match block.test_network, v.child with
| None, None -> false
| Some _, None
| None, Some _ -> true
| Some (net_id, _), Some { net } ->
let net_id' = State.Net.id net in
not (Net_id.equal net_id net_id') in
if change then begin
v.create_child block >>= function
| Ok () -> Lwt.return_unit
| Error err ->
lwt_log_error "@[<v 2>Error while switch test network:@ %a@]"
Error_monad.pp_print_error err
end else
Lwt.return_unit
let fetch_protocol v hash =
lwt_log_notice "Fetching protocol %a"
Protocol_hash.pp_short hash >>= fun () ->
Distributed_db.Protocol.fetch
v.worker.db hash >>= fun protocol ->
Distributed_db.Protocol.fetch v.worker.db hash >>= fun protocol ->
Updater.compile hash protocol >>= fun valid ->
if valid then begin
lwt_log_notice "Successfully compiled protocol %a"
@ -101,12 +86,16 @@ let fetch_protocols v (block: State.Valid_block.t) =
| Some _ -> return false
| None -> fetch_protocol v block.protocol_hash
and test_proto_updated =
match block.test_protocol with
| Some _ -> return false
| None -> fetch_protocol v block.test_protocol_hash in
match block.test_network with
| Not_running -> return false
| Forking { protocol }
| Running { protocol } ->
Distributed_db.Protocol.known v.worker.db protocol >>= fun known ->
if known then return false
else fetch_protocol v protocol in
proto_updated >>=? fun proto_updated ->
test_proto_updated >>=? fun test_proto_updated ->
if test_proto_updated || proto_updated then
test_proto_updated >>=? fun _test_proto_updated ->
if proto_updated then
State.Valid_block.read_exn v.net block.hash >>= return
else
return block
@ -122,14 +111,27 @@ let rec may_set_head v (block: State.Valid_block.t) =
| true ->
Distributed_db.broadcast_head v.net_db block.hash [] ;
Prevalidator.flush v.prevalidator block ;
may_change_test_network v block >>= fun () ->
begin
begin
match block.test_network with
| Not_running -> v.deactivate_child () >>= return
| Running { genesis ; protocol ; expiration } ->
v.check_child genesis protocol expiration block.timestamp
| Forking { protocol ; expiration } ->
v.create_child block protocol expiration
end >>= function
| Ok () -> Lwt.return_unit
| Error err ->
lwt_log_error "@[<v 2>Error while switch test network:@ %a@]"
Error_monad.pp_print_error err
end >>= fun () ->
Watcher.notify v.new_head_input block ;
lwt_log_notice "update current head %a %a %a(%t)"
Block_hash.pp_short block.hash
Fitness.pp block.fitness
Time.pp_hum block.timestamp
(fun ppf ->
if Block_hash.equal head.hash block.pred then
if Block_hash.equal head.hash block.predecessor then
Format.fprintf ppf "same branch"
else
Format.fprintf ppf "changing branch") >>= fun () ->
@ -142,6 +144,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,10 +169,13 @@ 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
db (hash, 0) block.shell.operations >>= fun operation_hashes ->
db (hash, 0) block.shell.operations_hash >>= fun operation_hashes ->
Lwt_list.map_p
(fun op -> Distributed_db.Operation.fetch db op)
operation_hashes >>= fun operations ->
@ -181,10 +202,8 @@ let apply_block net db
begin
match pred.protocol with
| None -> fail (State.Unknown_protocol pred.protocol_hash)
| Some p ->
Context.set_timestamp pred.context block.shell.timestamp >>= fun c ->
return (p, c)
end >>=? fun ((module Proto), patched_context) ->
| Some p -> return p
end >>=? fun (module Proto) ->
lwt_debug "validation of %a: Proto %a"
Block_hash.pp_short hash
Protocol_hash.pp_short Proto.hash >>= fun () ->
@ -200,9 +219,12 @@ let apply_block net db
operations >>=? fun parsed_operations ->
lwt_debug "validation of %a: applying block..."
Block_hash.pp_short hash >>= fun () ->
Context.reset_test_network
pred.context pred.hash block.shell.timestamp >>= fun context ->
Proto.begin_application
~predecessor_context:patched_context
~predecessor_context:context
~predecessor_timestamp:pred.timestamp
~predecessor_fitness:pred.fitness
block >>=? fun state ->
fold_left_s (fun state op ->
Proto.apply_operation state op >>=? fun state ->
@ -466,7 +488,7 @@ module Context_db = struct
end
let rec create_validator ?parent worker state db net =
let rec create_validator ?max_ttl ?parent worker state db net =
let queue = Lwt_pipe.create () in
let current_ops = ref (fun () -> []) in
@ -550,6 +572,8 @@ let rec create_validator ?parent worker state db net =
notify_block ;
fetch_block ;
create_child ;
check_child ;
deactivate_child ;
test_validator ;
bootstrapped ;
new_head_input ;
@ -567,36 +591,62 @@ let rec create_validator ?parent worker state db net =
and fetch_block hash =
Context_db.fetch session v hash
and create_child block =
begin
and create_child block protocol expiration =
if State.Net.allow_forked_network net then begin
deactivate_child () >>= fun () ->
begin
State.Net.get state net_id >>= function
| Ok net_store -> return net_store
| Error _ ->
State.Valid_block.fork_testnet
state net block protocol expiration >>=? fun net_store ->
State.Valid_block.Current.head net_store >>= fun block ->
Watcher.notify v.worker.valid_block_input block ;
return net_store
end >>=? fun net_store ->
worker.activate ~parent:v net_store >>= fun child ->
v.child <- Some child ;
return ()
end else begin
(* Ignoring request... *)
return ()
end
and deactivate_child () =
match v.child with
| None -> Lwt.return_unit
| Some child ->
v.child <- None ;
deactivate child
and check_child genesis protocol expiration current_time =
let activated =
match v.child with
| None -> Lwt.return_unit
| None -> false
| Some child ->
v.child <- None ;
deactivate child
end >>= fun () ->
match block.test_network with
| None -> return ()
| Some (net_id, expiration) ->
begin
State.Net.get state net_id >>= function
| Ok net_store -> return net_store
| Error _ ->
State.Valid_block.fork_testnet
state net block expiration >>=? fun net_store ->
State.Valid_block.Current.head net_store >>= fun block ->
Watcher.notify v.worker.valid_block_input block ;
return net_store
end >>=? fun net_store ->
worker.activate ~parent:v net_store >>= fun child ->
v.child <- Some child ;
return ()
Block_hash.equal (State.Net.genesis child.net).block genesis in
begin
match max_ttl with
| None -> Lwt.return expiration
| Some ttl ->
Distributed_db.Block_header.fetch net_db genesis >>= fun genesis ->
Lwt.return
(Time.min expiration
(Time.add genesis.shell.timestamp (Int64.of_int ttl)))
end >>= fun local_expiration ->
let expired = Time.(local_expiration <= current_time) in
if expired && activated then
deactivate_child () >>= return
else if not activated && not expired then
fetch_block genesis >>=? fun genesis ->
create_child genesis protocol expiration
else
return ()
and test_validator () =
match v.child with
| None -> None
| Some child -> Some (child, child.net_db)
in
new_blocks := begin
@ -619,7 +669,7 @@ let rec create_validator ?parent worker state db net =
type error += Unknown_network of Net_id.t
let create_worker state db =
let create_worker ?max_ttl state db =
let validators : t Lwt.t Net_id.Table.t =
Net_id.Table.create 7 in
@ -750,10 +800,9 @@ let create_worker state db =
let net_id = State.Net.id net in
lwt_log_notice "activate network %a"
Net_id.pp net_id >>= fun () ->
State.Valid_block.Current.genesis net >>= fun genesis ->
get net_id >>= function
| Error _ ->
let v = create_validator ?parent worker state db net in
let v = create_validator ?max_ttl ?parent worker state db net in
Net_id.Table.add validators net_id v ;
v
| Ok v -> Lwt.return v

2
src/node/shell/validator.mli
View File

@ -9,7 +9,7 @@
type worker
val create_worker: State.t -> Distributed_db.t -> worker
val create_worker: ?max_ttl:int -> State.t -> Distributed_db.t -> worker
val shutdown: worker -> unit Lwt.t
val notify_block: worker -> Block_hash.t -> State.Block_header.t -> unit Lwt.t

6
src/node/updater/environment.ml
View File

@ -82,7 +82,7 @@ module Ed25519 = struct
(conv
Sodium.Sign.Bigbytes.of_public_key
Sodium.Sign.Bigbytes.to_public_key
bytes)
(Fixed.bytes Sodium.Sign.public_key_size))
let hash v =
Public_key_hash.hash_bytes
@ -144,7 +144,7 @@ module Ed25519 = struct
(conv
Sodium.Sign.Bigbytes.of_secret_key
Sodium.Sign.Bigbytes.to_secret_key
bytes)
(Fixed.bytes Sodium.Sign.secret_key_size))
end
@ -199,7 +199,7 @@ module Ed25519 = struct
| None -> Data_encoding.Json.cannot_destruct
"Ed25519 signature: unexpected prefix.")
string)
~binary: (Fixed.bytes 64)
~binary: (Fixed.bytes Sodium.Sign.signature_size)
let check public_key signature msg =
try

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

@ -9,11 +9,10 @@
(** Tezos Protocol Environment - Protocol Implementation Signature *)
(** The score of a block as a sequence of as unsigned bytes. Ordered
by length and then by contents lexicographically. *)
(* See `src/proto/updater.mli` for documentation. *)
type fitness = Fitness.fitness
(** The version agnostic toplevel structure of operations. *)
type shell_operation = Store.Operation.shell_header = {
net_id: Net_id.t ;
}
@ -23,20 +22,13 @@ type raw_operation = Store.Operation.t = {
proto: MBytes.t ;
}
(** The version agnostic toplevel structure of blocks. *)
type shell_block = Store.Block_header.shell_header =
{ net_id: Net_id.t ;
(** The genesis of the chain this block belongs to. *)
level: Int32.t ;
predecessor: Block_hash.t ;
(** The preceding block in the chain. *)
timestamp: Time.t ;
(** The date at which this block has been forged. *)
operations: Operation_list_list_hash.t ;
(** The sequence of operations. *)
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
(** The announced score of the block. As a sequence of sequences
of unsigned bytes. Ordered by length and then by contents
lexicographically. *)
}
type raw_block = Store.Block_header.t = {
@ -44,96 +36,61 @@ type raw_block = Store.Block_header.t = {
proto: MBytes.t ;
}
(** This is the signature of a Tezos protocol implementation. It has
access to the standard library and the Environment module. *)
type validation_result = {
context: Context.t ;
fitness: Fitness.fitness ;
message: string option ;
}
type rpc_context = {
context: Context.t ;
level: Int32.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}
module type PROTOCOL = sig
type error = ..
type 'a tzresult = ('a, error list) result
(** The version specific type of operations. *)
type operation
(** The maximum size of operations in bytes *)
val max_operation_data_length : int
(** The maximum size of block headers in bytes *)
val max_block_length : int
(** The maximum *)
val max_number_of_operations : int
(** The parsing / preliminary validation function for
operations. Similar to {!parse_block}. *)
type operation
val parse_operation :
Operation_hash.t -> raw_operation -> operation tzresult
(** Basic ordering of operations. [compare_operations op1 op2] means
that [op1] should appear before [op2] in a block. *)
val compare_operations : operation -> operation -> int
(** A functional state that is transmitted through the steps of a
block validation sequence. It must retain the current state of
the store (that can be extracted from the outside using
{!current_context}, and whose final value is produced by
{!finalize_block}). It can also contain the information that
must be remembered during the validation, which must be
immutable (as validator or baker implementations are allowed to
pause, replay or backtrack during the validation process). *)
type validation_state
(** Access the context at a given validation step. *)
val current_context : validation_state -> Context.t tzresult Lwt.t
(** Checks that a block is well formed in a given context. This
function should run quickly, as its main use is to reject bad
blocks from the network as early as possible. The input context
is the one resulting of an ancestor block of same protocol
version, not necessarily the one of its predecessor. *)
val precheck_block :
ancestor_context: Context.t ->
ancestor_timestamp: Time.t ->
raw_block ->
unit tzresult Lwt.t
(** The first step in a block validation sequence. Initializes a
validation context for validating a block. Takes as argument the
{!raw_block} to initialize the context for this block, patching
the context resulting of the application of the predecessor
block passed as parameter. The function {!precheck_block} may
not have been called before [begin_application], so all the
check performed by the former must be repeated in the latter. *)
val begin_application :
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_fitness: Fitness.fitness ->
raw_block ->
validation_state tzresult Lwt.t
(** Initializes a validation context for constructing a new block
(as opposed to validating an existing block). Since there is no
{!raw_block} header available, the parts that it provides are
passed as arguments (predecessor block hash, context resulting
of the application of the predecessor block, and timestamp). *)
val begin_construction :
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_level: Int32.t ->
predecessor_fitness: Fitness.fitness ->
predecessor: Block_hash.t ->
timestamp: Time.t ->
validation_state tzresult Lwt.t
(** Called after {!begin_application} (or {!begin_construction}) and
before {!finalize_block}, with each operation in the block. *)
val apply_operation :
validation_state -> operation -> validation_state tzresult Lwt.t
(** The last step in a block validation sequence. It produces the
context that will be used as input for the validation of its
successor block candidates. *)
val finalize_block :
validation_state -> Context.t tzresult Lwt.t
validation_state -> validation_result tzresult Lwt.t
(** The list of remote procedures exported by this implementation *)
val rpc_services : Context.t RPC.directory
val rpc_services : rpc_context RPC.directory
val configure_sandbox :
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t

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

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

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

@ -11,6 +11,19 @@ open Logging.Updater
let (//) = Filename.concat
type validation_result = Protocol.validation_result = {
context: Context.t ;
fitness: Fitness.fitness ;
message: string option ;
}
type rpc_context = Protocol.rpc_context = {
context: Context.t ;
level: Int32.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}
module type PROTOCOL = Protocol.PROTOCOL
module type REGISTRED_PROTOCOL = sig
val hash: Protocol_hash.t
@ -30,20 +43,13 @@ type raw_operation = Store.Operation.t = {
}
let raw_operation_encoding = Store.Operation.encoding
(** The version agnostic toplevel structure of blocks. *)
type shell_block = Store.Block_header.shell_header = {
net_id: Net_id.t ;
(** The genesis of the chain this block belongs to. *)
level: Int32.t ;
predecessor: Block_hash.t ;
(** The preceding block in the chain. *)
timestamp: Time.t ;
(** The date at which this block has been forged. *)
operations: Operation_list_list_hash.t ;
(** The sequence of operations. *)
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
(** The announced score of the block. As a sequence of sequences
of unsigned bytes. Ordered by length and then by contents
lexicographically. *)
}
let shell_block_encoding = Store.Block_header.shell_header_encoding
@ -65,7 +71,6 @@ let register hash proto =
let activate = Context.set_protocol
let fork_test_network = Context.fork_test_network
let set_test_protocol = Context.set_test_protocol
let get_exn hash = VersionTable.find versions hash
let get hash =

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

@ -18,20 +18,13 @@ type raw_operation = Store.Operation.t = {
}
val raw_operation_encoding: raw_operation Data_encoding.t
(** The version agnostic toplevel structure of blocks. *)
type shell_block = Store.Block_header.shell_header = {
net_id: Net_id.t ;
(** The genesis of the chain this block belongs to. *)
level: Int32.t ;
predecessor: Block_hash.t ;
(** The preceding block in the chain. *)
timestamp: Time.t ;
(** The date at which this block has been forged. *)
operations: Operation_list_list_hash.t ;
(** The sequence of operations. *)
operations_hash: Operation_list_list_hash.t ;
fitness: MBytes.t list ;
(** The announced score of the block. As a sequence of sequences
of unsigned bytes. Ordered by length and then by contents
lexicographically. *)
}
val shell_block_encoding: shell_block Data_encoding.t
@ -41,6 +34,19 @@ type raw_block = Store.Block_header.t = {
}
val raw_block_encoding: raw_block Data_encoding.t
type validation_result = Protocol.validation_result = {
context: Context.t ;
fitness: Fitness.fitness ;
message: string option ;
}
type rpc_context = Protocol.rpc_context = {
context: Context.t ;
level: Int32.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}
module type PROTOCOL = Protocol.PROTOCOL
module type REGISTRED_PROTOCOL = sig
val hash: Protocol_hash.t
@ -60,8 +66,8 @@ val extract: Lwt_io.file_name -> Protocol_hash.t -> component list -> unit Lwt.t
val compile: Protocol_hash.t -> component list -> bool Lwt.t
val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t
val set_test_protocol: Context.t -> Protocol_hash.t -> Context.t Lwt.t
val fork_test_network: Context.t -> Context.t Lwt.t
val fork_test_network:
Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t
val register: Protocol_hash.t -> (module REGISTRED_PROTOCOL) -> unit

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

@ -67,9 +67,10 @@ let start_new_voting_cycle ctxt =
Vote.clear_ballots ctxt >>= fun ctxt ->
Vote.clear_listings ctxt >>=? fun ctxt ->
if approved then
let expiration = (* in two days maximum... *)
Time.add (Timestamp.current ctxt) (Int64.mul 48L 3600L) in
Vote.get_current_proposal ctxt >>=? fun proposal ->
set_test_protocol ctxt proposal >>= fun ctxt ->
fork_test_network ctxt >>= fun ctxt ->
fork_test_network ctxt proposal expiration >>= fun ctxt ->
Vote.set_current_period_kind ctxt Testing >>=? fun ctxt ->
return ctxt
else
@ -133,12 +134,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

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

@ -51,19 +51,19 @@ let apply_delegate_operation_content
(Block_hash.equal block pred_block)
(Wrong_endorsement_predecessor (pred_block, block)) >>=? fun () ->
Mining.check_signing_rights ctxt slot delegate >>=? fun () ->
Fitness.increase ctxt >>=? fun ctxt ->
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
@ -175,8 +175,9 @@ let apply_sourced_operation
| Dictator_operation (Activate_testnet hash) ->
let dictator_pubkey = Constants.dictator_pubkey ctxt in
Operation.check_signature dictator_pubkey operation >>=? fun () ->
set_test_protocol ctxt hash >>= fun ctxt ->
fork_test_network ctxt >>= fun ctxt ->
let expiration = (* in two days maximum... *)
Time.add (Timestamp.current ctxt) (Int64.mul 48L 3600L) in
fork_test_network ctxt hash expiration >>= fun ctxt ->
return (ctxt, origination_nonce, None)
let apply_anonymous_operation ctxt miner_contract origination_nonce kind =
@ -228,17 +229,14 @@ 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 ->
Roll.clear_cycle ctxt last_cycle >>=? fun ctxt ->
Roll.freeze_rolls_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt ->
Timestamp.get_current ctxt >>= fun timestamp ->
let timestamp = Timestamp.current ctxt in
Lwt.return (Timestamp.(timestamp +? (Constants.time_before_reward ctxt)))
>>=? fun reward_date ->
Reward.set_reward_time_for_cycle
@ -254,28 +252,20 @@ let begin_application ctxt block pred_timestamp =
Mining.check_mining_rights ctxt block pred_timestamp >>=? fun miner ->
Mining.check_signature ctxt block miner >>=? fun () ->
Mining.pay_mining_bond ctxt block miner >>=? fun ctxt ->
Fitness.increase ctxt >>=? fun ctxt ->
let ctxt = Fitness.increase ctxt in
return (ctxt, miner)
let finalize_application ctxt block miner op_count =
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 ->
Level.current ctxt >>=? fun { level } ->
let level = Raw_level.to_int32 level in
Fitness.get ctxt >>=? fun fitness ->
let commit_message =
Format.asprintf
"lvl %ld, fit %Ld, prio %ld, %d ops"
level fitness priority op_count in
return (commit_message, ctxt)
return ctxt
let compare_operations op1 op2 =
match op1.contents, op2.contents with

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: Int32.t ;
}
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 "proprity" int32))
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_hash } ;
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_hash } 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: Int32.t ;
}
val mining_slot_encoding: mining_slot Data_encoding.encoding
(** The maximum size of block headers in bytes *)
val max_header_length: int

10
src/proto/alpha/constants_repr.ml
View File

@ -38,7 +38,7 @@ type constants = {
voting_period_length: int32 ;
time_before_reward: Period_repr.t ;
slot_durations: Period_repr.t list ;
first_free_mining_slot: int32 ;
first_free_mining_slot: int ;
max_signing_slot: int ;
instructions_per_transaction: int ;
proof_of_work_threshold: int64 ;
@ -58,7 +58,7 @@ let default = {
Int64.(mul 365L (mul 24L 3600L)) ;
slot_durations =
List.map Period_repr.of_seconds_exn [ 60L ] ;
first_free_mining_slot = 16l ;
first_free_mining_slot = 16 ;
max_signing_slot = 15 ;
instructions_per_transaction = 16 * 1024 ;
proof_of_work_threshold =
@ -103,7 +103,7 @@ let constants_encoding =
opt Compare_slot_durations.(=)
default.slot_durations c.slot_durations
and first_free_mining_slot =
opt Compare.Int32.(=)
opt Compare.Int.(=)
default.first_free_mining_slot c.first_free_mining_slot
and max_signing_slot =
opt Compare.Int.(=)
@ -171,8 +171,8 @@ let constants_encoding =
(opt "voting_period_length" int32)
(opt "time_before_reward" int64)
(opt "slot_durations" (list Period_repr.encoding))
(opt "first_free_mining_slot" int32)
(opt "max_signing_slot" int31)
(opt "first_free_mining_slot" uint16)
(opt "max_signing_slot" uint16)
(opt "instructions_per_transaction" int31)
(opt "proof_of_work_threshold" int64)
(opt "bootstrap_keys" (list Ed25519.Public_key.encoding))

8
src/proto/alpha/fitness_repr.ml
View File

@ -16,9 +16,9 @@ let int64_to_bytes i =
let int64_of_bytes b =
if Compare.Int.(MBytes.length b <> 8) then
fail Invalid_fitness
error Invalid_fitness
else
return (MBytes.get_int64 b 0)
ok (MBytes.get_int64 b 0)
let from_int64 fitness =
[ MBytes.of_string Constants_repr.version_number ;
@ -30,5 +30,5 @@ let to_int64 = function
when Compare.String.
(MBytes.to_string version = Constants_repr.version_number) ->
int64_of_bytes fitness
| [] -> return 0L
| _ -> fail Invalid_fitness
| [] -> ok 0L
| _ -> error Invalid_fitness

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

@ -7,17 +7,7 @@
(* *)
(**************************************************************************)
let get ctxt =
Storage.get_fitness ctxt >>= fun fitness ->
Fitness_repr.to_int64 fitness
let set ctxt v =
Storage.set_fitness ctxt (Fitness_repr.from_int64 v) >>= fun ctxt ->
Lwt.return ctxt
let current = Storage.current_fitness
let increase ctxt =
get ctxt >>=? fun v ->
set ctxt (Int64.succ v) >>= fun ctxt ->
return ctxt
let init ctxt = set ctxt 0L
let fitness = current ctxt in
Storage.set_current_fitness ctxt (Int64.succ fitness)

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

@ -7,25 +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 ~from_genesis (ctxt:Context.t) =
Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
Storage.prepare ctxt >>=? fun store ->
begin
if from_genesis then
Lwt.return store
else
Fitness_storage.init store
end >>= 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 ->
@ -38,34 +22,25 @@ let initialize ~from_genesis (ctxt:Context.t) =
return store
type error +=
| Incompatiple_protocol_version
| Unimplemented_sandbox_migration
let may_initialize ctxt =
Context.get ctxt version_key >>= function
| None ->
(* This is the genesis protocol: The only acceptable preceding
version is an empty context *)
initialize ~from_genesis:false ctxt
| Some bytes ->
let s = MBytes.to_string bytes in
if Compare.String.(s = version_value)
then Storage.prepare ctxt
else if Compare.String.(s = "genesis") then
initialize ~from_genesis:true 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 ->
initialize ~from_genesis:false ctxt >>=? fun ctxt ->
return (Storage.recover ctxt)
| Some _ ->
return ctxt
| 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

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

@ -34,7 +34,7 @@ type validation_state =
op_count : int }
let current_context { ctxt } =
Tezos_context.finalize ctxt
return (Tezos_context.finalize ctxt).context
let precheck_block
~ancestor_context:_
@ -47,9 +47,13 @@ let precheck_block
let begin_application
~predecessor_context:ctxt
~predecessor_timestamp:pred_timestamp
~predecessor_fitness:pred_fitness
raw_block =
Lwt.return (Tezos_context.Block.parse_header raw_block) >>=? fun header ->
Tezos_context.init ctxt >>=? fun ctxt ->
let level = header.shell.level in
let fitness = pred_fitness in
let timestamp = header.shell.timestamp in
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 }
@ -57,21 +61,25 @@ 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 ctxt >>=? fun ctxt ->
Apply.begin_construction 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 }
let apply_operation ({ mode ; ctxt ; op_count } as data) operation =
let pred_block, block_prio, miner_contract =
match mode with
| Construction { pred_block } ->
pred_block, 0l, None
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
@ -81,12 +89,20 @@ let apply_operation ({ mode ; ctxt ; op_count } as data) operation =
let finalize_block { mode ; ctxt ; op_count } = match mode with
| Construction _ ->
Tezos_context.finalize ctxt >>=? fun ctxt ->
let ctxt = Tezos_context.finalize ctxt in
return ctxt
| Application (block, miner) ->
Apply.finalize_application
ctxt block miner op_count >>=? fun (commit_message, ctxt) ->
Tezos_context.finalize ~commit_message ctxt >>=? fun ctxt ->
Apply.finalize_application ctxt block miner >>=? fun ctxt ->
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 =
Format.asprintf
"lvl %ld, fit %Ld, prio %d, %d ops"
level fitness priority op_count in
let ctxt = Tezos_context.finalize ~commit_message ctxt in
return ctxt
let compare_operations op1 op2 =

69
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"
@ -110,6 +95,7 @@ let () =
(fun () -> Cannot_pay_endorsement_bond)
let minimal_time c priority pred_timestamp =
let priority = Int32.of_int priority in
let rec cumsum_slot_durations acc durations p =
if Compare.Int32.(<=) p 0l then
ok acc
@ -128,26 +114,19 @@ let minimal_time c priority pred_timestamp =
let check_timestamp c priority pred_timestamp =
minimal_time c priority pred_timestamp >>=? fun minimal_time ->
Tezos_context.Timestamp.get_current c >>= fun timestamp ->
let timestamp = Tezos_context.Timestamp.current c in
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 =
if Compare.Int32.(priority >= Constants.first_free_mining_slot c)
let pay_mining_bond c { Block.proto = { priority } } id =
if Compare.Int.(priority >= Constants.first_free_mining_slot c)
then return c
else
Contract.spend c (Contract.default_contract id) Constants.mining_bond_cost
@ -162,13 +141,13 @@ 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))
let paying_priorities c =
0l ---> Constants.first_free_mining_slot c
0 --> Constants.first_free_mining_slot c
let bond_and_reward =
match Tez.(Constants.mining_bond_cost +? Constants.mining_reward) with
@ -176,25 +155,25 @@ let bond_and_reward =
| Error _ -> assert false
let base_mining_reward c ~priority =
if Compare.Int32.(priority < Constants.first_free_mining_slot c)
if Compare.Int.(priority < Constants.first_free_mining_slot c)
then bond_and_reward
else Constants.mining_reward
type error += Incorect_priority
let endorsement_reward ~block_priority:prio =
if Compare.Int32.(prio >= 0l)
if Compare.Int.(prio >= 0)
then
Lwt.return
Tez.(Constants.endorsement_reward /? (Int64.(succ (of_int32 prio))))
Tez.(Constants.endorsement_reward /? (Int64.(succ (of_int prio))))
else fail Incorect_priority
let mining_priorities c level =
let rec f priority =
Roll.mining_rights_owner c level ~priority >>=? fun delegate ->
return (LCons (delegate, (fun () -> f (Int32.succ priority))))
return (LCons (delegate, (fun () -> f (succ priority))))
in
f 0l
f 0
let endorsement_priorities c level =
let rec f slot =
@ -205,7 +184,7 @@ let endorsement_priorities c level =
let select_delegate delegate delegate_list max_priority =
let rec loop acc l n =
if Compare.Int32.(n >= max_priority)
if Compare.Int.(n >= max_priority)
then return (List.rev acc)
else
let LCons (pkh, t) = l in
@ -214,9 +193,9 @@ let select_delegate delegate delegate_list max_priority =
then n :: acc
else acc in
t () >>=? fun t ->
loop acc t (Int32.succ n)
loop acc t (succ n)
in
loop [] delegate_list 0l
loop [] delegate_list 0
let first_mining_priorities
ctxt
@ -227,8 +206,7 @@ let first_mining_priorities
let first_endorsement_slots
ctxt
?(max_priority =
Int32.of_int (Constants.max_signing_slot ctxt))
?(max_priority = Constants.max_signing_slot ctxt)
delegate level =
endorsement_priorities ctxt level >>=? fun delegate_list ->
select_delegate delegate delegate_list max_priority
@ -273,20 +251,21 @@ let max_fitness_gap ctxt =
Int64.add slots 1L
let check_fitness_gap ctxt (block : Block.header) =
Fitness.get ctxt >>=? fun current_fitness ->
Fitness.to_int64 block.shell.fitness >>=? fun announced_fitness ->
let current_fitness = Fitness.current ctxt in
Lwt.return (Fitness.to_int64 block.shell.fitness) >>=? fun announced_fitness ->
let gap = Int64.sub announced_fitness current_fitness in
if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then
fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
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

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

@ -14,15 +14,13 @@ 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 *)
val paying_priorities: context -> int32 list
val paying_priorities: context -> int list
val minimal_time:
context -> int32 -> Time.t -> Time.t tzresult Lwt.t
val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t
(** [minimal_time ctxt priority pred_block_time] returns the minimal
time, given the predecessor block timestamp [pred_block_time],
after which a miner with priority [priority] is allowed to
@ -56,9 +54,9 @@ val check_signing_rights:
(** If this priority should have payed the bond it is the base mining
reward and the bond, or just the base reward otherwise *)
val base_mining_reward: context -> priority:int32 -> Tez.t
val base_mining_reward: context -> priority:int -> Tez.t
val endorsement_reward: block_priority:int32 -> Tez.t tzresult Lwt.t
val endorsement_reward: block_priority:int -> Tez.t tzresult Lwt.t
val mining_priorities:
context -> Level.t -> public_key_hash lazy_list
@ -70,10 +68,10 @@ val endorsement_priorities:
val first_mining_priorities:
context ->
?max_priority:int32 ->
?max_priority:int ->
public_key_hash ->
Level.t ->
int32 list tzresult Lwt.t
int list tzresult Lwt.t
(** [first_mining_priorities ctxt ?max_priority contract_hash level]
is a list of priorities of max [?max_priority] elements, where the
delegate of [contract_hash] is allowed to mine for [level]. If
@ -82,9 +80,9 @@ val first_mining_priorities:
val first_endorsement_slots:
context ->
?max_priority:int32 ->
?max_priority:int ->
public_key_hash ->
Level.t -> int32 list tzresult Lwt.t
Level.t -> int list tzresult Lwt.t
val check_signature:
context -> Block.header -> public_key_hash -> unit tzresult Lwt.t

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/reward_storage.ml
View File

@ -56,7 +56,7 @@ let pay_rewards_for_cycle c cycle =
amount)
let pay_due_rewards c =
Storage.get_timestamp c >>= fun timestamp ->
let timestamp = Storage.current_timestamp c in
let rec loop c cycle =
Storage.Rewards.Date.get_option c cycle >>=? function
| None ->

4
src/proto/alpha/roll_storage.ml
View File

@ -73,7 +73,7 @@ module Random = struct
let cycle = level.Level_repr.cycle in
Seed_storage.for_cycle c cycle >>=? fun random_seed ->
let rd = level_random random_seed kind level in
let sequence = Seed_repr.sequence rd offset in
let sequence = Seed_repr.sequence rd (Int32.of_int offset) in
Storage.Roll.Last_for_cycle.get c cycle >>=? fun bound ->
let roll, _ = Roll_repr.random sequence bound in
Storage.Roll.Owner_for_cycle.get c (cycle, roll)
@ -84,7 +84,7 @@ let mining_rights_owner c level ~priority =
Random.owner c "mining" level priority
let endorsement_rights_owner c level ~slot =
Random.owner c "endorsement" level (Int32.of_int slot)
Random.owner c "endorsement" level slot
module Contract = struct

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

@ -35,7 +35,7 @@ val clear_cycle :
Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t
val mining_rights_owner :
Storage.t -> Level_repr.t -> priority:int32 ->
Storage.t -> Level_repr.t -> priority:int ->
Ed25519.Public_key_hash.t tzresult Lwt.t
val endorsement_rights_owner :

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

@ -475,7 +475,7 @@ let rec interp
Contract.get_balance ctxt source >>=? fun balance ->
logged_return (Item (balance, rest), qta - 1, ctxt)
| Now, rest ->
Timestamp.get_current ctxt >>= fun now ->
let now = Timestamp.current ctxt in
logged_return (Item (now, rest), qta - 1, ctxt)
| Check_signature, Item (key, Item ((signature, message), rest)) ->
Public_key.get ctxt key >>=? fun key ->

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

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

@ -73,7 +73,7 @@ module Constants = struct
~description: "First free mining slot"
~input: empty
~output: (wrap_tzerror @@
describe ~title: "first free mining slot" int32)
describe ~title: "first free mining slot" uint16)
RPC.Path.(custom_root / "constants" / "first_free_mining_slot")
let max_signing_slot custom_root =
@ -81,7 +81,7 @@ module Constants = struct
~description: "Max signing slot"
~input: empty
~output: (wrap_tzerror @@
describe ~title: "max signing slot" int31)
describe ~title: "max signing slot" uint16)
RPC.Path.(custom_root / "constants" / "max_signing_slot")
let instructions_per_transaction custom_root =
@ -563,7 +563,7 @@ module Helpers = struct
(req "fitness" Fitness.encoding)
(req "operations" Operation_list_list_hash.encoding)
(req "level" Raw_level.encoding)
(req "priority" int31)
(req "priority" uint16)
(req "nonce_hash" Nonce_hash.encoding)
(req "proof_of_work_nonce"
(Fixed.bytes Tezos_context.Constants.proof_of_work_nonce_size)))

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

@ -9,24 +9,27 @@
open Tezos_context
let rpc_services = ref (RPC.empty : Context.t RPC.directory)
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 =
rpc_services :=
RPC.register !rpc_services (s RPC.Path.root)
(fun ctxt () ->
( Tezos_context.init ctxt >>=? fun ctxt ->
( rpc_init ctxt >>=? fun ctxt ->
f ctxt ) >>= RPC.Answer.return)
let register1 s f =
rpc_services :=
RPC.register !rpc_services (s RPC.Path.root)
(fun ctxt arg ->
( Tezos_context.init ctxt >>=? fun ctxt ->
( rpc_init ctxt >>=? fun ctxt ->
f ctxt arg ) >>= RPC.Answer.return)
let register2 s f =
rpc_services :=
RPC.register !rpc_services (s RPC.Path.root)
(fun (ctxt, arg1) arg2 ->
( Tezos_context.init ctxt >>=? fun ctxt ->
( rpc_init ctxt >>=? fun ctxt ->
f ctxt arg1 arg2 ) >>= RPC.Answer.return)
let register1_noctxt s f =
rpc_services :=
@ -92,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
@ -100,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
@ -143,7 +146,7 @@ let () =
rpc_services :=
RPC.register !rpc_services (s RPC.Path.root)
(fun (ctxt, contract) arg ->
( Tezos_context.init ctxt >>=? fun ctxt ->
( rpc_init ctxt >>=? fun ctxt ->
Contract.exists ctxt contract >>=? function
| true -> f ctxt contract arg
| false -> raise Not_found ) >>= RPC.Answer.return) in
@ -171,13 +174,13 @@ let () =
(*-- Helpers -----------------------------------------------------------------*)
let minimal_timestamp ctxt prio =
let prio = match prio with None -> 0l | Some p -> Int32.of_int p in
let prio = match prio with None -> 0 | Some p -> p in
Mining.minimal_time ctxt prio
let () = register1
Services.Helpers.minimal_timestamp
(fun ctxt slot ->
Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
let timestamp = Tezos_context.Timestamp.current ctxt in
minimal_timestamp ctxt slot timestamp)
let () =
@ -190,10 +193,10 @@ 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 = 0l in
let block_prio = 0 in
Apply.apply_operation
ctxt (Some miner_contract) pred_block block_prio operation
>>=? function
@ -278,11 +281,11 @@ let () = register2 Services.Helpers.levels levels
let default_max_mining_priority ctxt arg =
let default = Constants.first_free_mining_slot ctxt in
match arg with
| None -> Int32.mul 2l default
| Some m -> Int32.of_int m
| None -> 2 * default
| Some m -> m
let mining_rights ctxt level max =
let max = Int32.to_int (default_max_mining_priority ctxt max) in
let max = default_max_mining_priority ctxt max in
Mining.mining_priorities ctxt level >>=? fun contract_list ->
let rec loop l n =
match n with
@ -299,15 +302,14 @@ 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) @@
List.mapi
(fun prio c ->
Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
Mining.minimal_time
ctxt (Int32.of_int prio) timestamp >>= function
let timestamp = Timestamp.current ctxt in
Mining.minimal_time ctxt prio timestamp >>= function
| Error _ -> Lwt.return None
| Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp)))
slots
@ -323,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 ->
@ -343,9 +345,9 @@ let mining_rights_for_delegate
let raw_level = level.level in
Error_monad.map_s
(fun priority ->
Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
let timestamp = Timestamp.current ctxt in
Mining.minimal_time ctxt priority timestamp >>=? fun time ->
return (raw_level, Int32.to_int priority, time))
return (raw_level, priority, time))
priorities >>=? fun priorities ->
return (priorities @ t)
in
@ -379,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 ->
@ -388,10 +390,8 @@ let () =
let endorsement_rights_for_delegate
ctxt contract (max_priority, min_level, max_level) =
let max_priority =
Int32.of_int @@
default_max_endorsement_priority ctxt max_priority in
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
| None ->
@ -409,10 +409,7 @@ let endorsement_rights_for_delegate
Mining.first_endorsement_slots
ctxt ~max_priority contract level >>=? fun slots ->
let raw_level = level.level in
let slots =
List.rev_map
(fun slot -> (raw_level, Int32.to_int slot))
slots in
let slots = List.rev_map (fun slot -> (raw_level, slot)) slots in
return (List.rev_append slots t)
in
loop min_level
@ -437,13 +434,13 @@ let forge_operations _ctxt (shell, proto) =
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 priority = Int32.of_int priority in
let mining_slot = { Block.level = raw_level ; priority } in
(net_id, predecessor, timestamp, fitness, operations_hash,
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_hash }
{ priority ; seed_nonce_hash ; proof_of_work_nonce })
let () = register1 Services.Helpers.Forge.block forge_block

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

@ -10,21 +10,54 @@
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" ]
let prevalidation_key = [ version ; "prevalidation" ]
type t = Storage_functors.context
type error += Invalid_sandbox_parameter
let get_fitness (c, _) = Context.get_fitness c
let set_fitness (c, csts) v =
Context.set_fitness c v >>= fun c -> Lwt.return (c, csts)
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_timestamp (c, _) = Context.get_timestamp c
let set_commit_message (c, csts) msg =
Context.set_commit_message c msg >>= fun c -> Lwt.return (c, csts)
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
@ -38,29 +71,41 @@ let set_sandboxed c json =
Context.set c sandboxed_key
(Data_encoding.Binary.to_bytes Data_encoding.json json)
let prepare (c : Context.t) : t tzresult Lwt.t =
get_sandboxed c >>=? fun sandbox ->
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 ->
may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) ->
get_sandboxed ctxt >>=? fun sandbox ->
Constants_repr.read sandbox >>=? function constants ->
return (c, constants)
let recover (c, _ : t) : Context.t = c
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 get_prevalidation (c, _ : t) =
Context.get c prevalidation_key >>= function
| None -> Lwt.return false
| Some _ -> Lwt.return true
let set_prevalidation (c, constants : t) =
Context.set c prevalidation_key (MBytes.of_string "prevalidation") >>= fun c ->
Lwt.return (c, constants)
let constants : t -> _ = snd
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"]
@ -132,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
@ -510,13 +545,11 @@ module Rewards = struct
end
let activate (c, constants) h =
Updater.activate c h >>= fun c -> Lwt.return (c, constants)
let fork_test_network (c, constants) =
Updater.fork_test_network c >>= fun c -> Lwt.return (c, constants)
let set_test_protocol (c, constants) h =
Updater.set_test_protocol c h >>= fun c -> Lwt.return (c, constants)
let activate ({ context = c } as s) h =
Updater.activate c h >>= fun c -> Lwt.return { s with context = c }
let fork_test_network ({ context = c } as s) protocol expiration =
Updater.fork_test_network c ~protocol ~expiration >>= fun c ->
Lwt.return { s with context = c }
(** Resolver *)

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

@ -24,8 +24,17 @@
(** Abstract view of the database *)
type t
(** Rerieves the state of the database and gives its abstract view *)
val prepare : Context.t -> t tzresult Lwt.t
(** 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 * bool) tzresult Lwt.t
(** Returns the state of the database resulting of operations on its
abstract view *)
@ -34,27 +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 get_fitness : t -> Fitness.fitness Lwt.t
val set_fitness : t -> Fitness.fitness -> t Lwt.t
val current_level : t -> Level_repr.t
val current_timestamp : t -> Time.t
val get_timestamp: t -> Time.t Lwt.t
val set_commit_message: t -> string -> t Lwt.t
val get_prevalidation : t -> bool Lwt.t
val set_prevalidation : t -> t Lwt.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
@ -274,5 +275,4 @@ module Rewards : sig
end
val activate: t -> Protocol_hash.t -> t Lwt.t
val set_test_protocol: t -> Protocol_hash.t -> t Lwt.t
val fork_test_network: t -> t Lwt.t
val fork_test_network: t -> Protocol_hash.t -> Time.t -> t Lwt.t

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

@ -11,7 +11,14 @@
open Misc
type context = Context.t * Constants_repr.constants
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 ;
}
(*-- Errors ------------------------------------------------------------------*)
@ -52,7 +59,7 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
let key_to_string l = String.concat "/" (key l)
let get (c, _) k =
let get { context = c } k =
Context.get c (key k) >>= function
| None ->
let msg =
@ -61,16 +68,16 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
| Some bytes ->
Lwt.return (P.of_bytes bytes)
let mem (c, _) k = Context.mem c (key k)
let mem { context = c } k = Context.mem c (key k)
let get_option (c, _) k =
let get_option { context = c } k =
Context.get c (key k) >>= function
| None -> return None
| Some bytes ->
Lwt.return (P.of_bytes bytes >|? fun v -> Some v)
(* Verify that the key is present before modifying *)
let set (c, x) k v =
let set ({ context = c } as s) k v =
let key = key k in
Context.get c key >>= function
| None ->
@ -80,13 +87,13 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
| Some old ->
let bytes = P.to_bytes v in
if MBytes.(old = bytes) then
return (c, x)
return { s with context = c }
else
Context.set c key (P.to_bytes v) >>= fun c ->
return (c, x)
return { s with context = c }
(* Verify that the key is not present before inserting *)
let init (c, x) k v =
let init ({ context = c } as s) k v =
let key = key k in
Context.get c key >>=
function
@ -96,27 +103,29 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
fail (Storage_error msg)
| None ->
Context.set c key (P.to_bytes v) >>= fun c ->
return (c, x)
return { s with context = c }
(* Does not verify that the key is present or not *)
let init_set (c, x) k v =
Context.set c (key k) (P.to_bytes v) >>= fun c -> return (c, x)
let init_set ({ context = c } as s) k v =
Context.set c (key k) (P.to_bytes v) >>= fun c ->
return { s with context = c }
(* Verify that the key is present before deleting *)
let delete (c, x) k =
let delete ({ context = c } as s) k =
let key = key k in
Context.get c key >>= function
| Some _ ->
Context.del c key >>= fun c ->
return (c, x)
return { s with context = c }
| None ->
let msg =
"cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in
fail (Storage_error msg)
(* Do not verify before deleting *)
let remove (c, x) k =
Context.del c (key k) >>= fun c -> Lwt.return (c, x)
let remove ({ context = c } as s) k =
Context.del c (key k) >>= fun c ->
Lwt.return { s with context = c }
end
@ -229,28 +238,34 @@ module Make_data_set_storage (P : Single_data_description) = struct
error (Storage_error msg)
| Some v -> Ok v
let add (c, x) v =
let add ({ context = c } as s) v =
let hash, data = serial v in
HashTbl.mem c hash >>= function
| true -> return (c, x)
| false -> HashTbl.set c hash data >>= fun c -> return (c, x)
| true ->
return { s with context = c }
| false ->
HashTbl.set c hash data >>= fun c ->
return { s with context = c }
let del (c, x) v =
let del ({ context = c } as s) v =
let hash, _ = serial v in
HashTbl.mem c hash >>= function
| false -> return (c, x)
| true -> HashTbl.del c hash >>= fun c -> return (c, x)
| false ->
return { s with context = c }
| true ->
HashTbl.del c hash >>= fun c ->
return { s with context = c }
let mem (c, _) v =
let mem { context = c } v =
let hash, _ = serial v in
HashTbl.mem c hash >>= fun v ->
return v
let elements (c, _) =
let elements { context = c } =
HashTbl.bindings c >>= fun elts ->
map_s (fun (_, data) -> Lwt.return (unserial data)) elts
let fold (c, _) init ~f =
let fold { context = c } init ~f =
HashTbl.fold c (ok init)
~f:(fun _ data acc ->
match acc with
@ -262,9 +277,9 @@ module Make_data_set_storage (P : Single_data_description) = struct
f data acc >>= fun acc ->
return acc)
let clear (c, x) =
let clear ({ context = c } as s) =
HashTbl.fold c c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c ->
return (c, x)
return { s with context = c }
end
@ -284,7 +299,7 @@ module Raw_make_iterable_data_storage
let key_to_string k = String.concat "/" (K.to_path k)
let get (c, _) k =
let get { context = c } k =
HashTbl.get c k >>= function
| None ->
let msg =
@ -293,15 +308,15 @@ module Raw_make_iterable_data_storage
| Some v ->
return v
let mem (c, _) k = HashTbl.mem c k
let mem { context = c } k = HashTbl.mem c k
let get_option (c, _) k =
let get_option { context = c } k =
HashTbl.get c k >>= function
| None -> return None
| Some v -> return (Some v)
(* Verify that the key is present before modifying *)
let set (c, x) k v =
let set ({ context = c } as s) k v =
HashTbl.get c k >>= function
| None ->
let msg =
@ -309,10 +324,10 @@ module Raw_make_iterable_data_storage
fail (Storage_error msg)
| Some _ ->
HashTbl.set c k v >>= fun c ->
return (c, x)
return { s with context = c }
(* Verify that the key is not present before inserting *)
let init (c, x) k v =
let init ({ context = c } as s) k v =
HashTbl.get c k >>=
function
| Some _ ->
@ -321,29 +336,35 @@ module Raw_make_iterable_data_storage
fail (Storage_error msg)
| None ->
HashTbl.set c k v >>= fun c ->
return (c, x)
return { s with context = c }
(* Does not verify that the key is present or not *)
let init_set (c, x) k v = HashTbl.set c k v >>= fun c -> return (c, x)
let init_set ({ context = c } as s) k v =
HashTbl.set c k v >>= fun c ->
return { s with context = c }
(* Verify that the key is present before deleting *)
let delete (c, x) k =
let delete ({ context = c } as s) k =
HashTbl.get c k >>= function
| Some _ ->
HashTbl.del c k >>= fun c ->
return (c, x)
return { s with context = c }
| None ->
let msg =
"cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in
fail (Storage_error msg)
(* Do not verify before deleting *)
let remove (c, x) k =
HashTbl.del c k >>= fun c -> Lwt.return (c, x)
let remove ({ context = c } as s) k =
HashTbl.del c k >>= fun c ->
Lwt.return { s with context = c }
let clear (c, x) = HashTbl.clear c >>= fun c -> Lwt.return (c, x)
let fold (c, _) x ~f = HashTbl.fold c x ~f:(fun k v acc -> f k v acc)
let iter (c, _) ~f = HashTbl.fold c () ~f:(fun k v () -> f k v)
let clear ({ context = c } as s) =
HashTbl.clear c >>= fun c ->
Lwt.return { s with context = c }
let fold { context = c } x ~f = HashTbl.fold c x ~f:(fun k v acc -> f k v acc)
let iter { context = c } ~f = HashTbl.fold c () ~f:(fun k v () -> f k v)
end

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

@ -14,7 +14,14 @@
indexed data and homgeneous data set). *)
type context = Context.t * Constants_repr.constants
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 ;
}
open Storage_sigs

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

@ -22,7 +22,7 @@ module Period = Period_repr
module Timestamp = struct
include Time_repr
let get_current = Storage.get_timestamp
let current = Storage.current_timestamp
end
include Operation_repr
@ -110,18 +110,12 @@ end
let init = Init_storage.may_initialize
let finalize ?commit_message c =
match commit_message with
| None ->
return (Storage.recover c)
| Some msg ->
Storage.set_commit_message c msg >>= fun c ->
return (Storage.recover c)
let finalize ?commit_message:message c =
let fitness = Fitness.from_int64 (Fitness.current c) in
let context = Storage.recover c in
{ Updater.context ; fitness ; message }
let configure_sandbox = Init_storage.configure_sandbox
let get_prevalidation = Storage.get_prevalidation
let set_prevalidation = Storage.set_prevalidation
let activate = Storage.activate
let fork_test_network = Storage.fork_test_network
let set_test_protocol = Storage.set_test_protocol

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

@ -75,10 +75,7 @@ module Timestamp : sig
val of_seconds: string -> time option
val to_seconds: time -> string
val get_current: context -> Time.t Lwt.t
(** [get_current ctxt] returns the current timestamp of [ctxt]. When
[ctxt] is the context of a block, the block timestamp is used,
otherwise a timestamp is inferred otherwise. *)
val current: context -> Time.t
end
@ -175,7 +172,7 @@ module Constants : sig
val voting_period_length: context -> int32
val time_before_reward: context -> Period.t
val slot_durations: context -> Period.t list
val first_free_mining_slot: context -> int32
val first_free_mining_slot: context -> int
val max_signing_slot: context -> int
val instructions_per_transaction: context -> int
val proof_of_work_threshold: context -> int64
@ -222,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 ;
@ -231,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
@ -240,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
@ -253,10 +250,11 @@ module Fitness : sig
include (module type of Fitness)
type t = fitness
val increase: context -> context tzresult Lwt.t
val increase: context -> context
val get: context -> int64 tzresult Lwt.t
val to_int64: fitness -> int64 tzresult Lwt.t
val current: context -> int64
val to_int64: fitness -> int64 tzresult
end
@ -525,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: Int32.t ;
}
val mining_slot_encoding: mining_slot Data_encoding.encoding
val max_header_length: int
val parse_header: Updater.raw_block -> header tzresult
@ -558,7 +549,7 @@ module Roll : sig
val clear_cycle: context -> Cycle.t -> context tzresult Lwt.t
val mining_rights_owner:
context -> Level.t -> priority:int32 -> public_key_hash tzresult Lwt.t
context -> Level.t -> priority:int -> public_key_hash tzresult Lwt.t
val endorsement_rights_owner:
context -> Level.t -> slot:int -> public_key_hash tzresult Lwt.t
@ -580,15 +571,16 @@ module Reward : sig
end
val init: Context.t -> context tzresult Lwt.t
val finalize: ?commit_message:string -> context -> Context.t tzresult Lwt.t
val init:
Context.t ->
level:Int32.t ->
timestamp:Time.t ->
fitness:Fitness.t ->
context tzresult Lwt.t
val finalize: ?commit_message:string -> context -> Updater.validation_result
val configure_sandbox:
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
val get_prevalidation: context -> bool Lwt.t
val set_prevalidation: context -> context Lwt.t
val activate: context -> Protocol_hash.t -> context Lwt.t
val set_test_protocol: context -> Protocol_hash.t -> context Lwt.t
val fork_test_network: context -> context Lwt.t
val fork_test_network: context -> Protocol_hash.t -> Time.t -> context Lwt.t

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

@ -17,9 +17,15 @@ let parse_operation h _ = Ok h
let compare_operations _ _ = 0
module Fitness = struct
type validation_state = {
context : Context.t ;
fitness : Int64.t ;
}
let version_number = "\000"
let current_context { context } =
return context
module Fitness = struct
type error += Invalid_fitness
type error += Invalid_fitness2
@ -36,67 +42,51 @@ module Fitness = struct
return (MBytes.get_int64 b 0)
let from_int64 fitness =
[ MBytes.of_string version_number ;
int64_to_bytes fitness ]
[ int64_to_bytes fitness ]
let to_int64 = function
| [ version ;
fitness ]
when Compare.String.
(MBytes.to_string version = version_number) ->
int64_of_bytes fitness
| [ fitness ] -> int64_of_bytes fitness
| [] -> return 0L
| _ -> fail Invalid_fitness
let get ctxt =
Context.get_fitness ctxt >>= fun fitness ->
to_int64 fitness
let set ctxt v =
Context.set_fitness ctxt (from_int64 v) >>= fun ctxt ->
Lwt.return ctxt
let increase ctxt =
get ctxt >>=? fun v ->
set ctxt (Int64.succ v) >>= fun ctxt ->
return ctxt
let get { fitness } = fitness
end
type validation_state = Context.t
let current_context ctxt =
return ctxt
let precheck_block
~ancestor_context:_
~ancestor_timestamp:_
_raw_block =
raw_block =
Fitness.to_int64 raw_block.Updater.shell.fitness >>=? fun _ ->
return ()
let begin_application
~predecessor_context:ctxt
~predecessor_context:context
~predecessor_timestamp:_
_raw_block =
return ctxt
~predecessor_fitness:_
raw_block =
Fitness.to_int64 raw_block.Updater.shell.fitness >>=? fun fitness ->
return { context ; fitness }
let begin_construction
~predecessor_context:ctxt
~predecessor_context:context
~predecessor_timestamp:_
~predecessor_level:_
~predecessor_fitness:pred_fitness
~predecessor:_
~timestamp:_ =
return ctxt
Fitness.to_int64 pred_fitness >>=? function pred_fitness ->
let fitness = Int64.succ pred_fitness in
return { context ; fitness }
let apply_operation ctxt _ =
return ctxt
let finalize_block ctxt =
Fitness.increase ctxt >>=? fun ctxt ->
Fitness.get ctxt >>=? fun fitness ->
let commit_message =
Format.asprintf "fitness <- %Ld" fitness in
Context.set_commit_message ctxt commit_message >>= fun ctxt ->
return ctxt
let fitness = Fitness.get ctxt in
let message = Some (Format.asprintf "fitness <- %Ld" fitness) in
let fitness = Fitness.from_int64 fitness in
return { Updater.message ; context = ctxt.context ; fitness }
let rpc_services = Services.rpc_services

2
src/proto/demo/services.ml
View File

@ -45,7 +45,7 @@ let failing_service custom_root =
~output: (wrap_tzerror Data_encoding.empty)
RPC.Path.(custom_root / "failing")
let rpc_services : Context.t RPC.directory =
let rpc_services : Updater.rpc_context RPC.directory =
let dir = RPC.empty in
let dir =
RPC.register

6
src/proto/environment/context.mli
View File

@ -5,12 +5,6 @@ open Hash
include Persist.STORE
val get_fitness: t -> Fitness.fitness Lwt.t
val set_fitness: t -> Fitness.fitness -> t Lwt.t
val get_timestamp: t -> Time.t Lwt.t
val set_commit_message: t -> string -> t Lwt.t
val register_resolver:
'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit

2
src/proto/environment/data_encoding.mli
View File

@ -28,7 +28,9 @@ val empty : unit encoding
val unit : unit encoding
val constant : string -> unit encoding
val int8 : int encoding
val uint8 : int encoding
val int16 : int encoding
val uint16 : int encoding
val int31 : int encoding
val int32 : int32 encoding
val int64 : int64 encoding

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

@ -2,6 +2,7 @@
open Hash
(** The version agnostic toplevel structure of operations. *)
type shell_operation = {
net_id: Net_id.t ;
}
@ -18,12 +19,14 @@ 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 ;
(** The date at which this block has been forged. *)
operations: Operation_list_list_hash.t ;
(** The sequence of operations. *)
operations_hash: Operation_list_list_hash.t ;
(** The hash lf the merkle tree of operations. *)
fitness: MBytes.t list ;
(** The announced score of the block. As a sequence of sequences
of unsigned bytes. Ordered by length and then by contents
@ -37,6 +40,19 @@ type raw_block = {
}
val raw_block_encoding: raw_block Data_encoding.t
type validation_result = {
context: Context.t ;
fitness: Fitness.fitness ;
message: string option ;
}
type rpc_context = {
context: Context.t ;
level: Int32.t ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}
(** This is the signature of a Tezos protocol implementation. It has
access to the standard library and the Environment module. *)
module type PROTOCOL = sig
@ -99,6 +115,7 @@ module type PROTOCOL = sig
val begin_application :
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_fitness: Fitness.fitness ->
raw_block ->
validation_state tzresult Lwt.t
@ -110,6 +127,8 @@ 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 ->
validation_state tzresult Lwt.t
@ -123,10 +142,10 @@ module type PROTOCOL = sig
context that will be used as input for the validation of its
successor block candidates. *)
val finalize_block :
validation_state -> Context.t tzresult Lwt.t
validation_state -> validation_result tzresult Lwt.t
(** The list of remote procedures exported by this implementation *)
val rpc_services : Context.t RPC.directory
val rpc_services : rpc_context RPC.directory
val configure_sandbox :
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
@ -155,5 +174,10 @@ val compile : Protocol_hash.t -> component list -> bool Lwt.t
been previously compiled successfully. *)
val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t
val set_test_protocol: Context.t -> Protocol_hash.t -> Context.t Lwt.t
val fork_test_network: Context.t -> Context.t Lwt.t
(** Fork a test network. The forkerd network will use the current block
as genesis, and [protocol] as economic protocol. The network will
be destroyed when a (successor) block will have a timestamp greater
than [expiration]. The protocol must have been previously compiled
successfully. *)
val fork_test_network:
Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t

16
src/proto/genesis/data.ml
View File

@ -14,7 +14,7 @@ module Command = struct
| Activate of Protocol_hash.t
(* Activate a protocol as a testnet *)
| Activate_testnet of Protocol_hash.t
| Activate_testnet of Protocol_hash.t * Int64.t
let mk_case name args =
let open Data_encoding in
@ -22,7 +22,7 @@ module Command = struct
(fun o -> ((), o))
(fun ((), o) -> o)
(merge_objs
(obj1 (req "network" (constant name)))
(obj1 (req "command" (constant name)))
args)
let encoding =
@ -30,14 +30,18 @@ module Command = struct
union ~tag_size:`Uint8 [
case ~tag:0
(mk_case "activate"
(obj1 (req "hash" Protocol_hash.encoding)))
(obj1
(req "hash" Protocol_hash.encoding)))
(function (Activate hash) -> Some hash | _ -> None)
(fun hash -> Activate hash) ;
case ~tag:1
(mk_case "activate_testnet"
(obj1 (req "hash" Protocol_hash.encoding)))
(function (Activate_testnet hash) -> Some hash | _ -> None)
(fun hash -> Activate_testnet hash) ;
(obj2
(req "hash" Protocol_hash.encoding)
(req "validity_time" int64)))
(function (Activate_testnet (hash, delay)) -> Some (hash, delay)
| _ -> None)
(fun (hash, delay) -> Activate_testnet (hash, delay)) ;
]
let signed_encoding =

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

@ -45,9 +45,15 @@ type block = {
}
let max_block_length =
match Data_encoding.Binary.fixed_length Data.Command.signed_encoding with
| None -> assert false
| Some len -> len
Data_encoding.Binary.length
Data.Command.encoding
(Activate_testnet (Protocol_hash.hash_bytes [], 0L))
+
begin
match Data_encoding.Binary.fixed_length Ed25519.Signature.encoding with
| None -> assert false
| Some len -> len
end
let parse_block { Updater.shell ; proto } : block tzresult =
match Data_encoding.Binary.of_bytes Data.Command.signed_encoding proto with
@ -61,10 +67,10 @@ let check_signature ctxt { shell ; command ; signature } =
(Ed25519.Signature.check public_key signature bytes)
Invalid_signature
type validation_state = block * Context.t
type validation_state = Updater.validation_result
let current_context (_, ctxt) =
return ctxt
let current_context ({ context } : validation_state) =
return context
let precheck_block
~ancestor_context:_
@ -76,38 +82,39 @@ let precheck_block
let begin_application
~predecessor_context:ctxt
~predecessor_timestamp:_
~predecessor_fitness:_
raw_block =
Data.Init.may_initialize ctxt >>=? fun ctxt ->
Lwt.return (parse_block raw_block) >>=? fun block ->
return (block, ctxt)
check_signature ctxt block >>=? fun () ->
let fitness = raw_block.shell.fitness in
match block.command with
| Data.Command.Activate hash ->
let message =
Some (Format.asprintf "activate %a" Protocol_hash.pp_short hash) in
Updater.activate ctxt hash >>= fun ctxt ->
return { Updater.message ; context = ctxt ; fitness }
| Activate_testnet (hash, delay) ->
let message =
Some (Format.asprintf "activate testnet %a" Protocol_hash.pp_short hash) in
let expiration = Time.add raw_block.shell.timestamp delay in
Updater.fork_test_network ctxt hash expiration >>= fun ctxt ->
return { Updater.message ; context = ctxt ; fitness }
let begin_construction
~predecessor_context:_
~predecessor_context:context
~predecessor_timestamp:_
~predecessor_level:_
~predecessor_fitness:fitness
~predecessor:_
~timestamp:_ =
Lwt.return (Error []) (* absurd *)
(* Dummy result. *)
return { Updater.message = None ; context ; fitness }
let apply_operation _vctxt _ =
Lwt.return (Error []) (* absurd *)
let finalize_block (header, ctxt) =
check_signature ctxt header >>=? fun () ->
Data.Init.may_initialize ctxt >>=? fun ctxt ->
Context.set_fitness ctxt header.shell.fitness >>= fun ctxt ->
match header.command with
| Activate hash ->
let commit_message =
Format.asprintf "activate %a" Protocol_hash.pp_short hash in
Context.set_commit_message ctxt commit_message >>= fun ctxt ->
Updater.activate ctxt hash >>= fun ctxt ->
return ctxt
| Activate_testnet hash ->
let commit_message =
Format.asprintf "activate testnet %a" Protocol_hash.pp_short hash in
Context.set_commit_message ctxt commit_message >>= fun ctxt ->
Updater.set_test_protocol ctxt hash >>= fun ctxt ->
Updater.fork_test_network ctxt >>= fun ctxt ->
return ctxt
let finalize_block state = return state
let rpc_services = Services.rpc_services

13
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))
@ -53,18 +54,18 @@ let int64_to_bytes i =
MBytes.set_int64 b 0 i;
b
let operations =
let operations_hash =
Operation_list_list_hash.compute [Operation_list_hash.empty]
let rpc_services : Context.t RPC.directory =
let rpc_services : Updater.rpc_context RPC.directory =
let dir = RPC.empty in
let dir =
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_hash } in
let bytes = Data.Command.forge shell command in
RPC.Answer.return bytes) in
dir

20
test/p2p/test_p2p_connection.ml
View File

@ -64,7 +64,7 @@ let sync_nodes nodes =
sync_nodes nodes >>= function
| Ok () | Error (Exn End_of_file :: _) ->
return ()
| Error e as err ->
| Error _ as err ->
Lwt.return err
let run_nodes client server =
@ -147,7 +147,7 @@ module Low_level = struct
return ()
let server _ch sched socket =
raw_accept sched socket >>= fun (fd, point) ->
raw_accept sched socket >>= fun (fd, _point) ->
P2p_io_scheduler.write fd simple_msg >>=? fun () ->
P2p_io_scheduler.close fd >>=? fun _ ->
return ()
@ -190,7 +190,7 @@ module Kicked = struct
let encoding = Data_encoding.bytes
let server _ch sched socket =
accept sched socket >>=? fun (info, auth_fd) ->
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>= fun conn ->
_assert (Kick.is_rejected conn) __LOC__ "" >>=? fun () ->
return ()
@ -212,7 +212,7 @@ module Simple_message = struct
let simple_msg2 = MBytes.create (1 lsl 4)
let server ch sched socket =
accept sched socket >>=? fun (info, auth_fd) ->
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.write_sync conn simple_msg >>=? fun () ->
P2p_connection.read conn >>=? fun (_msg_size, msg) ->
@ -242,7 +242,7 @@ module Close_on_read = struct
let simple_msg = MBytes.create (1 lsl 4)
let server _ch sched socket =
accept sched socket >>=? fun (info, auth_fd) ->
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.close conn >>= fun _stat ->
return ()
@ -266,7 +266,7 @@ module Close_on_write = struct
let simple_msg = MBytes.create (1 lsl 4)
let server ch sched socket =
accept sched socket >>=? fun (info, auth_fd) ->
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.close conn >>= fun _stat ->
sync ch >>=? fun ()->
@ -291,8 +291,8 @@ module Garbled_data = struct
let garbled_msg = MBytes.create (1 lsl 4)
let server ch sched socket =
accept sched socket >>=? fun (info, auth_fd) ->
let server _ch sched socket =
accept sched socket >>=? fun (_info, auth_fd) ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.raw_write_sync conn garbled_msg >>=? fun () ->
P2p_connection.read conn >>= fun err ->
@ -300,7 +300,7 @@ module Garbled_data = struct
P2p_connection.close conn >>= fun _stat ->
return ()
let client ch sched addr port =
let client _ch sched addr port =
connect sched addr port id2 >>=? fun auth_fd ->
P2p_connection.accept auth_fd encoding >>=? fun conn ->
P2p_connection.read conn >>= fun err ->
@ -328,7 +328,7 @@ let spec = Arg.[
let main () =
let open Utils in
let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
let usage_msg = "Usage: %s.\nArguments are:" in
Arg.parse spec anon_fun usage_msg ;
Test.run "p2p-connection." [

8
test/p2p/test_p2p_connection_pool.ml
View File

@ -54,7 +54,7 @@ let sync_nodes nodes =
sync_nodes nodes >>= function
| Ok () | Error (Exn End_of_file :: _) ->
return ()
| Error e as err ->
| Error _ as err ->
Lwt.return err
let detach_node f points n =
@ -100,7 +100,7 @@ let detach_node f points n =
return ()
end
let detach_nodes ?(sync = 0) run_node points =
let detach_nodes run_node points =
let open Utils in
let clients = List.length points in
Lwt_list.map_p
@ -196,7 +196,7 @@ module Random_connections = struct
let rem = ref (n * total) in
iter_p (fun point -> connect_random pool total rem point n) points
let node repeat channel pool points =
let node repeat _channel pool points =
lwt_log_info "Begin random connections." >>= fun () ->
connect_random_all pool points repeat >>=? fun () ->
lwt_log_info "Random connections OK." >>= fun () ->
@ -267,7 +267,7 @@ let spec = Arg.[
let main () =
let open Utils in
let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
Arg.parse spec anon_fun usage_msg ;
let ports = !port -- (!port + !clients - 1) in

33
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
@ -393,24 +393,24 @@ module Mining = struct
Client_node_rpcs.Blocks.info rpc_config block >>=? fun bi ->
let seed_nonce_hash = Nonce.hash seed_nonce in
Client_proto_rpcs.Context.next_level rpc_config block >>=? fun level ->
let operations =
let operations_hash =
Operation_list_list_hash.compute
[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 = Int32.of_int priority } in
{ Store.Block_header.net_id = bi.net_id ; predecessor = bi.hash ;
timestamp ; fitness ; operations_hash ;
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
~net:bi.net_id
~predecessor:bi.hash
~timestamp
~fitness
~operations
~operations_hash
~level:level.level
~priority:priority
~priority
~seed_nonce_hash
~proof_of_work_nonce
() >>=? fun unsigned_header ->
@ -422,6 +422,7 @@ module Mining = struct
let mine
?(force = false)
?(operations = [])
~fitness_gap
contract
block =
Client_mining_blocks.info rpc_config block >>=? fun bi ->
@ -434,12 +435,11 @@ module Mining = struct
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 ->
(Fitness_repr.to_int64 bi.fitness >|=
(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 @@ List.length operations + 1) in
Level.pp_full Format.str_formatter bi.level ;
Int64.add fitness (Int64.of_int fitness_gap) in
inject_block
~force
~priority
@ -453,7 +453,7 @@ module Mining = struct
let endorsement_reward contract block =
Client_mining_blocks.info rpc_config block >>=? fun bi ->
get_first_priority bi.level.level contract block >>=? fun prio ->
Mining.endorsement_reward ~block_priority:(Int32.of_int prio) >|=
Mining.endorsement_reward ~block_priority:prio >|=
Register_client_embedded_proto_alpha.wrap_error >>|?
Tez.to_cents
@ -553,3 +553,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 ()

7
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
@ -122,6 +122,7 @@ module Mining : sig
val mine :
?force:bool ->
?operations:Operation_hash.t list ->
fitness_gap:int ->
Account.t ->
Client_node_rpcs.Blocks.block ->
Block_hash.t tzresult Lwt.t
@ -191,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

55
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
@ -16,25 +17,25 @@ module Assert = Helpers.Assert
let test_double_endorsement contract block =
(* Double endorsement for the same level *)
Helpers.Mining.mine contract block >>=? fun b1 ->
Helpers.Mining.mine ~fitness_gap:1 contract block >>=? fun b1 ->
(* branch root *)
Helpers.Mining.mine contract (`Hash b1) >>=? fun b2 ->
Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b1) >>=? fun b2 ->
(* changing branch *)
Helpers.Mining.mine contract (`Hash b1) >>=? fun b2' ->
Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b1) >>=? fun b2' ->
(* branch root *)
Helpers.Endorse.endorse ~force:true contract (`Hash b2) >>=? fun ops ->
Helpers.Mining.mine ~operations:[ ops ] contract (`Hash b2) >>=? fun _b3 ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] contract (`Hash b2) >>=? fun _b3 ->
Helpers.Endorse.endorse ~force:true contract (`Hash b2') >>=? fun ops ->
Helpers.Mining.mine ~operations:[ ops ] contract (`Hash b2') >>=? fun b3' ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] contract (`Hash b2') >>=? fun b3' ->
Helpers.Endorse.endorse ~force:true contract (`Hash b3') >>=? fun ops ->
Helpers.Mining.mine ~operations:[ ops ] contract (`Hash b3') >>=? fun b4' ->
Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] contract (`Hash b3') >>=? fun b4' ->
(* TODO: Inject double endorsement op ! *)
Helpers.Mining.mine contract (`Hash b4')
Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b4')
(* FIXME: Mining.Invalid_signature is unclassified *)
let test_invalid_signature block =
@ -47,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 account block >>= fun res ->
Helpers.Mining.mine ~fitness_gap:1 account block >>= fun res ->
Assert.generic_economic_error ~msg:__LOC__ res ;
return ()
@ -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
@ -94,20 +95,24 @@ let test_endorsement_rewards
get_endorser_except_b1 accounts >>=? fun (account0, slot0) ->
Helpers.Account.balance account0 >>=? fun balance0 ->
Helpers.Endorse.endorse ~slot:slot0 ~force:true account0 block >>=? fun ops ->
Helpers.Mining.mine ~operations:[ ops ] b1 block >>=? fun head0 ->
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 ->
get_endorser_except_b1 accounts >>=? fun (account1, slot1) ->
Helpers.Account.balance account1 >>=? fun balance1 ->
Helpers.Endorse.endorse ~slot:slot1 ~force:true account1 block0 >>=? fun ops ->
Helpers.Mining.mine ~operations:[ ops ] b1 block0 >>=? fun head1 ->
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 ->
@ -117,8 +122,12 @@ let test_endorsement_rewards
Assert.balance_equal ~msg:__LOC__ account2
(Int64.sub (Tez.to_cents balance2) bond) >>=? fun () ->
Helpers.Mining.mine b1 (`Hash head1) >>=? fun head2 ->
Helpers.Mining.mine b1 (`Hash head2) >>=? fun head3 ->
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 b1 (`Hash head3) >>=? fun head ->
Helpers.Mining.mine 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 ->
@ -144,18 +155,22 @@ let test_endorsement_rewards
Helpers.Account.balance account3 >>=? fun balance3 ->
Helpers.Endorse.endorse
~slot:slot3 ~force:true account3 (`Hash head) >>=? fun ops ->
Helpers.Mining.mine ~operations:[ ops ] b1 (`Hash head) >>=? fun new_head ->
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 ->
get_endorser_except_b1 accounts >>=? fun (account4, slot4) ->
Helpers.Account.balance account4 >>=? fun _balance4 ->
Helpers.Endorse.endorse ~slot:slot4 ~force:true account4 (`Hash fork) >>=? fun ops ->
Helpers.Mining.mine ~operations:[ ops ] b1 (`Hash fork) >>=? fun _new_fork ->
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 b1 (`Hash new_head) >>=? fun head ->
Helpers.Mining.mine b1 (`Hash head) >>=? fun head ->
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/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 b1 blkid >>=? fun blkh ->
Helpers.Mining.mine ~fitness_gap:1 b1 blkid >>=? 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 b1 blkid >>=? fun blkh ->
Helpers.Mining.mine ~fitness_gap:1 b1 blkid >>=? fun blkh ->
let foo = Helpers.Account.create "foo" in
let bar = Helpers.Account.create "bar" in

5
test/shell/test_context.ml
View File

@ -37,6 +37,8 @@ let net_id = Net_id.of_block_hash genesis_block
(** Context creation *)
let commit = commit ~time:Time.epoch ~message:""
let block2 =
Block_hash.of_hex_exn
"2222222222222222222222222222222222222222222222222222222222222222"
@ -87,8 +89,7 @@ let wrap_context_init f base_dir =
Context.commit_genesis idx
~id:genesis.block
~time:genesis.time
~protocol:genesis.protocol
~test_protocol:genesis.protocol >>= fun _ ->
~protocol:genesis.protocol >>= fun _ ->
create_block2 idx >>= fun () ->
create_block3a idx >>= fun () ->
create_block3b idx >>= fun () ->

15
test/shell/test_state.ml
View File

@ -38,7 +38,7 @@ let net_id = Net_id.of_block_hash genesis_block
let incr_fitness fitness =
let new_fitness =
match fitness with
| [ _ ; fitness ] ->
| [ fitness ] ->
Pervasives.(
Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
|> Utils.unopt ~default:0L
@ -47,7 +47,7 @@ let incr_fitness fitness =
)
| _ -> Data_encoding.Binary.to_bytes Data_encoding.int64 1L
in
[ MBytes.of_string "\000" ; new_fitness ]
[ new_fitness ]
let incr_timestamp timestamp =
Time.add timestamp (Int64.add 1L (Random.int64 10L))
@ -62,15 +62,16 @@ let operation op =
Data_encoding.Binary.to_bytes Store.Operation.encoding op
let block _state ?(operations = []) pred_hash pred name : Store.Block_header.t =
let operations =
let operations_hash =
Operation_list_list_hash.compute
[Operation_list_hash.compute operations] in
let fitness = incr_fitness pred.Store.Block_header.shell.fitness in
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 } ;
timestamp ; operations_hash ; fitness } ;
proto = MBytes.of_string name ;
}
@ -133,14 +134,15 @@ let build_chain state tbl otbl pred names =
let block _state ?(operations = []) (pred: State.Valid_block.t) name
: State.Block_header.t =
let operations =
let operations_hash =
Operation_list_list_hash.compute
[Operation_list_hash.compute operations] in
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 } ;
timestamp ; operations_hash ; fitness } ;
proto = MBytes.of_string name ;
}
@ -166,6 +168,7 @@ let build_valid_chain state tbl vtbl otbl pred names =
Proto.begin_application
~predecessor_context: pred.context
~predecessor_timestamp: pred.timestamp
~predecessor_fitness: pred.fitness
block >>=? fun vstate ->
(* no operations *)
Proto.finalize_block vstate

5
test/shell/test_store.ml
View File

@ -89,13 +89,14 @@ let test_operation s =
(** Block store *)
let lolblock ?(operations = []) header =
let operations =
let operations_hash =
Operation_list_list_hash.compute
[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 ;
predecessor = genesis_block ; operations_hash ;
fitness = [MBytes.of_string @@ string_of_int @@ String.length header;
MBytes.of_string @@ string_of_int @@ 12] } ;
proto = MBytes.of_string header ;