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

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

@ -58,21 +58,21 @@ type t = context
(*-- 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_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 ->
let store = t () in
GitStore.read store genesis_block_key >>= function
GitStore.read store current_protocol_key >>= function
| Some _ ->
Lwt.return true
| None ->
@ -108,22 +108,58 @@ 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 block key context =
let commit key context =
get_timestamp context >>= fun timestamp ->
get_fitness context >>= fun fitness ->
let task =
Irmin.Task.create
~date:(Time.to_seconds block.Store.Block_header.shell.timestamp)
~owner:"tezos" in
Irmin.Task.create ~date:(Time.to_seconds timestamp) ~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 ->
let msg =
Format.asprintf "%a %a"
Fitness.pp block.shell.fitness
Block_hash.pp_short key in
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
@ -144,10 +180,7 @@ let dir_mem ctxt key =
GitStore.FunView.dir_mem ctxt.view (data_key key) >>= fun v ->
Lwt.return v
let raw_get ctxt key =
GitStore.FunView.get ctxt.view key >>= function
| None -> Lwt.return_none
| Some bytes -> Lwt.return (Some bytes)
let raw_get ctxt key = GitStore.FunView.get ctxt.view key
let get t key = raw_get t (data_key key)
let raw_set ctxt key data =
@ -188,11 +221,7 @@ let commit_genesis index ~id:block ~time ~protocol ~test_protocol =
index.repo >>= fun t ->
let store = t () in
GitStore.FunView.of_path store [] >>= fun view ->
GitStore.FunView.set view genesis_block_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
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 ->
@ -214,17 +243,6 @@ let get_protocol v =
let set_protocol v 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 =
raw_get v current_test_protocol_key >>= function
| None -> assert false
@ -260,23 +278,11 @@ let read_and_reset_fork_test_network v =
let fork_test_network v =
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 =
get_test_protocol v >>= fun test_protocol ->
del_test_network_expiration v >>= fun v ->
set_protocol v test_protocol >>= fun v ->
raw_set v genesis_time_key
(MBytes.of_string (Time.to_notation time)) >>= fun v ->
raw_set v genesis_block_key (Block_hash.to_bytes genesis) >>= fun v ->
set_timestamp v time >>= fun v ->
let task =
Irmin.Task.create
~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 checkout: index -> Block_hash.t -> context option 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} ****************************************************)
@ -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 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 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

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

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

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

@ -864,7 +864,7 @@ module Valid_block = struct
block_header_store hash >>= fun _marked ->
(* TODO fail if the block was previsouly stored ... ??? *)
(* Let's commit the context. *)
Context.commit block hash context >>= fun () ->
Context.commit hash context >>= fun () ->
(* Update the chain state. *)
let store = net_state.chain_store 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
match pred.protocol with
| 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) ->
lwt_debug "validation of %a: Proto %a"
Block_hash.pp_short hash
Protocol_hash.pp_short Proto.hash >>= fun () ->
lwt_debug "validation of %a: parsing header..."
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..."
Block_hash.pp_short hash >>= fun () ->
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
{!block} type. It does not have access to the storage
context. It may store the hash and raw bytes for later signature
verification by {!apply} or {!preapply}. *)
val parse_block : raw_block -> block tzresult
verification by {!apply} or {!preapply}. The timestamp of the
predecessor block is also provided for early delay checks. *)
val parse_block : raw_block -> Time.t -> block tzresult
(** The parsing / preliminary validation function for
operations. Similar to {!parse_block}. *)
@ -107,14 +108,13 @@ module type PROTOCOL = sig
(** The auxiliary protocol entry point that validates pending
operations out of blocks. This function tries to apply the all
operations in the given order, and returns which applications have
suceeded and which ones have failed. The first three parameters
are a context in which to apply the operations, the hash of the
preceding block and the date at which the operations are
executed. This function is used by the shell for accepting or
suceeded and which ones have failed. The first two parameters
are a context in which to apply the operations and the hash of the
preceding block. This function is used by the shell for accepting or
dropping operations, as well as the mining client to check that a
sequence of operations forms a valid block. *)
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
(** 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
include 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 apply c h ops = apply c h ops >|= wrap_error
let preapply c h t b ops =
(preapply c h t b ops >|= wrap_error) >>=? fun (ctxt, r) ->
let preapply c h b ops =
(preapply c h b ops >|= wrap_error) >>=? fun (ctxt, r) ->
return (ctxt, Updater.map_result (fun l -> [Ecoproto_error l]) r)
let configure_sandbox c j =
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 ->
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 ->
Timestamp.get_current ctxt >>= fun timestamp ->
Lwt.return (Timestamp.(timestamp +? (Constants.time_before_reward ctxt)))
>>=? fun reward_date ->
Reward.set_reward_time_for_cycle
ctxt last_cycle reward_date >>=? fun 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 *)
Mining.check_proof_of_work_stamp 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 () ->
(* automatic bonds payment *)
Mining.pay_mining_bond ctxt block delegate_pkh >>=? fun ctxt ->
(* set timestamp *)
Timestamp.set_current ctxt block.shell.timestamp >>=? fun ctxt ->
(* do effectful stuff *)
Fitness.increase ctxt >>=? fun ctxt ->
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
let apply ctxt accept_failing_script block operations =
let apply ctxt accept_failing_script block pred_timestamp operations =
(init ctxt >>=? fun ctxt ->
get_prevalidation ctxt >>= function
| true ->
fail (Internal_error "we should not call `apply` after `preapply`!")
| false ->
apply_main ctxt accept_failing_script block operations >>=? fun ctxt ->
finalize ctxt)
apply_main ctxt accept_failing_script block pred_timestamp operations >>=? fun 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 =
{ Updater.applied = [];
@ -338,7 +342,7 @@ let prevalidate ctxt pred_block sort operations =
return (ctxt, r)) in
loop ctxt operations
let preapply ctxt pred_block timestamp sort operations =
let preapply ctxt pred_block sort operations =
let result =
init ctxt >>=? fun ctxt ->
begin
@ -349,7 +353,6 @@ let preapply ctxt pred_block timestamp sort operations =
Fitness.increase ctxt >>=? fun ctxt ->
return ctxt
end >>=? fun ctxt ->
Timestamp.set_current ctxt timestamp >>=? fun ctxt ->
prevalidate ctxt pred_block sort operations >>=? fun (ctxt, r) ->
(* TODO should accept failing script in the last round ?
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) =
Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
Storage.prepare ctxt >>=? fun store ->
Storage.get_genesis_time store >>= fun time ->
Storage.Current_timestamp.init_set store time >>=? fun store ->
begin
if from_genesis then
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
type block =
Tezos_context.Block.header
{ header : Tezos_context.Block.header ;
pred_timestamp : Time.t }
let parse_block =
Tezos_context.Block.parse_header
let parse_block raw_header pred_timestamp =
Tezos_context.Block.parse_header raw_header >>? fun header ->
Ok { header ; pred_timestamp }
let 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 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

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

