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

Shell-level commit messages and timestamps.

Browse Source
This commit is contained in:
Benjamin Canou 2017-03-03 13:05:20 +01:00
parent 2e96a1377e
commit 015f3edff3
25 changed files with 189 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -58,21 +58,21 @@ type t = context
(*-- Version Access and Update -----------------------------------------------*) (*-- Version Access and Update -----------------------------------------------*)
let genesis_block_key = ["genesis";"block"]
let genesis_protocol_key = ["genesis";"protocol"]
let genesis_time_key = ["genesis";"time"]
let current_protocol_key = ["protocol"] let current_protocol_key = ["protocol"]
let current_fitness_key = ["fitness"] let current_fitness_key = ["fitness"]
let current_timestamp_key = ["timestamp"]
let current_test_protocol_key = ["test_protocol"] let current_test_protocol_key = ["test_protocol"]
let current_test_network_key = ["test_network"] let current_test_network_key = ["test_network"]
let current_test_network_expiration_key = ["test_network_expiration"] let current_test_network_expiration_key = ["test_network_expiration"]
let current_fork_test_network_key = ["fork_test_network"] let current_fork_test_network_key = ["fork_test_network"]
let transient_commit_message_key = ["message"]
let exists { repo } key = let exists { repo } key =
GitStore.of_branch_id GitStore.of_branch_id
Irmin.Task.none (Block_hash.to_b58check key) repo >>= fun t -> Irmin.Task.none (Block_hash.to_b58check key) repo >>= fun t ->
let store = t () in let store = t () in
GitStore.read store genesis_block_key >>= function GitStore.read store current_protocol_key >>= function
| Some _ -> | Some _ ->
Lwt.return true Lwt.return true
| None -> | None ->
@ -108,22 +108,58 @@ let exists index key =
Block_hash.pp_short key exists >>= fun () -> Block_hash.pp_short key exists >>= fun () ->
Lwt.return exists 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 Preexistent_context of Block_hash.t
exception Empty_head of Block_hash.t exception Empty_head of Block_hash.t
let commit block key context = let commit key context =
get_timestamp context >>= fun timestamp ->
get_fitness context >>= fun fitness ->
let task = let task =
Irmin.Task.create Irmin.Task.create ~date:(Time.to_seconds timestamp) ~owner:"Tezos" in
~date:(Time.to_seconds block.Store.Block_header.shell.timestamp)
~owner:"tezos" in
GitStore.clone task context.store (Block_hash.to_b58check key) >>= function GitStore.clone task context.store (Block_hash.to_b58check key) >>= function
| `Empty_head -> Lwt.fail (Empty_head key) | `Empty_head -> Lwt.fail (Empty_head key)
| `Duplicated_branch -> Lwt.fail (Preexistent_context key) | `Duplicated_branch -> Lwt.fail (Preexistent_context key)
| `Ok store -> | `Ok store ->
let msg = get_and_erase_commit_message context >>= fun (msg, context) ->
let msg = match msg with
| None ->
Format.asprintf "%a %a" Format.asprintf "%a %a"
Fitness.pp block.shell.fitness Fitness.pp fitness Block_hash.pp_short key
Block_hash.pp_short key in | Some msg -> msg in
GitStore.FunView.update_path (store msg) [] context.view GitStore.FunView.update_path (store msg) [] context.view
@ -144,10 +180,7 @@ let dir_mem ctxt key =
GitStore.FunView.dir_mem ctxt.view (data_key key) >>= fun v -> GitStore.FunView.dir_mem ctxt.view (data_key key) >>= fun v ->
Lwt.return v Lwt.return v
let raw_get ctxt key = let raw_get ctxt key = GitStore.FunView.get ctxt.view key
GitStore.FunView.get ctxt.view key >>= function
| None -> Lwt.return_none
| Some bytes -> Lwt.return (Some bytes)
let get t key = raw_get t (data_key key) let get t key = raw_get t (data_key key)
let raw_set ctxt key data = let raw_set ctxt key data =
@ -188,11 +221,7 @@ let commit_genesis index ~id:block ~time ~protocol ~test_protocol =
index.repo >>= fun t -> index.repo >>= fun t ->
let store = t () in let store = t () in
GitStore.FunView.of_path store [] >>= fun view -> GitStore.FunView.of_path store [] >>= fun view ->
GitStore.FunView.set view genesis_block_key GitStore.FunView.set view current_timestamp_key
(Block_hash.to_bytes block) >>= fun view ->
GitStore.FunView.set view genesis_protocol_key
(Protocol_hash.to_bytes protocol) >>= fun view ->
GitStore.FunView.set view genesis_time_key
(MBytes.of_string (Time.to_notation time)) >>= fun view -> (MBytes.of_string (Time.to_notation time)) >>= fun view ->
GitStore.FunView.set view current_protocol_key GitStore.FunView.set view current_protocol_key
(Protocol_hash.to_bytes protocol) >>= fun view -> (Protocol_hash.to_bytes protocol) >>= fun view ->
@ -214,17 +243,6 @@ let get_protocol v =
let set_protocol v key = let set_protocol v key =
raw_set v current_protocol_key (Protocol_hash.to_bytes key) raw_set v current_protocol_key (Protocol_hash.to_bytes key)
let get_fitness v =
raw_get v 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 v data =
raw_set v current_fitness_key
(Data_encoding.Binary.to_bytes Fitness.encoding data)
let get_test_protocol v = let get_test_protocol v =
raw_get v current_test_protocol_key >>= function raw_get v current_test_protocol_key >>= function
| None -> assert false | None -> assert false
@ -260,23 +278,11 @@ let read_and_reset_fork_test_network v =
let fork_test_network v = let fork_test_network v =
raw_set v current_fork_test_network_key (MBytes.of_string "fork") raw_set v current_fork_test_network_key (MBytes.of_string "fork")
let get_genesis_block v =
raw_get v genesis_block_key >>= function
| None -> assert false
| Some block -> Lwt.return (Block_hash.of_bytes_exn block)
let get_genesis_time v =
raw_get v genesis_time_key >>= function
| None -> assert false
| Some time -> Lwt.return (Time.of_notation_exn (MBytes.to_string time))
let init_test_network v ~time ~genesis = let init_test_network v ~time ~genesis =
get_test_protocol v >>= fun test_protocol -> get_test_protocol v >>= fun test_protocol ->
del_test_network_expiration v >>= fun v -> del_test_network_expiration v >>= fun v ->
set_protocol v test_protocol >>= fun v -> set_protocol v test_protocol >>= fun v ->
raw_set v genesis_time_key set_timestamp v time >>= fun v ->
(MBytes.of_string (Time.to_notation time)) >>= fun v ->
raw_set v genesis_block_key (Block_hash.to_bytes genesis) >>= fun v ->
let task = let task =
Irmin.Task.create Irmin.Task.create
~date:(Time.to_seconds time) ~date:(Time.to_seconds time)

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

