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

Proto/Env: Replace configure_sandbox by proper init

Browse Source
This commit is contained in:
Grégoire Henry 2018-04-06 11:40:34 +02:00
parent 6f0cc397ae
commit bf32659a6b
32 changed files with 268 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/bin_client/test/demo/main.ml
View File

@ -95,4 +95,10 @@ let finalize_block ctxt =
let rpc_services = RPC_directory.empty
let configure_sandbox ctxt _ = Lwt.return (Ok ctxt)
let init ctxt block_header =
let fitness = block_header.Block_header.fitness in
let message = None in
return { Updater.message ; context = ctxt ; fitness ;
max_operations_ttl = 0 ; max_operation_data_length = 0 ;
last_allowed_fork_level = 0l ;
}

9
src/bin_client/test/test_basic.sh
View File

@ -11,12 +11,11 @@ activate_alpha
sleep 2
#tests for the rpc service raw_context
$client rpc call '/blocks/head/raw_context/version' | assert '{ "content": "67656e65736973" }'
$client rpc call '/blocks/head/raw_context/version' | assert '{ "content": "616c706861" }'
$client rpc call '/blocks/head/raw_context/non-existent' | assert 'No service found at this URL'
$client rpc call '/blocks/head/raw_context?depth=2' | assert '{ "content":
{ "genesis_key":
"68b4bf512517497dbd944de6825ab0a0fed7ff51bdd6b77596a19cc9175ddd55",
"v1": { "sandboxed": null }, "version": "67656e65736973" } }'
$client rpc call '/blocks/head/raw_context/delegates/?depth=2' | assert '{ "content":
{ "02": { "29": null }, "a9": { "ce": null }, "c5": { "5c": null },
"da": { "c9": null }, "e7": { "67": null } } }'
$client rpc call '/blocks/head/raw_context/non-existent?depth=-1' | assert 'No service found at this URL'
$client rpc call '/blocks/head/raw_context/non-existent?depth=0' | assert 'No service found at this URL'

2
src/bin_client/test/test_injection.sh
View File

@ -14,7 +14,7 @@ show_logs="no"
sleep 2
# autogenerated from the demo source
protocol_version="Ps1ZDZdgRP4PFDkzmFpiYtE7gJHioavCMxC96i9zJsK6URwSXSJ"
protocol_version="PsxS1brZfzzXCiFwirbMtQr4X5XR6SiHQ46HajpFDdk9GBXR6vy"
$admin_client inject protocol "$test_dir/demo"
$admin_client list protocols

40
src/bin_node/node_run_command.ml
View File

