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

Protocol_environment: more sharing between node and client

Browse Source
This commit is contained in:
Grégoire Henry 2018-02-05 11:32:12 +01:00 committed by Grégoire Henry
parent dffa65f648
commit 2498da2815
16 changed files with 301 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
src/lib_base/protocol_environment.ml
View File

@ -9,7 +9,59 @@
open Error_monad
module Make(Param : sig val name: string end)() = struct
module type CONTEXT = sig
type t
type key = string list
type value = MBytes.t
val mem: t -> key -> bool Lwt.t
val dir_mem: t -> key -> bool Lwt.t
val get: t -> key -> value option Lwt.t
val set: t -> key -> value -> t Lwt.t
val del: t -> key -> t Lwt.t
val remove_rec: t -> key -> t Lwt.t
val fold:
t -> key -> init:'a ->
f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
'a Lwt.t
end
module type UPDATER = sig
module Context : CONTEXT
type validation_result = {
context: Context.t ;
fitness: Fitness.t ;
message: string option ;
max_operation_data_length: int ;
max_operations_ttl: int ;
}
type quota = {
max_size: int ;
max_op: int option ;
}
type rpc_context = {
block_hash: Block_hash.t ;
block_header: Block_header.t ;
operation_hashes: unit -> Operation_hash.t list list Lwt.t ;
operations: unit -> Operation.t list list Lwt.t ;
context: Context.t ;
}
val compile: Protocol_hash.t -> Protocol.t -> bool Lwt.t
val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t
val fork_test_network:
Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t
end
module MakeV1
(Param : sig val name: string end)
(Context : CONTEXT)
(Updater : UPDATER with module Context := Context)
() = struct
include Pervasives
module Pervasives = Pervasives
@ -33,6 +85,7 @@ module Make(Param : sig val name: string end)() = struct
module Nativeint = Nativeint
module Buffer = Buffer
module Format = Format
module Option = Option
module Z = Z
module Lwt_sequence = Lwt_sequence
module Lwt = Lwt
@ -92,6 +145,76 @@ module Make(Param : sig val name: string end)() = struct
| Ok _ as ok -> ok
| Error errors -> Error [Ecoproto_error errors]
module Option = Option
module Updater = struct
include Updater
module type PROTOCOL = sig
open Error_monad
val max_block_length: int
val validation_passes: quota list
type operation
val parse_operation:
Operation_hash.t -> Operation.t -> operation tzresult
val acceptable_passes: operation -> int list
val compare_operations: operation -> operation -> int
type validation_state
val current_context: validation_state -> Context.t tzresult Lwt.t
val precheck_block:
ancestor_context: Context.t ->
ancestor_timestamp: Time.t ->
Block_header.t ->
unit tzresult Lwt.t
val begin_application:
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_fitness: Fitness.t ->
Block_header.t ->
validation_state tzresult Lwt.t
val begin_construction:
predecessor_context: Context.t ->
predecessor_timestamp: Time.t ->
predecessor_level: Int32.t ->
predecessor_fitness: Fitness.t ->
predecessor: Block_hash.t ->
timestamp: Time.t ->
?proto_header: MBytes.t ->
unit -> validation_state tzresult Lwt.t
val apply_operation:
validation_state -> operation -> validation_state tzresult Lwt.t
val finalize_block:
validation_state -> validation_result tzresult Lwt.t
val rpc_services: rpc_context RPC_directory.t
val configure_sandbox:
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
end
end
module Base58 = struct
include Base58
let simple_encode enc s = simple_encode enc s
let simple_decode enc s = simple_decode enc s
include Make(struct type context = Context.t end)
let decode s = decode s
end
module Context = struct
include Context
let fold_keys s k ~init ~f =
let rec loop k acc =
fold s k ~init:acc
~f:(fun file acc ->
match file with
| `Key k -> f k acc
| `Dir k -> loop k acc) in
loop k init
let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
let register_resolver = Base58.register_resolver
let complete ctxt s = Base58.complete ctxt s
end
end

2
src/lib_base/tzPervasives.ml
View File