@ -40,7 +40,7 @@ exception Preexistent_context of Block_hash.t
val exists: index -> Block_hash.t -> bool Lwt.t val exists: index -> Block_hash.t -> bool Lwt.t
val checkout: index -> Block_hash.t -> context option Lwt.t val checkout: index -> Block_hash.t -> context option Lwt.t
val checkout_exn: index -> Block_hash.t -> context Lwt.t val checkout_exn: index -> Block_hash.t -> context Lwt.t
val commit: Store.Block_header.t -> Block_hash.t -> context -> unit Lwt.t val commit: Block_hash.t -> context -> unit Lwt.t
(** {2 Predefined Fields} ****************************************************) (** {2 Predefined Fields} ****************************************************)
@ -61,11 +61,13 @@ val del_test_network_expiration: context -> context Lwt.t
val read_and_reset_fork_test_network: context -> (bool * context) Lwt.t val read_and_reset_fork_test_network: context -> (bool * context) Lwt.t
val fork_test_network: context -> context Lwt.t val fork_test_network: context -> context Lwt.t
val get_genesis_time: context -> Time.t Lwt.t
val get_genesis_block: context -> Block_hash.t Lwt.t
val set_fitness: context -> Fitness.fitness -> context Lwt.t val set_fitness: context -> Fitness.fitness -> context Lwt.t
val get_fitness: context -> Fitness.fitness 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: val init_test_network:
context -> time:Time.t -> genesis:Block_hash.t -> context tzresult Lwt.t context -> time:Time.t -> genesis:Block_hash.t -> context tzresult Lwt.t

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

@ -28,7 +28,8 @@ let preapply
Lwt.return_none Lwt.return_none
| Ok p -> Lwt.return (Some p)) | Ok p -> Lwt.return (Some p))
ops >>= fun ops -> ops >>= fun ops ->
Proto.preapply ctxt block timestamp sort (Utils.unopt_list ops) >>= function Context.set_timestamp ctxt timestamp >>= fun ctxt ->
Proto.preapply ctxt block sort (Utils.unopt_list ops) >>= function
| Ok (ctxt, r) -> | Ok (ctxt, r) ->
lwt_debug "<- prevalidate (%d/%d/%d/%d)" lwt_debug "<- prevalidate (%d/%d/%d/%d)"
(List.length r.Updater.applied) (List.length r.Updater.applied)
@ -105,7 +106,8 @@ let create net_db =
let timestamp = ref (Time.now ()) in let timestamp = ref (Time.now ()) in
begin begin
let (module Proto) = protocol in let (module Proto) = protocol in
Proto.preapply head.context head.hash !timestamp false [] >|= function Context.set_timestamp head.context !timestamp >>= fun ctxt ->
Proto.preapply ctxt head.hash false [] >|= function
| Error _ -> ref head.context | Error _ -> ref head.context
| Ok (ctxt, _) -> ref ctxt | Ok (ctxt, _) -> ref ctxt
end >>= fun context -> end >>= fun context ->
@ -214,9 +216,9 @@ let create net_db =
(Proto.parse_operation h b (Proto.parse_operation h b
|> record_trace_exn (Invalid_operation h))) |> record_trace_exn (Invalid_operation h)))
(Operation_hash.Map.bindings ops) >>=? fun parsed_ops -> (Operation_hash.Map.bindings ops) >>=? fun parsed_ops ->
Context.set_timestamp !context (Time.now ()) >>= fun ctxt ->
Proto.preapply Proto.preapply
!context !head.hash (Time.now ()) ctxt !head.hash true parsed_ops >>=? fun (ctxt, res) ->
true parsed_ops >>=? fun (ctxt, res) ->
let register h = let register h =
let op = Operation_hash.Map.find h ops in let op = Operation_hash.Map.find h ops in
Distributed_db.Operation.inject Distributed_db.Operation.inject
@ -287,8 +289,10 @@ let create net_db =
timestamp := Time.now () ; timestamp := Time.now () ;
(* Tag the context as a prevalidation context. *) (* Tag the context as a prevalidation context. *)
let (module Proto) = new_protocol in let (module Proto) = new_protocol in
Proto.preapply new_head.context Context.set_timestamp
new_head.hash !timestamp false [] >>= function new_head.context !timestamp >>= fun ctxt ->
Proto.preapply
ctxt new_head.hash false [] >>= function
| Error _ -> set_context new_head.context | Error _ -> set_context new_head.context
| Ok (ctxt, _) -> set_context ctxt) | Ok (ctxt, _) -> set_context ctxt)
q >>= fun () -> q >>= fun () ->

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