@ -92,32 +92,44 @@ let init_logger ?verbosity (log_config : Node_config_file.log) =
let init_node ?sandbox (config : Node_config_file.t) =
let patch_context json ctxt =
begin
match json with
| None -> Lwt.return ctxt
| Some json ->
Tezos_storage.Context.set ctxt
["sandbox_parameter"]
(Data_encoding.Binary.to_bytes Data_encoding.json json)
end >>= fun ctxt ->
let module Proto = (val Registered_protocol.get_exn genesis.protocol) in
protect begin fun () ->
Proto.configure_sandbox ctxt json
end >|= function
| Error err ->
warn
"@[Error while configuring ecoproto for the sandboxed mode:@ %a@]"
pp_print_error err ;
ctxt
| Ok ctxt -> ctxt in
Proto.init ctxt {
level = 0l ;
proto_level = 0 ;
predecessor = genesis.block ;
timestamp = genesis.time ;
validation_passes = 0 ;
operations_hash = Operation_list_list_hash.empty ;
fitness = [] ;
context = Context_hash.zero ;
} >>= function
| Error _ -> assert false (* FIXME error *)
| Ok { context = ctxt ; _ } ->
Lwt.return ctxt in
begin
match sandbox with
| None -> Lwt.return_none
| Some sandbox_param ->
match sandbox_param with
| None -> Lwt.return (Some (patch_context None))
| None -> Lwt.return None
| Some file ->
Lwt_utils_unix.Json.read_file file >>= function
| Error err ->
lwt_warn
"Can't parse sandbox parameters: %s" file >>= fun () ->
lwt_debug "%a" pp_print_error err >>= fun () ->
Lwt.return (Some (patch_context None))
Lwt.return None
| Ok json ->
Lwt.return (Some (patch_context (Some json)))
end >>= fun patch_context ->
Lwt.return (Some json)
end >>= fun sandbox_param ->
(* TODO "WARN" when pow is below our expectation. *)
begin
match config.p2p.listen_addr with
@ -163,7 +175,7 @@ let init_node ?sandbox (config : Node_config_file.t) =
end >>=? fun p2p_config ->
let node_config : Node.config = {
genesis ;
patch_context ;
patch_context = Some (patch_context sandbox_param) ;
store_root = store_dir config.data_dir ;
context_root = context_dir config.data_dir ;
p2p = p2p_config ;

2
src/lib_protocol_environment/sigs/v1/data_encoding.mli
View File

@ -227,6 +227,8 @@ module Json : sig
val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a
val wrap_error : ('a -> 'b) -> 'a -> 'b
val pp : Format.formatter -> json -> unit
end
module Binary : sig

11
src/lib_protocol_environment/sigs/v1/updater.mli
View File

@ -155,11 +155,12 @@ module type PROTOCOL = sig
(** The list of remote procedures exported by this implementation *)
val rpc_services: rpc_context Lwt.t RPC_directory.t
(** An ad-hoc context patcher. It used only for debugging protocol
while running in the "sandbox" mode. This function is never used
in production. *)
val configure_sandbox:
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
(** Initialize the context (or upgrade the context after a protocol
amendment). This function receives the context resulting of the
application of a block that triggered the amendment. It also
receives the header of the block that triggered the amendment. *)
val init:
Context.t -> Block_header.shell_header -> validation_result tzresult Lwt.t
end

7
src/lib_protocol_environment/tezos_protocol_environment.ml
View File

@ -93,8 +93,8 @@ module Make (Context : CONTEXT) = struct
val finalize_block:
validation_state -> validation_result tzresult Lwt.t
val rpc_services: rpc_context Lwt.t RPC_directory.t
val configure_sandbox:
context -> Data_encoding.json option -> context tzresult Lwt.t
val init:
context -> Block_header.shell_header -> validation_result tzresult Lwt.t
end
module type PROTOCOL =
@ -581,8 +581,7 @@ module Make (Context : CONTEXT) = struct
apply_operation c o >|= wrap_error
let finalize_block c = finalize_block c >|= wrap_error
let parse_operation h b = parse_operation h b |> wrap_error
let configure_sandbox c j =
configure_sandbox c j >|= wrap_error
let init c bh = init c bh >|= wrap_error
end
class ['block] proto_rpc_context

4
src/lib_protocol_environment/tezos_protocol_environment.mli
View File

@ -86,8 +86,8 @@ module Make (Context : CONTEXT) : sig
val finalize_block:
validation_state -> validation_result tzresult Lwt.t
val rpc_services: rpc_context Lwt.t RPC_directory.t
val configure_sandbox:
context -> Data_encoding.json option -> context tzresult Lwt.t
val init:
context -> Block_header.shell_header -> validation_result tzresult Lwt.t
end
module type PROTOCOL =

27
src/lib_shell/block_validator.ml
View File

@ -167,8 +167,8 @@ let apply_block
Proto.apply_operation state op >>=? fun state ->
return state))
state parsed_operations >>=? fun state ->
Proto.finalize_block state >>=? fun new_context ->
Context.get_protocol new_context.context >>= fun new_protocol ->
Proto.finalize_block state >>=? fun validation_result ->
Context.get_protocol validation_result.context >>= fun new_protocol ->
let expected_proto_level =
if Protocol_hash.equal new_protocol Proto.hash then
pred_header.shell.proto_level
@ -180,19 +180,30 @@ let apply_block
expected = expected_proto_level ;
}) >>=? fun () ->
fail_when
Fitness.(new_context.fitness <> header.shell.fitness)
Fitness.(validation_result.fitness <> header.shell.fitness)
(invalid_block hash @@ Invalid_fitness {
expected = header.shell.fitness ;
found = new_context.fitness ;
found = validation_result.fitness ;
}) >>=? fun () ->
begin
if Protocol_hash.equal new_protocol Proto.hash then
return validation_result
else
match Registered_protocol.get new_protocol with
| None ->
fail (Unavailable_protocol { block = hash ;
protocol = new_protocol })
| Some (module NewProto) ->
NewProto.init validation_result.context header.shell
end >>=? fun validation_result ->
let max_operations_ttl =
max 0
(min
((State.Block.max_operations_ttl pred)+1)
new_context.max_operations_ttl) in
let new_context =
{ new_context with max_operations_ttl } in
return new_context
validation_result.max_operations_ttl) in
let validation_result =
{ validation_result with max_operations_ttl } in
return validation_result
let check_chain_liveness chain_db hash (header: Block_header.t) =
let chain_state = Distributed_db.chain_state chain_db in

18
src/lib_shell/node.ml
View File