@ -19,8 +19,23 @@ type error +=
| Bad_delegate
| Invalid_slot_durations_constant
let minimal_time c priority =
Timestamp.get_current c >>=? fun prev_timestamp ->
let () =
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 =
if Compare.Int32.(=) p 0l then
ok acc
@ -35,23 +50,24 @@ let minimal_time c priority =
cumsum_slot_durations acc durations p in
Lwt.return
(cumsum_slot_durations
prev_timestamp (Constants.slot_durations c) priority)
pred_timestamp (Constants.slot_durations c) priority)
let check_timestamp c priority timestamp =
minimal_time c priority >>=? fun minimal_time ->
let check_timestamp c priority pred_timestamp =
minimal_time c priority pred_timestamp >>=? fun minimal_time ->
Tezos_context.Timestamp.get_current c >>= fun timestamp ->
fail_unless Timestamp.(minimal_time <= timestamp)
(Too_early (minimal_time, timestamp))
let check_mining_rights c
{ Block.shell = { timestamp } ;
proto = { mining_slot = (raw_level, priority) } } =
{ Block.proto = { mining_slot = (raw_level, priority) } }
pred_timestamp =
Level.current c >>=? fun current_level ->
fail_unless
Raw_level.(raw_level = current_level.level)
(Invalid_level (current_level.Level.level, raw_level)) >>=? fun () ->
let level = Level.from_raw c raw_level in
Roll.mining_rights_owner c level ~priority >>=? fun delegate ->
check_timestamp c priority timestamp >>=? fun () ->
check_timestamp c priority pred_timestamp >>=? fun () ->
return delegate
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 minimal_time:
context -> int32 -> Time.t tzresult Lwt.t
context -> int32 -> Time.t -> Time.t tzresult Lwt.t
val pay_mining_bond:
context ->
@ -25,13 +25,13 @@ val pay_mining_bond:
val pay_endorsement_bond:
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 timestamp is coherent with the announced slot.
* the bond have been payed if the slot is below [Constants.first_free_mining_slot].
*)
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:
* 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)
let pay_due_rewards c =
Storage.Current_timestamp.get c >>=? fun timestamp ->
Storage.get_timestamp c >>= fun timestamp ->
let rec loop c cycle =
Storage.Rewards.Date.get_option c cycle >>=? function
| None ->

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