@ -864,7 +864,7 @@ module Valid_block = struct
block_header_store hash >>= fun _marked -> block_header_store hash >>= fun _marked ->
(* TODO fail if the block was previsouly stored ... ??? *) (* TODO fail if the block was previsouly stored ... ??? *)
(* Let's commit the context. *) (* Let's commit the context. *)
Context.commit block hash context >>= fun () -> Context.commit hash context >>= fun () ->
(* Update the chain state. *) (* Update the chain state. *)
let store = net_state.chain_store in let store = net_state.chain_store in
let predecessor = block.shell.predecessor in let predecessor = block.shell.predecessor in

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

@ -143,14 +143,16 @@ let apply_block net db
begin begin
match pred.protocol with match pred.protocol with
| None -> fail (State.Unknown_protocol pred.protocol_hash) | None -> fail (State.Unknown_protocol pred.protocol_hash)
| Some p -> return (p, pred.context) | Some p ->
Context.set_timestamp pred.context block.shell.timestamp >>= fun c ->
return (p, c)
end >>=? fun ((module Proto), patched_context) -> end >>=? fun ((module Proto), patched_context) ->
lwt_debug "validation of %a: Proto %a" lwt_debug "validation of %a: Proto %a"
Block_hash.pp_short hash Block_hash.pp_short hash
Protocol_hash.pp_short Proto.hash >>= fun () -> Protocol_hash.pp_short Proto.hash >>= fun () ->
lwt_debug "validation of %a: parsing header..." lwt_debug "validation of %a: parsing header..."
Block_hash.pp_short hash >>= fun () -> Block_hash.pp_short hash >>= fun () ->
Lwt.return (Proto.parse_block block) >>=? fun parsed_header -> Lwt.return (Proto.parse_block block pred.timestamp) >>=? fun parsed_header ->
lwt_debug "validation of %a: parsing operations..." lwt_debug "validation of %a: parsing operations..."
Block_hash.pp_short hash >>= fun () -> Block_hash.pp_short hash >>= fun () ->
map2_s map2_s

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

@ -89,8 +89,9 @@ module type PROTOCOL = sig
produce a pre-decomposed value of the high level, protocol defined produce a pre-decomposed value of the high level, protocol defined
{!block} type. It does not have access to the storage {!block} type. It does not have access to the storage
context. It may store the hash and raw bytes for later signature context. It may store the hash and raw bytes for later signature
verification by {!apply} or {!preapply}. *) verification by {!apply} or {!preapply}. The timestamp of the
val parse_block : raw_block -> block tzresult predecessor block is also provided for early delay checks. *)
val parse_block : raw_block -> Time.t -> block tzresult
(** The parsing / preliminary validation function for (** The parsing / preliminary validation function for
operations. Similar to {!parse_block}. *) operations. Similar to {!parse_block}. *)
@ -107,14 +108,13 @@ module type PROTOCOL = sig
(** The auxiliary protocol entry point that validates pending (** The auxiliary protocol entry point that validates pending
operations out of blocks. This function tries to apply the all operations out of blocks. This function tries to apply the all
operations in the given order, and returns which applications have operations in the given order, and returns which applications have
suceeded and which ones have failed. The first three parameters suceeded and which ones have failed. The first two parameters
are a context in which to apply the operations, the hash of the are a context in which to apply the operations and the hash of the
preceding block and the date at which the operations are preceding block. This function is used by the shell for accepting or
executed. This function is used by the shell for accepting or
dropping operations, as well as the mining client to check that a dropping operations, as well as the mining client to check that a
sequence of operations forms a valid block. *) sequence of operations forms a valid block. *)
val preapply : val preapply :
Context.t -> Block_hash.t -> Time.t -> bool -> operation list -> Context.t -> Block_hash.t -> bool -> operation list ->
(Context.t * error preapply_result) tzresult Lwt.t (Context.t * error preapply_result) tzresult Lwt.t
(** The list of remote procedures exported by this implementation *) (** The list of remote procedures exported by this implementation *)

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