@ -335,7 +335,6 @@ module RPC = struct
pred_shell_header.proto_level
else
((pred_shell_header.proto_level + 1) mod 256) in
Context.commit ?message ~time:timestamp context >>= fun context ->
let shell_header : Block_header.shell_header = {
level = Int32.succ pred_shell_header.level ;
proto_level ;
@ -344,9 +343,22 @@ module RPC = struct
validation_passes = List.length rs ;
operations_hash ;
fitness ;
context ;
context = Context_hash.zero ; (* place holder *)
} in
return (shell_header, rs)
begin
if Protocol_hash.equal protocol pred_protocol then
return (context, message)
else
match Registered_protocol.get protocol with
| None ->
fail (Block_validator_errors.Unavailable_protocol
{ block = State.Block.hash predecessor ; protocol })
| Some (module NewProto) ->
NewProto.init context shell_header >>=? fun { context ; message ; _ } ->
return (context, message)
end >>=? fun (context, message) ->
Context.commit ?message ~time:timestamp context >>= fun context ->
return ({ shell_header with context }, rs)
let complete node ?block str =
match block with

1
src/lib_storage/context.ml
View File

@ -102,7 +102,6 @@ let checkout index key =
| Some commit ->
GitStore.Commit.tree commit >>= fun tree ->
let ctxt = { index ; tree ; parents = [commit] } in
index.patch_context ctxt >>= fun ctxt ->
Lwt.return (Some ctxt)
let checkout_exn index key =

6
src/proto_alpha/lib_baking/test/test_endorsement.ml
View File