@ -53,5 +53,7 @@ module P2p_connection = P2p_connection
module P2p_stat = P2p_stat
module P2p_version = P2p_version
module Protocol_environment = Protocol_environment
include Utils.Infix
include Error_monad

2
src/lib_base/tzPervasives.mli
View File

@ -50,5 +50,7 @@ module P2p_connection = P2p_connection
module P2p_stat = P2p_stat
module P2p_version = P2p_version
module Protocol_environment = Protocol_environment
include (module type of (struct include Utils.Infix end))
include (module type of (struct include Error_monad end))

3
src/lib_protocol_compiler/jbuild_embedded_protocol_template
View File

@ -22,7 +22,7 @@ let () = Format.kasprintf Jbuild_plugin.V1.send {|
((targets (environment.ml))
(action
(write-file ${@@}
"include Tezos_protocol_updater.Tezos_protocol_environment.Make(struct let name = \"%s\" end)()"))))
"include Tezos_protocol_updater.Updater.MakeV1(struct let name = \"%s\" end)()"))))
(rule
((targets (registerer.ml))
@ -47,6 +47,7 @@ let () = Format.kasprintf Jbuild_plugin.V1.send {|
-w +a-4-6-7-9-29-32-40..42-44-45-48
-warn-error -a+8
-open Tezos_embedded_protocol_environment_%s__Environment
-open Pervasives
-open Error_monad))
(modules (:standard \ Environment Registerer))))

27
src/lib_protocol_environment_client/fake.ml
View File

@ -7,27 +7,6 @@
(* *)
(**************************************************************************)
module Make(Param : sig val name: string end)() = struct
include Tezos_base.Protocol_environment.Make(Param)()
module Updater = struct
include Fake_updater.Make(Fake_context)
module type PROTOCOL =
RAW_PROTOCOL with type error := Error_monad.error
and type 'a tzresult := 'a Error_monad.tzresult
end
module Base58 = struct
include Base58
let simple_encode enc s = simple_encode enc s
let simple_decode enc s = simple_decode enc s
include Make(struct type context = Fake_context.t end)
let decode s = decode s
end
module Context = struct
include Fake_context
let register_resolver = Base58.register_resolver
let complete ctxt s = Base58.complete ctxt s
end
end
module Make(Param : sig val name: string end)() =
Tezos_base.Protocol_environment.MakeV1
(Param)(Fake_context)(Fake_updater.Make(Fake_context))()

2
src/lib_protocol_environment_client/fake_context.ml
View File

@ -20,5 +20,3 @@ let remove_rec _ _ = assert false
let fold _ _ ~init:_ ~f:_ = assert false
let keys _ _ = assert false
let fold_keys _ _ ~init:_ ~f:_ = assert false
let register_resolver _ _ = ()
let complete _ _ = assert false

10
src/lib_protocol_environment_client/fake_context.mli Normal file
View File

@ -0,0 +1,10 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
include Protocol_environment.CONTEXT

2
src/lib_protocol_environment_client/fake_updater.ml
View File