@ -33,11 +33,11 @@ let register (module Proto : Protocol.PACKED_PROTOCOL) =
let module V = struct let module V = struct
include Proto include Proto
include Make(Proto) include Make(Proto)
let parse_block d = parse_block d |> wrap_error let parse_block d t = parse_block d t |> wrap_error
let parse_operation h b = parse_operation h b |> wrap_error let parse_operation h b = parse_operation h b |> wrap_error
let apply c h ops = apply c h ops >|= wrap_error let apply c h ops = apply c h ops >|= wrap_error
let preapply c h t b ops = let preapply c h b ops =
(preapply c h t b ops >|= wrap_error) >>=? fun (ctxt, r) -> (preapply c h b ops >|= wrap_error) >>=? fun (ctxt, r) ->
return (ctxt, Updater.map_result (fun l -> [Ecoproto_error l]) r) return (ctxt, Updater.map_result (fun l -> [Ecoproto_error l]) r)
let configure_sandbox c j = let configure_sandbox c j =
configure_sandbox c j >|= wrap_error configure_sandbox c j >|= wrap_error

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

@ -213,23 +213,21 @@ let may_start_new_cycle ctxt =
Seed.compute_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt -> Seed.compute_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt ->
Roll.clear_cycle ctxt last_cycle >>=? fun ctxt -> Roll.clear_cycle ctxt last_cycle >>=? fun ctxt ->
Roll.freeze_rolls_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt -> Roll.freeze_rolls_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt ->
Timestamp.get_current ctxt >>=? fun timestamp -> Timestamp.get_current ctxt >>= fun timestamp ->
Lwt.return (Timestamp.(timestamp +? (Constants.time_before_reward ctxt))) Lwt.return (Timestamp.(timestamp +? (Constants.time_before_reward ctxt)))
>>=? fun reward_date -> >>=? fun reward_date ->
Reward.set_reward_time_for_cycle Reward.set_reward_time_for_cycle
ctxt last_cycle reward_date >>=? fun ctxt -> ctxt last_cycle reward_date >>=? fun ctxt ->
return ctxt return ctxt
let apply_main ctxt accept_failing_script block operations = let apply_main ctxt accept_failing_script block pred_timestamp operations =
(* read only checks *) (* read only checks *)
Mining.check_proof_of_work_stamp ctxt block >>=? fun () -> Mining.check_proof_of_work_stamp ctxt block >>=? fun () ->
Mining.check_fitness_gap ctxt block >>=? fun () -> Mining.check_fitness_gap ctxt block >>=? fun () ->
Mining.check_mining_rights ctxt block >>=? fun delegate_pkh -> Mining.check_mining_rights ctxt block pred_timestamp >>=? fun delegate_pkh ->
Mining.check_signature ctxt block delegate_pkh >>=? fun () -> Mining.check_signature ctxt block delegate_pkh >>=? fun () ->
(* automatic bonds payment *) (* automatic bonds payment *)
Mining.pay_mining_bond ctxt block delegate_pkh >>=? fun ctxt -> Mining.pay_mining_bond ctxt block delegate_pkh >>=? fun ctxt ->
(* set timestamp *)
Timestamp.set_current ctxt block.shell.timestamp >>=? fun ctxt ->
(* do effectful stuff *) (* do effectful stuff *)
Fitness.increase ctxt >>=? fun ctxt -> Fitness.increase ctxt >>=? fun ctxt ->
let priority = snd block.proto.mining_slot in let priority = snd block.proto.mining_slot in
@ -255,14 +253,20 @@ let apply_main ctxt accept_failing_script block operations =
type error += Internal_error of string type error += Internal_error of string
let apply ctxt accept_failing_script block operations = let apply ctxt accept_failing_script block pred_timestamp operations =
(init ctxt >>=? fun ctxt -> (init ctxt >>=? fun ctxt ->
get_prevalidation ctxt >>= function get_prevalidation ctxt >>= function
| true -> | true ->
fail (Internal_error "we should not call `apply` after `preapply`!") fail (Internal_error "we should not call `apply` after `preapply`!")
| false -> | false ->
apply_main ctxt accept_failing_script block operations >>=? fun ctxt -> apply_main ctxt accept_failing_script block pred_timestamp operations >>=? fun ctxt ->
finalize ctxt) Level.current ctxt >>=? fun { level } ->
let level = Raw_level.diff level Raw_level.root in
Fitness.get ctxt >>=? fun fitness ->
let commit_message =
(* TODO: add more info ? *)
Format.asprintf "lvl %ld, fit %Ld" level fitness in
finalize ~commit_message ctxt)
let empty_result = let empty_result =
{ Updater.applied = []; { Updater.applied = [];
@ -338,7 +342,7 @@ let prevalidate ctxt pred_block sort operations =
return (ctxt, r)) in return (ctxt, r)) in
loop ctxt operations loop ctxt operations
let preapply ctxt pred_block timestamp sort operations = let preapply ctxt pred_block sort operations =
let result = let result =
init ctxt >>=? fun ctxt -> init ctxt >>=? fun ctxt ->
begin begin
@ -349,7 +353,6 @@ let preapply ctxt pred_block timestamp sort operations =
Fitness.increase ctxt >>=? fun ctxt -> Fitness.increase ctxt >>=? fun ctxt ->
return ctxt return ctxt
end >>=? fun ctxt -> end >>=? fun ctxt ->
Timestamp.set_current ctxt timestamp >>=? fun ctxt ->
prevalidate ctxt pred_block sort operations >>=? fun (ctxt, r) -> prevalidate ctxt pred_block sort operations >>=? fun (ctxt, r) ->
(* TODO should accept failing script in the last round ? (* TODO should accept failing script in the last round ?
or: what should we export to let the miner decide *) or: what should we export to let the miner decide *)

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