@ -199,7 +199,7 @@ let test_endorsement_rights contract block =
let run genesis =
Helpers.Baking.bake genesis b1 [] >>=? fun blk ->
Helpers.Baking.bake genesis b2 [] >>=? fun blk ->
let block = `Hash (blk, 0) in
test_endorsement_rights
@ -211,9 +211,9 @@ let run genesis =
Assert.equal_bool ~msg:__LOC__ has_right_to_endorse true ;
Assert.balance_equal
~block:block ~msg:__LOC__ b1 3_999_488_000_000L >>=? fun () ->
~block:block ~msg:__LOC__ b1 4_000_000_000_000L >>=? fun () ->
Assert.balance_equal
~block:block ~msg:__LOC__ b2 4_000_000_000_000L >>=? fun () ->
~block:block ~msg:__LOC__ b2 3_999_488_000_000L >>=? fun () ->
Assert.balance_equal
~block:block ~msg:__LOC__ b3 4_000_000_000_000L >>=? fun () ->
Assert.balance_equal

19
src/proto_alpha/lib_baking/test/test_rpc.ml
View File

@ -26,21 +26,18 @@ let run blkid =
in
(* files and directories that are in context *)
let version = Key (MBytes.of_hex (`Hex "67656e65736973")) in
let genesis_key = Key (MBytes.of_hex (`Hex "68b4bf512517497dbd944de6825ab0a0fed7ff51bdd6b77596a19cc9175ddd55")) in
let version = Key (MBytes.of_hex (`Hex "616c706861")) in
let dir_depth0 = Cut in
let dir_depth1 = Dir [("genesis_key", Cut);
("v1", Cut);
("version", Cut)] in
let dir_depth2 = Dir [("genesis_key", genesis_key);
("v1", Dir [("sandboxed",Cut)]);
("version", version)] in
let dir_depth2 = Dir [("02", Dir [("29", Cut)]);
("a9", Dir [("ce", Cut)]);
("c5", Dir [("5c", Cut)]);
("da", Dir [("c9", Cut)]);
("e7", Dir [("67", Cut)]);
] in
let tests = [(("version",1), is_equal version);
(("",0), is_equal dir_depth0);
(("",1), is_equal dir_depth1);
(("",2), is_equal dir_depth2);
(("",2), is_equal dir_depth2);
(("delegates",2), is_equal dir_depth2);
(("",-1), is_not_found);
(("not-existent",1), is_not_found);
(("not-existent",0), is_not_found);

1
src/proto_alpha/lib_baking/test/test_vote.ml
View File

@ -78,7 +78,6 @@ let run_change_to_demo_proto block
(* Mine blocks to switch to end the vote cycle (back to Proposal) *)
Format.eprintf "Switching to `demo` protocol@.";
Baking.bake (`Hash (head, 0)) b4 operations >>=? fun head ->
Baking.bake (`Hash (head, 0)) b5 [] >>=? fun head ->
Assert.check_protocol
~msg:__LOC__ ~block:(`Hash (head, 0)) demo_protocol >>=? fun () ->

5
src/proto_alpha/lib_protocol/src/alpha_context.ml
View File

@ -95,7 +95,8 @@ module Commitment = struct
include Commitment_storage
end
let init = Init_storage.may_initialize
let prepare_first_block = Init_storage.prepare_first_block
let prepare = Init_storage.prepare
let finalize ?commit_message:message c =
let fitness = Fitness.from_int64 (Fitness.current c) in
@ -107,8 +108,6 @@ let finalize ?commit_message:message c =
Raw_level.to_int32 @@ Level.last_allowed_fork_level c;
}
let configure_sandbox = Raw_context.configure_sandbox
let activate = Raw_context.activate
let fork_test_chain = Raw_context.fork_test_chain

13
src/proto_alpha/lib_protocol/src/alpha_context.mli
View File

@ -766,16 +766,21 @@ module Commitment : sig
end
val init:
val prepare_first_block:
Context.t ->
level:Int32.t ->
timestamp:Time.t ->
fitness:Fitness.t ->
context tzresult Lwt.t
val finalize: ?commit_message:string -> context -> Updater.validation_result
val configure_sandbox:
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
val prepare:
Context.t ->
level:Int32.t ->
timestamp:Time.t ->
fitness:Fitness.t ->
context tzresult Lwt.t
val finalize: ?commit_message:string -> context -> Updater.validation_result
val activate: context -> Protocol_hash.t -> context Lwt.t
val fork_test_chain: context -> Protocol_hash.t -> Time.t -> context Lwt.t

18
src/proto_alpha/lib_protocol/src/alpha_services.ml
View File

@ -117,18 +117,13 @@ module Context = struct
end
type error += Unexpected_level_in_context
let () =
let open Services_registration in
register0 S.level begin fun ctxt () () ->
let level = Level.current ctxt in
match Level.pred ctxt level with
| None -> fail Unexpected_level_in_context
| Some level -> return level
return (Level.current ctxt)
end ;
register0 S.next_level begin fun ctxt () () ->
return (Level.current ctxt)
return (Level.succ ctxt (Level.current ctxt))
end ;
register0 S.voting_period_kind begin fun ctxt () () ->
Vote.get_current_period_kind ctxt
@ -203,12 +198,9 @@ module Nonce = struct
end ;
register0 S.hash begin fun ctxt () () ->
let level = Level.current ctxt in
match Level.pred ctxt level with
| None -> fail Context.Unexpected_level_in_context
| Some level ->
Nonce.get ctxt level >>=? function
| Unrevealed { nonce_hash ; _ } -> return nonce_hash
| _ -> assert false
Nonce.get ctxt level >>=? function
| Unrevealed { nonce_hash ; _ } -> return nonce_hash
| _ -> assert false
end
let get ctxt block level =

8
src/proto_alpha/lib_protocol/src/constants_repr.ml
View File

@ -241,14 +241,18 @@ let constants_encoding =
))
unit)
type error += Constant_read of exn
type error += Constant_read of string
let read = function
| None ->
return default
| Some json ->
match Data_encoding.Json.(destruct constants_encoding json) with
| exception exn -> fail (Constant_read exn)
| exception (Data_encoding.Json.Cannot_destruct _ as exn) ->
Format.kasprintf
failwith "Invalid sandbox: %a %a"
(fun ppf -> Data_encoding.Json.print_error ppf) exn
Data_encoding.Json.pp json
| c ->
if Compare.Int32.(c.blocks_per_roll_snapshot > c.blocks_per_cycle) then
failwith "Invalid sandbox: 'blocks_per_roll_snapshot > blocks_per_cycle'"

6
src/proto_alpha/lib_protocol/src/delegate_services.ml
View File

@ -113,7 +113,7 @@ module Baker = struct
return (level.level, prio)
let baking_rights ctxt () max =
let level = Level.current ctxt in
let level = Level.succ ctxt (Level.current ctxt) in
baking_rights_for_level ctxt level max >>=? fun (raw_level, slots) ->
begin
Lwt_list.filter_map_p (fun x -> x) @@
@ -130,7 +130,7 @@ module Baker = struct
let baking_rights_for_delegate
ctxt contract () (max_priority, min_level, max_level) =
let max_priority = default_max_baking_priority ctxt max_priority in
let current_level = Level.current ctxt in
let current_level = Level.succ ctxt (Level.current ctxt) in
let min_level = match min_level with
| None -> current_level
| Some l -> Level.from_raw ctxt l in
@ -276,7 +276,7 @@ module Endorser = struct
let current_level = Level.current ctxt in
let max_priority = default_max_endorsement_priority ctxt max_priority in
let min_level = match min_level with
| None -> Level.succ ctxt current_level
| None -> current_level
| Some l -> Level.from_raw ctxt l in
let max_level =
match max_level with

2
src/proto_alpha/lib_protocol/src/helpers_services.ml
View File

@ -133,7 +133,7 @@ module I = struct
| None -> Error_monad.fail Operation.Cannot_parse_operation
| Some (shell, contents) ->
let operation = { shell ; contents ; signature } in
let level = Alpha_context.Level.current ctxt in
let level = Level.succ ctxt (Level.current ctxt) in
Baking.baking_priorities ctxt level >>=? fun (Misc.LCons (baker_pk, _)) ->
let baker_pkh = Ed25519.Public_key.hash baker_pk in
let block_prio = 0 in

13
src/proto_alpha/lib_protocol/src/init_storage.ml
View File

@ -8,7 +8,9 @@
(**************************************************************************)
(* This is the genesis protocol: initialise the state *)
let initialize ctxt =
let prepare_first_block ctxt ~level ~timestamp ~fitness =
Raw_context.prepare_first_block
~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
Roll_storage.init ctxt >>=? fun ctxt ->
Seed_storage.init ctxt >>=? fun ctxt ->
Contract_storage.init ctxt >>=? fun ctxt ->
@ -18,10 +20,5 @@ let initialize ctxt =
Commitment_storage.init ctxt >>=? fun ctxt ->
return ctxt
let may_initialize ctxt ~level ~timestamp ~fitness =
Raw_context.prepare
~level ~timestamp ~fitness ctxt >>=? fun (ctxt, first_block) ->
if first_block then
initialize ctxt
else
return ctxt
let prepare ctxt ~level ~timestamp ~fitness =
Raw_context.prepare ~level ~timestamp ~fitness ctxt

12
src/proto_alpha/lib_protocol/src/main.ml
View File

@ -69,7 +69,7 @@ let begin_application
let level = block_header.shell.level in
let fitness = pred_fitness in
let timestamp = block_header.shell.timestamp in
Alpha_context.init ~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
Alpha_context.prepare ~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
Apply.begin_application
ctxt block_header pred_timestamp >>=? fun (ctxt, baker, deposit) ->
let mode = Application { block_header ; baker = Ed25519.Public_key.hash baker } in
@ -88,7 +88,7 @@ let begin_construction
() =
let level = Int32.succ pred_level in
let fitness = pred_fitness in
Alpha_context.init ~timestamp ~level ~fitness ctxt >>=? fun ctxt ->
Alpha_context.prepare ~timestamp ~level ~fitness ctxt >>=? fun ctxt ->
begin
match protocol_data with
| None ->
@ -153,4 +153,10 @@ let finalize_block { mode ; ctxt ; op_count ; deposit ; fees ; rewards } =
let compare_operations op1 op2 =
Apply.compare_operations op1 op2
let configure_sandbox = Alpha_context.configure_sandbox
let init ctxt block_header =
let level = block_header.Block_header.level in
let fitness = block_header.fitness in
let timestamp = block_header.timestamp in
Alpha_context.prepare_first_block
~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
return (Alpha_context.finalize ctxt)

142
src/proto_alpha/lib_protocol/src/raw_context.ml
View File

@ -120,22 +120,12 @@ let storage_error err = fail (Storage_error err)
let version_key = ["version"]
let version_value = "alpha"
let is_first_block ctxt =
Context.get ctxt version_key >>= function
| None ->
return true
| Some bytes ->
let s = MBytes.to_string bytes in
if Compare.String.(s = version_value) then
return false
else if Compare.String.(s = "genesis") then
return true
else
storage_error (Incompatible_protocol_version s)
let version = "v1"
let first_level_key = [ version ; "first_level" ]
let sandboxed_key = [ version ; "sandboxed" ]
let constants_key = [ version ; "constants" ]
(* temporary hardcoded key to be removed... *)
let sandbox_param_key = [ "sandbox_parameter" ]
let get_first_level ctxt =
Context.get ctxt first_level_key >>= function
@ -171,35 +161,49 @@ let () =
(function Failed_to_parse_sandbox_parameter data -> Some data | _ -> None)
(fun data -> Failed_to_parse_sandbox_parameter data)
let get_sandboxed c =
Context.get c sandboxed_key >>= function
let get_sandbox_param c =
Context.get c sandbox_param_key >>= function
| None -> return None
| Some bytes ->
match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
| None -> fail (Failed_to_parse_sandbox_parameter bytes)
| Some json -> return (Some json)
let set_sandboxed c json =
Context.set c sandboxed_key
(Data_encoding.Binary.to_bytes Data_encoding.json json)
let set_constants ctxt constants =
let bytes =
Data_encoding.Binary.to_bytes
Constants_repr.constants_encoding constants in
Context.set ctxt constants_key bytes
let may_tag_first_block ctxt level =
is_first_block ctxt >>=? function
| false ->
get_first_level ctxt >>=? fun level ->
return (ctxt, false, level)
| true ->
Context.set ctxt version_key
(MBytes.of_string version_value) >>= fun ctxt ->
set_first_level ctxt level >>=? fun ctxt ->
return (ctxt, true, level)
let get_constants ctxt =
Context.get ctxt constants_key >>= function
| None ->
failwith "Internal error: cannot read constants in context."
| Some bytes ->
match
Data_encoding.Binary.of_bytes Constants_repr.constants_encoding bytes
with
| None ->
failwith "Internal error: cannot parse constants in context."
| Some constants -> return constants
let check_inited ctxt =
Context.get ctxt version_key >>= function
| None ->
failwith "Internal error: un-initialized context."
| Some bytes ->
let s = MBytes.to_string bytes in
if Compare.String.(s = version_value) then
return ()
else
storage_error (Incompatible_protocol_version s)
let prepare ~level ~timestamp ~fitness ctxt =
Lwt.return (Raw_level_repr.of_int32 level ) >>=? fun level ->
Lwt.return (Raw_level_repr.of_int32 level) >>=? fun level ->
Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) ->
get_sandboxed ctxt >>=? fun sandbox ->
Constants_repr.read sandbox >>=? fun constants ->
check_inited ctxt >>=? fun () ->
get_constants ctxt >>=? fun constants ->
get_first_level ctxt >>=? fun first_level ->
let level =
Level_repr.from_raw
~first_level
@ -207,11 +211,34 @@ let prepare ~level ~timestamp ~fitness ctxt =
~blocks_per_voting_period:constants.Constants_repr.blocks_per_voting_period
~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
level in
return ({ context = ctxt ; constants ; level ;
timestamp ; fitness ; first_level ;
endorsements_received = Int_set.empty ;
},
first_block)
return {
context = ctxt ; constants ; level ;
timestamp ; fitness ; first_level ;
endorsements_received = Int_set.empty ;
}
let check_first_block ctxt =
Context.get ctxt version_key >>= function
| None -> return ()
| Some bytes ->
let s = MBytes.to_string bytes in
if Compare.String.(s = version_value) then
failwith "Internal error: previously initialized context."
else if Compare.String.(s = "genesis") then
return ()
else
storage_error (Incompatible_protocol_version s)
let prepare_first_block ~level ~timestamp ~fitness ctxt =
check_first_block ctxt >>=? fun () ->
Lwt.return (Raw_level_repr.of_int32 level) >>=? fun first_level ->
get_sandbox_param ctxt >>=? fun sandbox_param ->
Constants_repr.read sandbox_param >>=? fun constants ->
Context.set ctxt version_key
(MBytes.of_string version_value) >>= fun ctxt ->
set_first_level ctxt first_level >>=? fun ctxt ->
set_constants ctxt constants >>= fun ctxt ->
prepare ctxt ~level ~timestamp ~fitness
let activate ({ context = c ; _ } as s) h =
Updater.activate c h >>= fun c -> Lwt.return { s with context = c }
@ -233,45 +260,6 @@ let register_resolvers enc resolve =
resolve faked_context str in
Context.register_resolver enc resolve
type error += Unimplemented_sandbox_migration
let configure_sandbox ctxt json =
let rec json_equals x y = match x, y with
| `Float x, `Float y -> Compare.Float.(x = y)
| `Bool x, `Bool y -> Compare.Bool.(x = y)
| `String x, `String y -> Compare.String.(x = y)
| `Null, `Null -> true
| `O x, `O y ->
let sort =
List.sort (fun (a, _) (b, _) -> Compare.String.compare a b) in
Compare.Int.(=) (List.length x) (List.length y) &&
List.for_all2
(fun (nx, vx) (ny, vy) ->
Compare.String.(nx = ny) && json_equals vx vy)
(sort x) (sort y)
| `A x, `A y ->
Compare.Int.(=) (List.length x) (List.length y) &&
List.for_all2 json_equals x y
| _, _ -> false
in
let json =
match json with
| None -> `O []
| Some json -> json in
is_first_block ctxt >>=? function
| true ->
set_sandboxed ctxt json >>= fun ctxt ->
return ctxt
| false ->
get_sandboxed ctxt >>=? function
| None ->
fail Unimplemented_sandbox_migration
| Some existing ->
if json_equals existing json then
return ctxt
else
failwith "Changing sandbox parameter is not yet implemented"
(* Generic context ********************************************************)
type key = string list

11
src/proto_alpha/lib_protocol/src/raw_context.mli
View File

@ -35,7 +35,13 @@ val prepare:
level: Int32.t ->
timestamp: Time.t ->
fitness: Fitness.t ->
Context.t -> (context * bool) tzresult Lwt.t
Context.t -> context tzresult Lwt.t
val prepare_first_block:
level:int32 ->
timestamp:Time.t ->
fitness:Fitness.t ->
Context.t -> context tzresult Lwt.t
val activate: context -> Protocol_hash.t -> t Lwt.t
val fork_test_chain: context -> Protocol_hash.t -> Time.t -> t Lwt.t
@ -43,9 +49,6 @@ val fork_test_chain: context -> Protocol_hash.t -> Time.t -> t Lwt.t
val register_resolvers:
'a Base58.encoding -> (context -> string -> 'a list Lwt.t) -> unit
val configure_sandbox:
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
(** Returns the state of the database resulting of operations on its
abstract view *)
val recover: context -> Context.t

4
src/proto_alpha/lib_protocol/src/services_registration.ml
View File

@ -20,10 +20,10 @@ type rpc_context = {
let rpc_init (rpc_context : Updater.rpc_context Lwt.t) =
rpc_context >>= fun { block_hash ; block_header ;
operation_hashes ; operations ; context } ->
let level = Int32.succ block_header.shell.level in
let level = block_header.shell.level in
let timestamp = block_header.shell.timestamp in
let fitness = block_header.shell.fitness in
Alpha_context.init ~level ~timestamp ~fitness context >>=? fun context ->
Alpha_context.prepare ~level ~timestamp ~fitness context >>=? fun context ->
return { block_hash ; block_header ; operation_hashes ; operations ; context }
let rpc_services = ref (RPC_directory.empty : Updater.rpc_context Lwt.t RPC_directory.t)

2
src/proto_alpha/lib_protocol/test/helpers/helpers_block.ml
View File

@ -131,7 +131,7 @@ let get_header_hash
shell = shell_header ;
protocol_data = init_block.protocol_data_bytes
} in
Proto_alpha.Alpha_context.init
Proto_alpha.Alpha_context.prepare
validation_result.context
~level
~timestamp

17
src/proto_alpha/lib_protocol/test/helpers/helpers_init.ml
View File

@ -21,7 +21,9 @@ let get_sandbox () =
let main () =
let context = Tezos_protocol_environment_memory.Context.empty in
get_sandbox () >>= fun json ->
Main.configure_sandbox context @@ Some json >>=? fun context ->
Tezos_protocol_environment_memory.Context.set context
["sandbox_parameter"]
(Data_encoding.Binary.to_bytes Data_encoding.json json) >>= fun context ->
let genesis_hash =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" in
@ -40,18 +42,9 @@ let main () =
Alpha_context.Block_header.protocol_data_encoding
(Helpers_block.get_protocol_data 0 true) in
let tezos_header = { Block_header.shell = header ; protocol_data } in
Proto_alpha.Main.begin_construction
~predecessor_context: context
~predecessor_fitness:[]
~predecessor_timestamp:Time.epoch
~predecessor_level: 0l
~predecessor: genesis_hash
~timestamp: header.timestamp
~protocol_data
() >>=? fun vstate ->
Proto_alpha.init context header >>=? fun validation ->
let hash = Block_header.hash tezos_header in
Proto_alpha.Main.finalize_block vstate >>=? fun validation ->
Alpha_context.init
Alpha_context.prepare
~level: (Int32.succ header.level)
~timestamp: header.timestamp
~fitness: header.fitness

3
src/proto_alpha/lib_protocol/test/helpers/helpers_operation.ml
View File

@ -14,7 +14,8 @@ open Alpha_context
let sourced ops = Sourced_operations ops
let manager (src : Helpers_account.t) ?(fee = Tez.zero) operations context =
Alpha_context.init ~level:0l ~timestamp:(Time.now ()) ~fitness:[] context >>=? fun context ->
Alpha_context.prepare
~level:0l ~timestamp:(Time.now ()) ~fitness:[] context >>=? fun context ->
Contract.get_counter context src.contract >>=? fun counter ->
let counter = Int32.succ counter in
return @@

4
src/proto_alpha/lib_protocol/test/helpers/isolate_helpers.ml
View File

@ -24,14 +24,14 @@ module Script = Helpers_script
module Shorthands = struct
let to_tc_full ctxt level fitness =
Alpha_context.init
Alpha_context.prepare
ctxt
~level
~fitness
~timestamp:(Time.now())
let get_tc_full (res:Block.result) =
Alpha_context.init
Alpha_context.prepare
res.validation.context
~level:res.level
~timestamp:res.tezos_header.shell.timestamp

8
src/proto_demo/lib_protocol/src/main.ml
View File

@ -94,4 +94,10 @@ let finalize_block ctxt =
let rpc_services = Services.rpc_services
let configure_sandbox ctxt _ = Lwt.return (Ok ctxt)
let init context block_header =
return { Updater.message = None ; context ;
fitness = block_header.Block_header.fitness ;
max_operations_ttl = 0 ;
max_operation_data_length = 0 ;
last_allowed_fork_level = block_header.level ;
}

50
src/proto_genesis/lib_protocol/src/data.ml
View File

@ -119,49 +119,21 @@ module Init = struct
protocol. It's absence meaning that the context is empty. *)
let version_value = "genesis"
let may_initialize ctxt =
let check_inited ctxt =
Context.get ctxt version_key >>= function
| None -> failwith "Internal error: uninitialized context."
| Some version ->
if Compare.String.(version_value <> MBytes.to_string version) then
failwith "Internal error: incompatible protocol version" ;
return ()
let tag_first_block ctxt =
Context.get ctxt version_key >>= function
| None ->
Context.set
ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
return ctxt
| Some bytes ->
let s = MBytes.to_string bytes in
fail_unless Compare.String.(s = version_value)
Incompatible_protocol_version >>=? fun () ->
return ctxt
let sandboxed_key = [ "v1" ; "sandboxed" ]
let set_sandboxed ctxt json =
Context.set ctxt sandboxed_key
(Data_encoding.Binary.to_bytes Data_encoding.json json)
let get_sandboxed ctxt =
Context.get ctxt sandboxed_key >>= fun b ->
match b with
| None -> return None
| Some b ->
return (Data_encoding.Binary.of_bytes Data_encoding.json b)
type error += Unimplemented_sandbox_migration
let configure_sandbox ctxt json =
let json =
match json with
| None -> `O []
| Some json -> json in
Context.get ctxt version_key >>= function
| None ->
set_sandboxed ctxt json >>= fun ctxt ->
Pubkey.may_change_default ctxt json >>= fun ctxt ->
return ctxt
| Some _ ->
get_sandboxed ctxt >>=? function
| None ->
fail Unimplemented_sandbox_migration
| Some _ ->
(* FIXME GRGR fail if parameter changed! *)
(* failwith "Changing sandbox parameter is not yet implemented" *)
return ctxt
| Some _version ->
failwith "Internal error: previously initialized context." ;
end

33
src/proto_genesis/lib_protocol/src/main.ml
View File

@ -109,7 +109,7 @@ let begin_application
~predecessor_timestamp:_
~predecessor_fitness:_
raw_block =
Data.Init.may_initialize ctxt >>=? fun ctxt ->
Data.Init.check_inited ctxt >>=? fun () ->
Lwt.return (parse_block raw_block) >>=? fun block ->
check_signature ctxt block >>=? fun () ->
prepare_application ctxt block.command
@ -136,7 +136,7 @@ let begin_construction
match Data_encoding.Binary.of_bytes Data.Command.encoding command with
| None -> failwith "Failed to parse proto header"
| Some command ->
Data.Init.may_initialize ctxt >>=? fun ctxt ->
Data.Init.check_inited ctxt >>=? fun () ->
prepare_application ctxt command level timestamp fitness
let apply_operation _vctxt _ =
@ -146,4 +146,31 @@ let finalize_block state = return state
let rpc_services = Services.rpc_services
let configure_sandbox = Data.Init.configure_sandbox
(* temporary hardcoded key to be removed... *)
let sandbox_param_key = [ "sandbox_parameter" ]
let get_sandbox_param ctxt =
Context.get ctxt sandbox_param_key >>= function
| None -> return None
| Some bytes ->
match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
| None ->
failwith "Internal error: failed to parse the sandbox parameter."
| Some json -> return (Some json)
let init ctxt block_header =
Data.Init.tag_first_block ctxt >>=? fun ctxt ->
get_sandbox_param ctxt >>=? fun sandbox_param ->
begin
match sandbox_param with
| None -> return ctxt
| Some json ->
Data.Pubkey.may_change_default ctxt json >>= fun ctxt ->
return ctxt
end >>=? fun ctxt ->
return { Updater.message = None ; context = ctxt ;
fitness = block_header.Block_header.fitness ;
max_operations_ttl = 0 ;
max_operation_data_length = 0 ;
last_allowed_fork_level = block_header.level ;
}