@ -7,7 +7,7 @@
(* *)
(**************************************************************************)
module Make(Context : sig type t end) = struct
module Make(Context : Protocol_environment.CONTEXT) = struct
type validation_result = {
context: Context.t ;

11
src/lib_protocol_environment_client/fake_updater.mli Normal file
View File

@ -0,0 +1,11 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module Make(Context : Protocol_environment.CONTEXT) :
Protocol_environment.UPDATER with module Context := Context

33
src/lib_protocol_updater/tezos_protocol_environment.ml
View File

@ -1,33 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module Make(Param : sig val name: string end)() = struct
include Tezos_base.Protocol_environment.Make(Param)()
module Updater = struct
include Updater
module type PROTOCOL =
RAW_PROTOCOL with type error := Error_monad.error
and type 'a tzresult := 'a Error_monad.tzresult
end
module Base58 = struct
include Base58
let simple_encode enc s = simple_encode enc s
let simple_decode enc s = simple_decode enc s
include Make(struct type context = Context.t end)
let decode s = decode s
end
module Context = struct
include Context
let register_resolver = Base58.register_resolver
let complete ctxt s = Base58.complete ctxt s
end
end

164
src/lib_protocol_updater/updater.ml
View File

@ -11,86 +11,92 @@ open Logging.Updater
let (//) = Filename.concat
type validation_result = {
context: Context.t ;
fitness: Fitness.t ;
message: string option ;
max_operation_data_length: int ;
max_operations_ttl: int ;
}
module Raw = struct
type quota = {
max_size: int ;
max_op: int option ;
}
type validation_result = {
context: Context.t ;
fitness: Fitness.t ;
message: string option ;
max_operation_data_length: int ;
max_operations_ttl: int ;
}
type rpc_context = {
block_hash: Block_hash.t ;
block_header: Block_header.t ;
operation_hashes: unit -> Operation_hash.t list list Lwt.t ;
operations: unit -> Operation.t list list Lwt.t ;
context: Context.t ;
}
type quota = {
max_size: int ;
max_op: int option ;
}
let activate = Context.set_protocol
let fork_test_network = Context.fork_test_network
type rpc_context = {
block_hash: Block_hash.t ;
block_header: Block_header.t ;
operation_hashes: unit -> Operation_hash.t list list Lwt.t ;
operations: unit -> Operation.t list list Lwt.t ;
context: Context.t ;
}
(** Compiler *)
let activate = Context.set_protocol
let fork_test_network = Context.fork_test_network
let datadir = ref None
let get_datadir () =
match !datadir with
| None ->
fatal_error "Node not initialized" ;
Lwt_exit.exit 1
| Some m -> m
(** Compiler *)
let init dir =
datadir := Some dir
let datadir = ref None
let get_datadir () =
match !datadir with
| None ->
fatal_error "Node not initialized" ;
Lwt_exit.exit 1
| Some m -> m
let compiler_name = "tezos-protocol-compiler"
let init dir =
datadir := Some dir
let do_compile hash p =
assert (p.Protocol.expected_env = V1) ;
let datadir = get_datadir () in
let source_dir = datadir // Protocol_hash.to_short_b58check hash // "src" in
let log_file = datadir // Protocol_hash.to_short_b58check hash // "LOG" in
let plugin_file = datadir // Protocol_hash.to_short_b58check hash //
Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash
in
Protocol.write_dir source_dir ~hash p >>= fun () ->
let compiler_command =
(Sys.executable_name,
Array.of_list [compiler_name; "-register"; plugin_file; source_dir]) in
let fd = Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644) in
let pi =
Lwt_process.exec
~stdin:`Close ~stdout:(`FD_copy fd) ~stderr:(`FD_move fd)
compiler_command in
pi >>= function
| Unix.WSIGNALED _ | Unix.WSTOPPED _ ->
log_error "INTERRUPTED COMPILATION (%s)" log_file;
Lwt.return false
| Unix.WEXITED x when x <> 0 ->
log_error "COMPILATION ERROR (%s)" log_file;
Lwt.return false
| Unix.WEXITED _ ->
try Dynlink.loadfile_private plugin_file; Lwt.return true
with Dynlink.Error err ->
log_error "Can't load plugin: %s (%s)"
(Dynlink.error_message err) plugin_file;
let compiler_name = "tezos-protocol-compiler"
let do_compile hash p =
assert (p.Protocol.expected_env = V1) ;
let datadir = get_datadir () in
let source_dir = datadir // Protocol_hash.to_short_b58check hash // "src" in
let log_file = datadir // Protocol_hash.to_short_b58check hash // "LOG" in
let plugin_file = datadir // Protocol_hash.to_short_b58check hash //
Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash
in
Protocol.write_dir source_dir ~hash p >>= fun () ->
let compiler_command =
(Sys.executable_name,
Array.of_list [compiler_name; "-register"; plugin_file; source_dir]) in
let fd = Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644) in
let pi =
Lwt_process.exec
~stdin:`Close ~stdout:(`FD_copy fd) ~stderr:(`FD_move fd)
compiler_command in
pi >>= function
| Unix.WSIGNALED _ | Unix.WSTOPPED _ ->
log_error "INTERRUPTED COMPILATION (%s)" log_file;
Lwt.return false
| Unix.WEXITED x when x <> 0 ->
log_error "COMPILATION ERROR (%s)" log_file;
Lwt.return false
| Unix.WEXITED _ ->
try Dynlink.loadfile_private plugin_file; Lwt.return true
with Dynlink.Error err ->
log_error "Can't load plugin: %s (%s)"
(Dynlink.error_message err) plugin_file;
Lwt.return false
let compile hash p =
if Tezos_protocol_registerer.Registerer.mem hash then
Lwt.return true
else begin
do_compile hash p >>= fun success ->
let loaded = Tezos_protocol_registerer.Registerer.mem hash in
if success && not loaded then
log_error "Internal error while compiling %a" Protocol_hash.pp hash;
Lwt.return loaded
end
let compile hash p =
if Tezos_protocol_registerer.Registerer.mem hash then
Lwt.return true
else begin
do_compile hash p >>= fun success ->
let loaded = Tezos_protocol_registerer.Registerer.mem hash in
if success && not loaded then
log_error "Internal error while compiling %a" Protocol_hash.pp hash;
Lwt.return loaded
end
end
include Raw
module Node_protocol_environment_sigs = struct
@ -118,6 +124,10 @@ module Node_protocol_environment_sigs = struct
and type Updater.validation_result = validation_result
and type Updater.quota = quota
and type Updater.rpc_context = rpc_context
and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t
and type Ed25519.Public_key.t = Ed25519.Public_key.t
and type Ed25519.Signature.t = Ed25519.Signature.t
and type 'a Micheline.canonical = 'a Micheline.canonical
type error += Ecoproto_error of Error_monad.error list
val wrap_error : 'a Error_monad.tzresult -> 'a tzresult
@ -126,9 +136,12 @@ module Node_protocol_environment_sigs = struct
end
module type RAW_PROTOCOL = sig
type error = ..
type 'a tzresult = ('a, error list) result
module MakeV1(Name : sig val name: string end)()
: Node_protocol_environment_sigs.V1 =
Protocol_environment.MakeV1(Name)(Context)(Raw)()
module type NODE_PROTOCOL = sig
val max_block_length: int
val validation_passes: quota list
type operation
@ -167,11 +180,6 @@ module type RAW_PROTOCOL = sig
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
end
module type NODE_PROTOCOL =
RAW_PROTOCOL with type error := error
and type 'a tzresult := 'a tzresult
module LiftProtocol
(Name : sig val name: string end)
(Env : Node_protocol_environment_sigs.V1)