@ -17,8 +17,6 @@ let version_value = "alpha"
let initialize ~from_genesis (ctxt:Context.t) = let initialize ~from_genesis (ctxt:Context.t) =
Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt -> Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
Storage.prepare ctxt >>=? fun store -> Storage.prepare ctxt >>=? fun store ->
Storage.get_genesis_time store >>= fun time ->
Storage.Current_timestamp.init_set store time >>=? fun store ->
begin begin
if from_genesis then if from_genesis then
Lwt.return store Lwt.return store

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

@ -17,10 +17,12 @@ let max_operation_data_length =
Tezos_context.Operation.max_operation_data_length Tezos_context.Operation.max_operation_data_length
type block = type block =
Tezos_context.Block.header { header : Tezos_context.Block.header ;
pred_timestamp : Time.t }
let parse_block = let parse_block raw_header pred_timestamp =
Tezos_context.Block.parse_header Tezos_context.Block.parse_header raw_header >>? fun header ->
Ok { header ; pred_timestamp }
let max_number_of_operations = let max_number_of_operations =
Tezos_context.Constants.max_number_of_operations Tezos_context.Constants.max_number_of_operations
@ -30,7 +32,8 @@ let max_block_length =
let rpc_services = Services_registration.rpc_services let rpc_services = Services_registration.rpc_services
let apply ctxt header ops = Apply.apply ctxt true header ops let apply ctxt block ops =
Apply.apply ctxt true block.header block.pred_timestamp ops
let preapply = Apply.preapply let preapply = Apply.preapply

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