@ -479,7 +479,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 ->
Timestamp.get_current ctxt >>= fun now ->
logged_return (Item (now, rest), qta - 1, ctxt)
| Check_signature, Item (key, Item ((signature, message), rest)) ->
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
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 () =
(* ctxt accept_failing_script miner_contract pred_block block_prio operation *)
@ -299,10 +303,11 @@ let () =
Lwt_list.filter_map_p (fun x -> x) @@
List.mapi
(fun prio c ->
Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
Mining.minimal_time
ctxt (Int32.of_int prio) >>= function
ctxt (Int32.of_int prio) timestamp >>= function
| Error _ -> Lwt.return None
| Ok timestamp -> Lwt.return (Some (c, timestamp)))
| Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp)))
slots
end >>= fun timed_slots ->
return (raw_level, timed_slots))
@ -336,7 +341,8 @@ let mining_rights_for_delegate
let raw_level = level.level in
Lwt_list.map_p
(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)
| Error _ -> Lwt.return (raw_level, Int32.to_int priority, None))
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 =
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 =
Context.get c sandboxed_key >>= function
| None -> return None
@ -56,7 +60,6 @@ module Key = struct
let store_root tail = version :: "store" :: tail
let current_level = store_root ["level"]
let current_timestamp = store_root ["timestamp"]
let current_fitness = store_root ["fitness"]
let global_counter = store_root ["global_counter"]
@ -139,14 +142,6 @@ module Current_level =
let encoding = Raw_level_repr.encoding
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 =
Make_single_data_storage(struct
type value = int64
@ -515,9 +510,6 @@ module Rewards = struct
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 =
Updater.activate c h >>= fun c -> Lwt.return (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 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 set_prevalidation : t -> t Lwt.t
@ -51,11 +55,6 @@ module Current_level : Single_data_storage
with type value = Raw_level_repr.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
(** Storage from this submodule must only be accessed through the
@ -269,9 +268,6 @@ module Rewards : sig
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 set_test_protocol: t -> Protocol_hash.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 Period = Period_repr
module Timestamp = struct
include Time_repr
let get_current = Storage.Current_timestamp.get
let set_current = Storage.Current_timestamp.set
let get_current = Storage.get_timestamp
end
include Operation_repr
module Operation = Operation_repr
module Block = Block_repr
@ -121,7 +120,15 @@ end
module Asset = Asset_repr
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 get_prevalidation = Storage.get_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 to_seconds: time -> string
val set_current: context -> Time.t -> context tzresult Lwt.t
val get_current: context -> Time.t tzresult Lwt.t
val get_current: context -> Time.t Lwt.t
end
@ -581,7 +580,7 @@ module Reward : sig
end
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:
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_number_of_operations = 42
let parse_block _ = Ok ()
let parse_block _ _pred_timestamp = Ok ()
let parse_operation h _ = Ok h
module Fitness = struct
@ -66,9 +66,13 @@ end
let apply ctxt () _operations =
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 preapply context _block_pred _timestamp _sort operations =
let preapply context _block_pred _sort operations =
Lwt.return
(Ok
(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 set_fitness: t -> Fitness.fitness -> t Lwt.t
val get_genesis_time: t -> Time.t Lwt.t
val get_genesis_block: t -> Block_hash.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

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
{!block} type. It does not have access to the storage
context. It may store the hash and raw bytes for later signature
verification by {!apply} or {!preapply}. *)
val parse_block : raw_block -> block tzresult
verification by {!apply} or {!preapply}. The timestamp of the
predecessor block is also provided for early delay checks. *)
val parse_block : raw_block -> Time.t -> block tzresult
(** The parsing / preliminary validation function for
operations. Similar to {!parse_block}. *)
@ -100,14 +101,13 @@ module type PROTOCOL = sig
(** The auxiliary protocol entry point that validates pending
operations out of blocks. This function tries to apply the all
operations in the given order, and returns which applications have
suceeded and which ones have failed. The first three parameters
are a context in which to apply the operations, the hash of the
preceding block and the date at which the operations are
executed. This function is used by the shell for accepting or
suceeded and which ones have failed. The first two parameters
are a context in which to apply the operations and the hash of the
preceding block. This function is used by the shell for accepting or
dropping operations, as well as the mining client to check that a
sequence of operations forms a valid block. *)
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
(** 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
| 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
| None -> Error [Parsing_error]
| 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 ->
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 preapply ctxt _block_pred _timestamp _sort _ops =
let preapply ctxt _block_pred _sort _ops =
return ( ctxt,
{ Updater.applied = [] ;
refused = Operation_hash.Map.empty ;

17
test/test_context.ml
View File

@ -41,17 +41,6 @@ let block2 =
Block_hash.of_hex_exn
"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 =
checkout idx genesis_block >>= function
| None ->
@ -60,7 +49,7 @@ let create_block2 idx =
set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt ->
set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt ->
set ctxt ["version";] (MBytes.of_string "0.0") >>= fun ctxt ->
commit faked_block block2 ctxt
commit block2 ctxt
let block3a =
Block_hash.of_hex_exn
@ -73,7 +62,7 @@ let create_block3a idx =
| Some ctxt ->
del ctxt ["a"; "b"] >>= fun ctxt ->
set ctxt ["a"; "d"] (MBytes.of_string "Mars") >>= fun ctxt ->
commit faked_block block3a ctxt
commit block3a ctxt
let block3b =
Block_hash.of_hex_exn
@ -90,7 +79,7 @@ let create_block3b idx =
| Some ctxt ->
del ctxt ["a"; "c"] >>= 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 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' ->
Assert.equal_block ~msg:__LOC__ (Some block) 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 ->
State.Valid_block.store state hash ctxt >>=? fun _vblock ->
State.Valid_block.read state hash >>=? fun vblock ->