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

Proto: explicit fitness/timestamp in the signature

Browse Source 
This remove the data fomr the context where they "duplicate" the
block header.
This commit is contained in:
Grégoire Henry 2017-04-10 12:14:11 +02:00
parent 1409fbadbc
commit a731a47d3c
38 changed files with 342 additions and 420 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -84,15 +84,11 @@ 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
Irmin.Task.none (Block_hash.to_b58check key) repo >>= fun t ->
@ -134,59 +130,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
@ -267,18 +221,15 @@ let init ?patch_context ~root =
}
let commit_genesis index ~id:block ~time ~protocol ~test_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
@ -334,7 +285,6 @@ 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)

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

@ -40,7 +40,11 @@ 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} ****************************************************)
@ -58,16 +62,9 @@ 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
(* FIXME split in two (reset after commit *)
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

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

@ -278,9 +278,8 @@ 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 ->
let operations =
let pv_result, _ = Prevalidator.operations pv in
Some [ pv_result.applied ] in
@ -291,29 +290,36 @@ module RPC = struct
protocol = Some protocol ;
fitness ; operations ; timestamp }
let get_context node block =
let rpc_context block : Updater.rpc_context =
{ context = block.State.Valid_block.context ;
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 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
Lwt.return (Some { Updater.context ; fitness ; timestamp })
let operations node block =
match block with
@ -417,8 +423,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 +431,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 +441,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 =

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

@ -135,7 +135,8 @@ let start_prevalidation
{ State.Valid_block.protocol ;
hash = predecessor ;
context = predecessor_context ;
timestamp = predecessor_timestamp }
timestamp = predecessor_timestamp ;
fitness = predecessor_fitness }
~timestamp =
let (module Proto) =
match protocol with
@ -144,8 +145,10 @@ let start_prevalidation
Proto.begin_construction
~predecessor_context
~predecessor_timestamp
~predecessor_fitness
~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

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

@ -996,14 +996,13 @@ module Valid_block = struct
block_header_store
(net_state: net_state)
valid_block_watcher
hash context ttl =
hash { Updater.context ; fitness ; message } ttl =
(* 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
@ -1041,7 +1040,15 @@ module Valid_block = struct
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: %a"
Block_hash.pp_short hash
Fitness.pp fitness in
Context.commit
hash ~time:block.shell.timestamp ~message context >>= fun () ->
(* Update the chain state. *)
let store = net_state.chain_store in
let predecessor = block.shell.predecessor in

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

@ -284,7 +284,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

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

@ -181,10 +181,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 () ->
@ -201,8 +199,9 @@ let apply_block net db
lwt_debug "validation of %a: applying block..."
Block_hash.pp_short hash >>= fun () ->
Proto.begin_application
~predecessor_context:patched_context
~predecessor_context:pred.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 ->

86
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,12 @@ 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. *)
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. *)
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 +35,59 @@ 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 ;
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_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_fitness
~predecessor ~timestamp =
begin_construction
~predecessor_context ~predecessor_timestamp
~predecessor_fitness
~predecessor ~timestamp >|= wrap_error
let current_context c =
current_context c >|= wrap_error

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

@ -11,6 +11,18 @@ 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 ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}
module type PROTOCOL = Protocol.PROTOCOL
module type REGISTRED_PROTOCOL = sig
val hash: Protocol_hash.t
@ -30,20 +42,12 @@ 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. *)
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. *)
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

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

@ -18,20 +18,12 @@ 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. *)
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. *)
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 +33,18 @@ 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 ;
timestamp: Time.t ;
fitness: Fitness.fitness ;
}
module type PROTOCOL = Protocol.PROTOCOL
module type REGISTRED_PROTOCOL = sig
val hash: Protocol_hash.t

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

@ -51,7 +51,7 @@ 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 } ->
@ -238,7 +238,7 @@ let may_start_new_cycle 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,10 +254,10 @@ 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 reward = Mining.base_mining_reward ctxt ~priority in
@ -268,14 +268,7 @@ let finalize_application ctxt block miner op_count =
(* 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

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)

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