93
src/lib_protocol_updater/updater.mli
View File

@ -37,9 +37,52 @@ type rpc_context = {
context: Context.t ;
}
module type RAW_PROTOCOL = sig
type error = ..
type 'a tzresult = ('a, error list) result
(* The end of this file is not exported to the protocol... *)
val compiler_name: string
module Node_protocol_environment_sigs : sig
module type V1 = sig
include Tezos_protocol_environment_sigs.V1.T
with type Format.formatter = Format.formatter
and type 'a Data_encoding.t = 'a Data_encoding.t
and type 'a Lwt.t = 'a Lwt.t
and type ('a, 'b) Pervasives.result = ('a, 'b) result
and type Block_hash.t = Block_hash.t
and type Operation_hash.t = Operation_hash.t
and type Operation_list_hash.t = Operation_list_hash.t
and type Operation_list_list_hash.t = Operation_list_list_hash.t
and type Context_hash.t = Context_hash.t
and type Protocol_hash.t = Protocol_hash.t
and type Context.t = Context.t
and type Time.t = Time.t
and type MBytes.t = MBytes.t
and type Operation.shell_header = Operation.shell_header
and type Operation.t = Operation.t
and type Block_header.shell_header = Block_header.shell_header
and type Block_header.t = Block_header.t
and type 'a RPC_directory.t = 'a RPC_directory.t
and type Updater.validation_result = validation_result
and type Updater.quota = quota
and type Updater.rpc_context = rpc_context
and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t
and type Ed25519.Public_key.t = Ed25519.Public_key.t
and type Ed25519.Signature.t = Ed25519.Signature.t
and type 'a Micheline.canonical = 'a Micheline.canonical
type error += Ecoproto_error of Error_monad.error list
val wrap_error : 'a Error_monad.tzresult -> 'a tzresult
end
end
module MakeV1(Name : sig val name: string end)() :
Node_protocol_environment_sigs.V1
module type NODE_PROTOCOL = sig
val max_block_length: int
val validation_passes: quota list
type operation
@ -78,50 +121,6 @@ module type RAW_PROTOCOL = sig
Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
end
(**/**)
(* The end of this file is not exported to the protocol... *)
val compiler_name: string
module Node_protocol_environment_sigs : sig
module type V1 = sig
include Tezos_protocol_environment_sigs.V1.T
with type Format.formatter = Format.formatter
and type 'a Data_encoding.t = 'a Data_encoding.t
and type 'a Lwt.t = 'a Lwt.t
and type ('a, 'b) Pervasives.result = ('a, 'b) result
and type Block_hash.t = Block_hash.t
and type Operation_hash.t = Operation_hash.t
and type Operation_list_hash.t = Operation_list_hash.t
and type Operation_list_list_hash.t = Operation_list_list_hash.t
and type Context_hash.t = Context_hash.t
and type Protocol_hash.t = Protocol_hash.t
and type Context.t = Context.t
and type Time.t = Time.t
and type MBytes.t = MBytes.t
and type Operation.shell_header = Operation.shell_header
and type Operation.t = Operation.t
and type Block_header.shell_header = Block_header.shell_header
and type Block_header.t = Block_header.t
and type 'a RPC_directory.t = 'a RPC_directory.t
and type Updater.validation_result = validation_result
and type Updater.quota = quota
and type Updater.rpc_context = rpc_context
type error += Ecoproto_error of Error_monad.error list
val wrap_error : 'a Error_monad.tzresult -> 'a tzresult
end
end
module type NODE_PROTOCOL =
RAW_PROTOCOL with type error := error
and type 'a tzresult := 'a tzresult
module LiftProtocol(Name : sig val name: string end)
(Env : Node_protocol_environment_sigs.V1)
(P : Env.Updater.PROTOCOL) :

2
src/lib_shell/state.ml
View File

@ -706,7 +706,7 @@ module Registred_protocol = struct
let module Name = struct
let name = Protocol_hash.to_b58check hash
end in
let module Env = Tezos_protocol_environment.Make(Name)() in
let module Env = Updater.MakeV1(Name)() in
(module struct
let hash = hash
module P = F(Env)

11
src/lib_storage/context.ml
View File

@ -169,17 +169,6 @@ let fold ctxt key ~init ~f =
end
init keys
let fold_keys s k ~init ~f =
let rec loop k acc =
fold s k ~init:acc
~f:(fun file acc ->
match file with
| `Key k -> f k acc
| `Dir k -> loop k acc) in
loop k init
let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
(*-- Predefined Fields -------------------------------------------------------*)
let get_protocol v =

4
src/lib_storage/context.mli
View File

@ -50,10 +50,6 @@ val fold:
f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) ->
'a Lwt.t
val keys: context -> key -> key list Lwt.t
val fold_keys:
context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
(** {2 Accessing and Updating Versions} **************************************)
val exists: index -> Context_hash.t -> bool Lwt.t

15
src/lib_storage/test/test_context.ml
View File

@ -169,7 +169,17 @@ let test_replay { idx ; genesis } =
Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
Lwt.return ()
let test_keys { idx ; genesis } =
let fold_keys s k ~init ~f =
let rec loop k acc =
fold s k ~init:acc
~f:(fun file acc ->
match file with
| `Key k -> f k acc
| `Dir k -> loop k acc) in
loop k init
let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
let test_fold { idx ; genesis } =
checkout idx genesis >>= function
| None ->
Assert.fail_msg "checkout genesis_block"
@ -198,7 +208,6 @@ let test_keys { idx ; genesis } =
Assert.equal_string_list_list ~msg:__LOC__ [] l ;
Lwt.return ()
(******************************************************************************)
let tests : (string * (t -> unit Lwt.t)) list = [
@ -206,7 +215,7 @@ let tests : (string * (t -> unit Lwt.t)) list = [
"continuation", test_continuation ;
"fork", test_fork ;
"replay", test_replay ;
"keys", test_keys ;
"fold", test_fold ;
]
let () =