@ -19,8 +19,23 @@ type error +=
| Bad_delegate | Bad_delegate
| Invalid_slot_durations_constant | Invalid_slot_durations_constant
let minimal_time c priority = let () =
Timestamp.get_current c >>=? fun prev_timestamp -> register_error_kind
`Branch
~id:"mining.too_early"
~title:"Block forged too early"
~description:"The block timestamp is before the first slot \
for this miner at this level"
~pp:(fun ppf (r, p) ->
Format.fprintf ppf "Block forged too early (%a is before %a)"
Time.pp_hum p Time.pp_hum r)
Data_encoding.(obj2
(req "minimal" Time.encoding)
(req "provided" Time.encoding))
(function Too_early (r, p) -> Some (r, p) | _ -> None)
(fun (r, p) -> Too_early (r, p))
let minimal_time c priority pred_timestamp =
let rec cumsum_slot_durations acc durations p = let rec cumsum_slot_durations acc durations p =
if Compare.Int32.(=) p 0l then if Compare.Int32.(=) p 0l then
ok acc ok acc
@ -35,23 +50,24 @@ let minimal_time c priority =
cumsum_slot_durations acc durations p in cumsum_slot_durations acc durations p in
Lwt.return Lwt.return
(cumsum_slot_durations (cumsum_slot_durations
prev_timestamp (Constants.slot_durations c) priority) pred_timestamp (Constants.slot_durations c) priority)
let check_timestamp c priority timestamp = let check_timestamp c priority pred_timestamp =
minimal_time c priority >>=? fun minimal_time -> minimal_time c priority pred_timestamp >>=? fun minimal_time ->
Tezos_context.Timestamp.get_current c >>= fun timestamp ->
fail_unless Timestamp.(minimal_time <= timestamp) fail_unless Timestamp.(minimal_time <= timestamp)
(Too_early (minimal_time, timestamp)) (Too_early (minimal_time, timestamp))
let check_mining_rights c let check_mining_rights c
{ Block.shell = { timestamp } ; { Block.proto = { mining_slot = (raw_level, priority) } }
proto = { mining_slot = (raw_level, priority) } } = pred_timestamp =
Level.current c >>=? fun current_level -> Level.current c >>=? fun current_level ->
fail_unless fail_unless
Raw_level.(raw_level = current_level.level) Raw_level.(raw_level = current_level.level)
(Invalid_level (current_level.Level.level, raw_level)) >>=? fun () -> (Invalid_level (current_level.Level.level, raw_level)) >>=? fun () ->
let level = Level.from_raw c raw_level in let level = Level.from_raw c raw_level in
Roll.mining_rights_owner c level ~priority >>=? fun delegate -> Roll.mining_rights_owner c level ~priority >>=? fun delegate ->
check_timestamp c priority timestamp >>=? fun () -> check_timestamp c priority pred_timestamp >>=? fun () ->
return delegate return delegate
let pay_mining_bond c let pay_mining_bond c

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

@ -14,7 +14,7 @@ open Misc
val paying_priorities: context -> int32 list val paying_priorities: context -> int32 list
val minimal_time: val minimal_time:
context -> int32 -> Time.t tzresult Lwt.t context -> int32 -> Time.t -> Time.t tzresult Lwt.t
val pay_mining_bond: val pay_mining_bond:
context -> context ->
@ -25,13 +25,13 @@ val pay_mining_bond:
val pay_endorsement_bond: val pay_endorsement_bond:
context -> public_key_hash -> (context * Tez.t) tzresult Lwt.t context -> public_key_hash -> (context * Tez.t) tzresult Lwt.t
(** [check_mining_rights] verifies that: (** [check_mining_rights ctxt block pred_timestamp] verifies that:
* the contract that owned the roll at cycle start has the block signer as delegate. * the contract that owned the roll at cycle start has the block signer as delegate.
* the timestamp is coherent with the announced slot. * the timestamp is coherent with the announced slot.
* the bond have been payed if the slot is below [Constants.first_free_mining_slot]. * the bond have been payed if the slot is below [Constants.first_free_mining_slot].
*) *)
val check_mining_rights: val check_mining_rights:
context -> Block.header -> public_key_hash tzresult Lwt.t context -> Block.header -> Time.t -> public_key_hash tzresult Lwt.t
(** [check_signing_rights c slot contract] verifies that: (** [check_signing_rights c slot contract] verifies that:
* the slot is valid; * the slot is valid;

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

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

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

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

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

@ -174,7 +174,11 @@ 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 -> 0l | Some p -> Int32.of_int p in
Mining.minimal_time ctxt prio Mining.minimal_time ctxt prio
let () = register1 Services.Helpers.minimal_timestamp minimal_timestamp let () = register1
Services.Helpers.minimal_timestamp
(fun ctxt slot ->
Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
minimal_timestamp ctxt slot timestamp)
let () = let () =
(* ctxt accept_failing_script miner_contract pred_block block_prio operation *) (* ctxt accept_failing_script miner_contract pred_block block_prio operation *)
@ -299,10 +303,11 @@ let () =
Lwt_list.filter_map_p (fun x -> x) @@ Lwt_list.filter_map_p (fun x -> x) @@
List.mapi List.mapi
(fun prio c -> (fun prio c ->
Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
Mining.minimal_time Mining.minimal_time
ctxt (Int32.of_int prio) >>= function ctxt (Int32.of_int prio) timestamp >>= function
| Error _ -> Lwt.return None | Error _ -> Lwt.return None
| Ok timestamp -> Lwt.return (Some (c, timestamp))) | Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp)))
slots slots
end >>= fun timed_slots -> end >>= fun timed_slots ->
return (raw_level, timed_slots)) return (raw_level, timed_slots))
@ -336,7 +341,8 @@ let mining_rights_for_delegate
let raw_level = level.level in let raw_level = level.level in
Lwt_list.map_p Lwt_list.map_p
(fun priority -> (fun priority ->
Mining.minimal_time ctxt priority >>= function Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
Mining.minimal_time ctxt priority timestamp >>= function
| Ok time -> Lwt.return (raw_level, Int32.to_int priority, Some time) | Ok time -> Lwt.return (raw_level, Int32.to_int priority, Some time)
| Error _ -> Lwt.return (raw_level, Int32.to_int priority, None)) | Error _ -> Lwt.return (raw_level, Int32.to_int priority, None))
priorities >>= fun priorities -> priorities >>= fun priorities ->

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

@ -22,6 +22,10 @@ let get_fitness (c, _) = Context.get_fitness c
let set_fitness (c, csts) v = let set_fitness (c, csts) v =
Context.set_fitness c v >>= fun c -> Lwt.return (c, csts) 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 get_sandboxed c = let get_sandboxed c =
Context.get c sandboxed_key >>= function Context.get c sandboxed_key >>= function
| None -> return None | None -> return None
@ -56,7 +60,6 @@ module Key = struct
let store_root tail = version :: "store" :: tail let store_root tail = version :: "store" :: tail
let current_level = store_root ["level"] let current_level = store_root ["level"]
let current_timestamp = store_root ["timestamp"]
let current_fitness = store_root ["fitness"] let current_fitness = store_root ["fitness"]
let global_counter = store_root ["global_counter"] let global_counter = store_root ["global_counter"]
@ -139,14 +142,6 @@ module Current_level =
let encoding = Raw_level_repr.encoding let encoding = Raw_level_repr.encoding
end) end)
module Current_timestamp =
Make_single_data_storage(struct
type value = Time_repr.t
let name = "timestamp"
let key = Key.current_timestamp
let encoding = Time_repr.encoding
end)
module Current_fitness = module Current_fitness =
Make_single_data_storage(struct Make_single_data_storage(struct
type value = int64 type value = int64
@ -515,9 +510,6 @@ module Rewards = struct
end end
let get_genesis_block (c, _) = Context.get_genesis_block c
let get_genesis_time (c, _) = Context.get_genesis_time c
let activate (c, constants) h = let activate (c, constants) h =
Updater.activate c h >>= fun c -> Lwt.return (c, constants) Updater.activate c h >>= fun c -> Lwt.return (c, constants)
let fork_test_network (c, constants) = let fork_test_network (c, constants) =

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

@ -37,6 +37,10 @@ val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t
val get_fitness : t -> Fitness.fitness Lwt.t val get_fitness : t -> Fitness.fitness Lwt.t
val set_fitness : t -> Fitness.fitness -> t 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 get_prevalidation : t -> bool Lwt.t val get_prevalidation : t -> bool Lwt.t
val set_prevalidation : t -> t Lwt.t val set_prevalidation : t -> t Lwt.t
@ -51,11 +55,6 @@ module Current_level : Single_data_storage
with type value = Raw_level_repr.t with type value = Raw_level_repr.t
and type context := t and type context := t
(** The level of the current block *)
module Current_timestamp : Single_data_storage
with type value = Time.t
and type context := t
module Roll : sig module Roll : sig
(** Storage from this submodule must only be accessed through the (** Storage from this submodule must only be accessed through the
@ -269,9 +268,6 @@ module Rewards : sig
end end
val get_genesis_time: t -> Time.t Lwt.t
val get_genesis_block: t -> Block_hash.t Lwt.t
val activate: t -> Protocol_hash.t -> t Lwt.t val activate: t -> Protocol_hash.t -> t Lwt.t
val set_test_protocol: 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 -> t Lwt.t

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

@ -19,13 +19,12 @@ end
module Tez = Tez_repr module Tez = Tez_repr
module Period = Period_repr module Period = Period_repr
module Timestamp = struct module Timestamp = struct
include Time_repr include Time_repr
let get_current = Storage.Current_timestamp.get let get_current = Storage.get_timestamp
let set_current = Storage.Current_timestamp.set
end end
include Operation_repr include Operation_repr
module Operation = Operation_repr module Operation = Operation_repr
module Block = Block_repr module Block = Block_repr
@ -121,7 +120,15 @@ end
module Asset = Asset_repr module Asset = Asset_repr
let init = Init_storage.may_initialize let init = Init_storage.may_initialize
let finalize c = return (Storage.recover c)
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 configure_sandbox = Init_storage.configure_sandbox let configure_sandbox = Init_storage.configure_sandbox
let get_prevalidation = Storage.get_prevalidation let get_prevalidation = Storage.get_prevalidation
let set_prevalidation = Storage.set_prevalidation let set_prevalidation = Storage.set_prevalidation

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

@ -68,8 +68,7 @@ module Timestamp : sig
val of_seconds: string -> time option val of_seconds: string -> time option
val to_seconds: time -> string val to_seconds: time -> string
val set_current: context -> Time.t -> context tzresult Lwt.t val get_current: context -> Time.t Lwt.t
val get_current: context -> Time.t tzresult Lwt.t
end end
@ -581,7 +580,7 @@ module Reward : sig
end end
val init: Context.t -> context tzresult Lwt.t val init: Context.t -> context tzresult Lwt.t
val finalize: context -> Context.t tzresult Lwt.t val finalize: ?commit_message:string -> context -> Context.t tzresult Lwt.t
val configure_sandbox: val configure_sandbox:
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t

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

@ -15,7 +15,7 @@ type block = unit
let max_block_length = 42 let max_block_length = 42
let max_number_of_operations = 42 let max_number_of_operations = 42
let parse_block _ = Ok () let parse_block _ _pred_timestamp = Ok ()
let parse_operation h _ = Ok h let parse_operation h _ = Ok h
module Fitness = struct module Fitness = struct
@ -66,9 +66,13 @@ end
let apply ctxt () _operations = let apply ctxt () _operations =
Fitness.increase ctxt >>=? fun 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 return ctxt
let preapply context _block_pred _timestamp _sort operations = let preapply context _block_pred _sort operations =
Lwt.return Lwt.return
(Ok (Ok
(context, (context,

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

@ -8,8 +8,8 @@ include Persist.STORE
val get_fitness: t -> Fitness.fitness Lwt.t val get_fitness: t -> Fitness.fitness Lwt.t
val set_fitness: t -> Fitness.fitness -> t Lwt.t val set_fitness: t -> Fitness.fitness -> t Lwt.t
val get_genesis_time: t -> Time.t Lwt.t val get_timestamp: t -> Time.t Lwt.t
val get_genesis_block: t -> Block_hash.t Lwt.t val set_commit_message: t -> string -> t Lwt.t
val register_resolver: val register_resolver:
'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit 'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit

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

@ -83,8 +83,9 @@ module type PROTOCOL = sig
produce a pre-decomposed value of the high level, protocol defined produce a pre-decomposed value of the high level, protocol defined
{!block} type. It does not have access to the storage {!block} type. It does not have access to the storage
context. It may store the hash and raw bytes for later signature context. It may store the hash and raw bytes for later signature
verification by {!apply} or {!preapply}. *) verification by {!apply} or {!preapply}. The timestamp of the
val parse_block : raw_block -> block tzresult predecessor block is also provided for early delay checks. *)
val parse_block : raw_block -> Time.t -> block tzresult
(** The parsing / preliminary validation function for (** The parsing / preliminary validation function for
operations. Similar to {!parse_block}. *) operations. Similar to {!parse_block}. *)
@ -100,14 +101,13 @@ module type PROTOCOL = sig
(** The auxiliary protocol entry point that validates pending (** The auxiliary protocol entry point that validates pending
operations out of blocks. This function tries to apply the all operations out of blocks. This function tries to apply the all
operations in the given order, and returns which applications have operations in the given order, and returns which applications have
suceeded and which ones have failed. The first three parameters suceeded and which ones have failed. The first two parameters
are a context in which to apply the operations, the hash of the are a context in which to apply the operations and the hash of the
preceding block and the date at which the operations are preceding block. This function is used by the shell for accepting or
executed. This function is used by the shell for accepting or
dropping operations, as well as the mining client to check that a dropping operations, as well as the mining client to check that a
sequence of operations forms a valid block. *) sequence of operations forms a valid block. *)
val preapply : val preapply :
Context.t -> Block_hash.t -> Time.t -> bool -> operation list -> Context.t -> Block_hash.t -> bool -> operation list ->
(Context.t * error preapply_result) tzresult Lwt.t (Context.t * error preapply_result) tzresult Lwt.t
(** The list of remote procedures exported by this implementation *) (** The list of remote procedures exported by this implementation *)

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

@ -48,7 +48,7 @@ let max_block_length =
| None -> assert false | None -> assert false
| Some len -> len | Some len -> len
let parse_block { Updater.shell ; proto } : block tzresult = let parse_block { Updater.shell ; proto } _pred_timestamp : block tzresult =
match Data_encoding.Binary.of_bytes Data.Command.signed_encoding proto with match Data_encoding.Binary.of_bytes Data.Command.signed_encoding proto with
| None -> Error [Parsing_error] | None -> Error [Parsing_error]
| Some (command, signature) -> Ok { shell ; command ; signature } | Some (command, signature) -> Ok { shell ; command ; signature }
@ -66,14 +66,20 @@ let apply ctxt header _ops =
Context.set_fitness ctxt header.shell.fitness >>= fun ctxt -> Context.set_fitness ctxt header.shell.fitness >>= fun ctxt ->
match header.command with match header.command with
| Activate hash -> | 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 -> Updater.activate ctxt hash >>= fun ctxt ->
return ctxt return ctxt
| Activate_testnet hash -> | 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.set_test_protocol ctxt hash >>= fun ctxt ->
Updater.fork_test_network ctxt >>= fun ctxt -> Updater.fork_test_network ctxt >>= fun ctxt ->
return ctxt return ctxt
let preapply ctxt _block_pred _timestamp _sort _ops = let preapply ctxt _block_pred _sort _ops =
return ( ctxt, return ( ctxt,
{ Updater.applied = [] ; { Updater.applied = [] ;
refused = Operation_hash.Map.empty ; refused = Operation_hash.Map.empty ;

17
test/test_context.ml
View File

@ -41,17 +41,6 @@ let block2 =
Block_hash.of_hex_exn Block_hash.of_hex_exn
"2222222222222222222222222222222222222222222222222222222222222222" "2222222222222222222222222222222222222222222222222222222222222222"
let faked_block : Store.Block_header.t = {
shell = {
net_id ;
predecessor = genesis_block ;
operations = [] ;
fitness = [] ;
timestamp = Time.of_seconds 0L ;
} ;
proto = MBytes.of_string "" ;
}
let create_block2 idx = let create_block2 idx =
checkout idx genesis_block >>= function checkout idx genesis_block >>= function
| None -> | None ->
@ -60,7 +49,7 @@ let create_block2 idx =
set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt -> set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt ->
set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt -> set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt ->
set ctxt ["version";] (MBytes.of_string "0.0") >>= fun ctxt -> set ctxt ["version";] (MBytes.of_string "0.0") >>= fun ctxt ->
commit faked_block block2 ctxt commit block2 ctxt
let block3a = let block3a =
Block_hash.of_hex_exn Block_hash.of_hex_exn
@ -73,7 +62,7 @@ let create_block3a idx =
| Some ctxt -> | Some ctxt ->
del ctxt ["a"; "b"] >>= fun ctxt -> del ctxt ["a"; "b"] >>= fun ctxt ->
set ctxt ["a"; "d"] (MBytes.of_string "Mars") >>= fun ctxt -> set ctxt ["a"; "d"] (MBytes.of_string "Mars") >>= fun ctxt ->
commit faked_block block3a ctxt commit block3a ctxt
let block3b = let block3b =
Block_hash.of_hex_exn Block_hash.of_hex_exn
@ -90,7 +79,7 @@ let create_block3b idx =
| Some ctxt -> | Some ctxt ->
del ctxt ["a"; "c"] >>= fun ctxt -> del ctxt ["a"; "c"] >>= fun ctxt ->
set ctxt ["a"; "d"] (MBytes.of_string "Février") >>= fun ctxt -> set ctxt ["a"; "d"] (MBytes.of_string "Février") >>= fun ctxt ->
commit faked_block block3b ctxt commit block3b ctxt
let wrap_context_init f base_dir = let wrap_context_init f base_dir =
let root = base_dir // "context" in let root = base_dir // "context" in

2
test/test_state.ml
View File

@ -129,7 +129,7 @@ let build_valid_chain state tbl vtbl otbl pred names =
State.Block_header.read_opt state hash >>= fun block' -> State.Block_header.read_opt state hash >>= fun block' ->
Assert.equal_block ~msg:__LOC__ (Some block) block' ; Assert.equal_block ~msg:__LOC__ (Some block) block' ;
Hashtbl.add tbl name (hash, block) ; Hashtbl.add tbl name (hash, block) ;
Lwt.return (Proto.parse_block block) >>=? fun block -> Lwt.return (Proto.parse_block block pred.timestamp) >>=? fun block ->
Proto.apply pred.context block [] >>=? fun ctxt -> Proto.apply pred.context block [] >>=? fun ctxt ->
State.Valid_block.store state hash ctxt >>=? fun _vblock -> State.Valid_block.store state hash ctxt >>=? fun _vblock ->
State.Valid_block.read state hash >>=? fun vblock -> State.Valid_block.read state hash >>=? fun vblock ->