@ -14,15 +14,9 @@ let version_key = ["version"]
let version_value = "alpha"
(* This is the genesis protocol: initialise the state *)
let initialize ~from_genesis (ctxt:Context.t) =
let initialize ~timestamp ~fitness (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 ->
Storage.prepare ~timestamp ~fitness ctxt >>=? fun store ->
Level_storage.init store >>=? fun store ->
Roll_storage.init store >>=? fun store ->
Nonce_storage.init store >>=? fun store ->
@ -41,19 +35,20 @@ type error +=
| Incompatiple_protocol_version
| Unimplemented_sandbox_migration
let may_initialize ctxt =
let may_initialize ctxt ~timestamp ~fitness =
Context.get ctxt version_key >>= function
| None ->
(* This is the genesis protocol: The only acceptable preceding
version is an empty context *)
initialize ~from_genesis:false ctxt
initialize ~timestamp ~fitness ctxt
| Some bytes ->
let s = MBytes.to_string bytes in
if Compare.String.(s = version_value)
then Storage.prepare ctxt
if Compare.String.(s = version_value) then
Storage.prepare ~timestamp ~fitness ctxt
else if Compare.String.(s = "genesis") then
initialize ~from_genesis:true ctxt
else fail Incompatiple_protocol_version
initialize ~timestamp ~fitness ctxt
else
fail Incompatiple_protocol_version
let configure_sandbox ctxt json =
let json =
@ -63,8 +58,7 @@ let configure_sandbox ctxt json =
Context.get ctxt version_key >>= function
| None ->
Storage.set_sandboxed ctxt json >>= fun ctxt ->
initialize ~from_genesis:false ctxt >>=? fun ctxt ->
return (Storage.recover ctxt)
return ctxt
| Some _ ->
Storage.get_sandboxed ctxt >>=? function
| None ->

26
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,11 @@ 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 timestamp = header.shell.timestamp in
Tezos_context.init ~timestamp ~fitness:pred_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,11 +59,12 @@ let begin_application
let begin_construction
~predecessor_context:ctxt
~predecessor_timestamp:_
~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 ->
Tezos_context.init ~timestamp ~fitness:pred_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 =
@ -81,12 +84,19 @@ 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 ->
Tezos_context.Level.current ctxt >>=? fun { level } ->
let priority = block.proto.mining_slot.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 %ld, %d ops"
level fitness priority op_count in
let ctxt = Tezos_context.finalize ~commit_message ctxt in
return ctxt
let compare_operations op1 op2 =

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

@ -128,7 +128,7 @@ 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))
@ -273,8 +273,8 @@ 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))

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

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

19
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 ; timestamp ; fitness } =
Tezos_context.init ~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 :=
@ -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
@ -177,7 +180,7 @@ let minimal_timestamp 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 () =
@ -305,7 +308,7 @@ let () =
Lwt_list.filter_map_p (fun x -> x) @@
List.mapi
(fun prio c ->
Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
let timestamp = Timestamp.current ctxt in
Mining.minimal_time
ctxt (Int32.of_int prio) timestamp >>= function
| Error _ -> Lwt.return None
@ -343,7 +346,7 @@ 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))
priorities >>=? fun priorities ->

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

@ -12,19 +12,14 @@ open Storage_functors
let version = "v1"
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 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 current_timestamp { timestamp } = timestamp
let current_fitness { fitness } = fitness
let set_current_fitness c fitness = { c with fitness }
let get_sandboxed c =
Context.get c sandboxed_key >>= function
@ -38,22 +33,14 @@ 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 =
let prepare ~timestamp ~fitness (c : Context.t) : t tzresult Lwt.t =
Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
get_sandboxed c >>=? fun sandbox ->
Constants_repr.read sandbox >>=? function constants ->
return (c, constants)
let recover (c, _ : t) : Context.t = c
return { context = c ; constants ; timestamp ; fitness }
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 constants { constants } = constants
module Key = struct
@ -510,12 +497,12 @@ 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) =
Updater.fork_test_network c >>= fun c -> Lwt.return { s with context = c }
let set_test_protocol ({ context = c } as s) h =
Updater.set_test_protocol c h >>= fun c -> Lwt.return { s with context = c }
(** Resolver *)

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

@ -25,7 +25,10 @@
type t
(** Rerieves the state of the database and gives its abstract view *)
val prepare : Context.t -> t tzresult Lwt.t
val prepare :
timestamp: Time.t ->
fitness: Fitness.fitness ->
Context.t -> t tzresult Lwt.t
(** Returns the state of the database resulting of operations on its
abstract view *)
@ -34,15 +37,10 @@ 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_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

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

@ -11,7 +11,12 @@
open Misc
type context = Context.t * Constants_repr.constants
type context = {
context: Context.t ;
constants: Constants_repr.constants ;
timestamp: Time.t ;
fitness: Int64.t ;
}
(*-- Errors ------------------------------------------------------------------*)
@ -52,7 +57,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 +66,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 +85,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 +101,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 +236,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 +275,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 +297,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 +306,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 +322,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 +334,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

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

@ -14,7 +14,12 @@
indexed data and homgeneous data set). *)
type context = Context.t * Constants_repr.constants
type context = {
context: Context.t ;
constants: Constants_repr.constants ;
timestamp: Time.t ;
fitness: Int64.t ;
}
open Storage_sigs

15
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,17 +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

23
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
@ -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
@ -580,15 +578,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 ->
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

65
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,50 @@ 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_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

19
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 ;
}
@ -37,6 +38,18 @@ 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 ;
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 +112,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 +124,7 @@ module type PROTOCOL = sig
val begin_construction :
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_fitness: Fitness.fitness ->
predecessor: Block_hash.t ->
timestamp: Time.t ->
validation_state tzresult Lwt.t
@ -123,10 +138,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

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

@ -61,10 +61,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 +76,38 @@ 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 ->
let message =
Some (Format.asprintf "activate testnet %a" Protocol_hash.pp_short hash) in
Updater.set_test_protocol ctxt hash >>= fun ctxt ->
Updater.fork_test_network ctxt >>= fun ctxt ->
return { Updater.message ; context = ctxt ; fitness }
let begin_construction
~predecessor_context:_
~predecessor_context:context
~predecessor_timestamp:_
~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

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

@ -56,7 +56,7 @@ let int64_to_bytes i =
let operations =
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

2
test/proto_alpha/proto_alpha_helpers.ml
View File

@ -434,7 +434,7 @@ 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 @@

2
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"

5
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))
@ -166,6 +166,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