diff --git a/src/lib_base/jbuild b/src/lib_base/jbuild index a5af7d07f..47dde2ada 100644 --- a/src/lib_base/jbuild +++ b/src/lib_base/jbuild @@ -17,6 +17,7 @@ tezos-error-monad tezos-rpc tezos-micheline + tezos-protocol-environment-sigs calendar ezjsonm lwt.unix diff --git a/src/lib_base/protocol_environment.ml b/src/lib_base/protocol_environment.ml index f153f5fc2..5fd51e52e 100644 --- a/src/lib_base/protocol_environment.ml +++ b/src/lib_base/protocol_environment.ml @@ -57,6 +57,93 @@ module type UPDATER = sig end +module type T = sig + type context + type quota + type validation_result + type rpc_context + type 'a tzresult + 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 tzresult Lwt.t + val precheck_block: + ancestor_context: context -> + ancestor_timestamp: Time.t -> + Block_header.t -> + unit tzresult Lwt.t + val begin_application: + predecessor_context: context -> + predecessor_timestamp: Time.t -> + predecessor_fitness: Fitness.t -> + Block_header.t -> + validation_state tzresult Lwt.t + val begin_construction: + predecessor_context: context -> + 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 -> Data_encoding.json option -> context tzresult Lwt.t +end + +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 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 Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t + and type Ed25519.Public_key.t = Ed25519.Public_key.t + and type Ed25519.Secret_key.t = Ed25519.Secret_key.t + and type Ed25519.Signature.t = Ed25519.Signature.t + and type 'a Micheline.canonical = 'a Micheline.canonical + and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t + and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node + and type Data_encoding.json_schema = Data_encoding.json_schema + and type RPC_service.meth = RPC_service.meth + and type (+'m,'pr,'p,'q,'i,'o) RPC_service.t = ('m,'pr,'p,'q,'i,'o) RPC_service.t + + type error += Ecoproto_error of Error_monad.error list + val wrap_error : 'a Error_monad.tzresult -> 'a tzresult + + module Lift (P : Updater.PROTOCOL) : + T with type context := Context.t + and type quota := Updater.quota + and type validation_result := Updater.validation_result + and type rpc_context := Updater.rpc_context + and type 'a tzresult := 'a tzresult + +end + module MakeV1 (Param : sig val name: string end) (Context : CONTEXT) @@ -148,45 +235,12 @@ module MakeV1 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 + module type PROTOCOL = + T with type context := Context.t + and type quota := Updater.quota + and type validation_result := Updater.validation_result + and type rpc_context := Updater.rpc_context + and type 'a tzresult := 'a Error_monad.tzresult end module Base58 = struct @@ -214,6 +268,40 @@ module MakeV1 let complete ctxt s = Base58.complete ctxt s end + module Lift(P : Updater.PROTOCOL) = struct + include P + let precheck_block + ~ancestor_context ~ancestor_timestamp + raw_block = + precheck_block + ~ancestor_context ~ancestor_timestamp + raw_block >|= wrap_error + let begin_application + ~predecessor_context ~predecessor_timestamp + ~predecessor_fitness + raw_block = + begin_application + ~predecessor_context ~predecessor_timestamp + ~predecessor_fitness + raw_block >|= wrap_error + let begin_construction + ~predecessor_context ~predecessor_timestamp + ~predecessor_level ~predecessor_fitness + ~predecessor ~timestamp ?proto_header () = + begin_construction + ~predecessor_context ~predecessor_timestamp + ~predecessor_level ~predecessor_fitness + ~predecessor ~timestamp ?proto_header () >|= wrap_error + let current_context c = + current_context c >|= wrap_error + let apply_operation c o = + 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 + end + end diff --git a/src/lib_base/protocol_environment.mli b/src/lib_base/protocol_environment.mli new file mode 100644 index 000000000..158b71c9c --- /dev/null +++ b/src/lib_base/protocol_environment.mli @@ -0,0 +1,148 @@ + +open Error_monad + + +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 type T = sig + type context + type quota + type validation_result + type rpc_context + type 'a tzresult + 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 tzresult Lwt.t + val precheck_block: + ancestor_context: context -> + ancestor_timestamp: Time.t -> + Block_header.t -> + unit tzresult Lwt.t + val begin_application: + predecessor_context: context -> + predecessor_timestamp: Time.t -> + predecessor_fitness: Fitness.t -> + Block_header.t -> + validation_state tzresult Lwt.t + val begin_construction: + predecessor_context: context -> + 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 -> Data_encoding.json option -> context tzresult Lwt.t +end + +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 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 Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t + and type Ed25519.Public_key.t = Ed25519.Public_key.t + and type Ed25519.Secret_key.t = Ed25519.Secret_key.t + and type Ed25519.Signature.t = Ed25519.Signature.t + and type 'a Micheline.canonical = 'a Micheline.canonical + and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node + and type Data_encoding.json_schema = Data_encoding.json_schema + and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t + and type RPC_service.meth = RPC_service.meth + and type (+'m,'pr,'p,'q,'i,'o) RPC_service.t = ('m,'pr,'p,'q,'i,'o) RPC_service.t + + type error += Ecoproto_error of Error_monad.error list + val wrap_error : 'a Error_monad.tzresult -> 'a tzresult + + module Lift (P : Updater.PROTOCOL) : + T with type context := Context.t + and type quota := Updater.quota + and type validation_result := Updater.validation_result + and type rpc_context := Updater.rpc_context + and type 'a tzresult := 'a tzresult + +end + +module MakeV1 + (Param : sig val name: string end) + (Context : CONTEXT) + (Updater : UPDATER with module Context := Context) + () : V1 with type Context.t = Context.t + and type Updater.validation_result = Updater.validation_result + and type Updater.quota = Updater.quota + and type Updater.rpc_context = Updater.rpc_context + diff --git a/src/lib_protocol_environment_sigs/v1/error_monad.mli b/src/lib_protocol_environment_sigs/v1/error_monad.mli index bf2a4bfb0..484391380 100644 --- a/src/lib_protocol_environment_sigs/v1/error_monad.mli +++ b/src/lib_protocol_environment_sigs/v1/error_monad.mli @@ -97,6 +97,7 @@ val fail_when : bool -> error -> unit tzresult Lwt.t (** A {!List.iter} in the monad *) val iter_s : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t +val iter_p : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t (** A {!List.map} in the monad *) val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t diff --git a/src/lib_protocol_updater/registred_protocol.ml b/src/lib_protocol_updater/registred_protocol.ml index 7bb0abe02..c1c2882c4 100644 --- a/src/lib_protocol_updater/registred_protocol.ml +++ b/src/lib_protocol_updater/registred_protocol.ml @@ -24,8 +24,7 @@ let build_v1 hash = (module struct let hash = hash module P = F(Env) - include P - include Updater.LiftProtocol(Name)(Env)(P) + include Env.Lift(P) let complete_b58prefix = Env.Context.complete end : T) @@ -70,8 +69,7 @@ module Register versions hash (module struct let hash = hash - include Proto - include Updater.LiftProtocol(Name)(Env)(Proto) + include Env.Lift(Proto) let complete_b58prefix = Env.Context.complete end : T) diff --git a/src/lib_protocol_updater/updater.ml b/src/lib_protocol_updater/updater.ml index 256fb1134..e63469262 100644 --- a/src/lib_protocol_updater/updater.ml +++ b/src/lib_protocol_updater/updater.ml @@ -101,41 +101,20 @@ end include Raw +module type NODE_PROTOCOL = Protocol_environment.T + with type context := Context.t + and type validation_result := validation_result + and type quota := quota + and type rpc_context := rpc_context + and type 'a tzresult := 'a tzresult + module Node_protocol_environment_sigs = struct - 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 + module type V1 = Protocol_environment.V1 + with type Context.t = Context.t + and type Updater.validation_result = validation_result + and type Updater.quota = quota + and type Updater.rpc_context = rpc_context end @@ -143,79 +122,3 @@ 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 - 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 - -module LiftProtocol - (Name : sig val name: string end) - (Env : Node_protocol_environment_sigs.V1) - (P : Env.Updater.PROTOCOL) = struct - include P - let precheck_block - ~ancestor_context ~ancestor_timestamp - raw_block = - precheck_block - ~ancestor_context ~ancestor_timestamp - raw_block >|= Env.wrap_error - let begin_application - ~predecessor_context ~predecessor_timestamp - ~predecessor_fitness - raw_block = - begin_application - ~predecessor_context ~predecessor_timestamp - ~predecessor_fitness - raw_block >|= Env.wrap_error - let begin_construction - ~predecessor_context ~predecessor_timestamp - ~predecessor_level ~predecessor_fitness - ~predecessor ~timestamp ?proto_header () = - begin_construction - ~predecessor_context ~predecessor_timestamp - ~predecessor_level ~predecessor_fitness - ~predecessor ~timestamp ?proto_header () >|= Env.wrap_error - let current_context c = - current_context c >|= Env.wrap_error - let apply_operation c o = - apply_operation c o >|= Env.wrap_error - let finalize_block c = finalize_block c >|= Env.wrap_error - let parse_operation h b = parse_operation h b |> Env.wrap_error - let configure_sandbox c j = - configure_sandbox c j >|= Env.wrap_error -end diff --git a/src/lib_protocol_updater/updater.mli b/src/lib_protocol_updater/updater.mli index 855038e01..82c2cb716 100644 --- a/src/lib_protocol_updater/updater.mli +++ b/src/lib_protocol_updater/updater.mli @@ -41,39 +41,22 @@ type rpc_context = { val compiler_name: string +module type NODE_PROTOCOL = Protocol_environment.T + with type context := Context.t + and type validation_result := validation_result + and type quota := quota + and type rpc_context := rpc_context + and type 'a tzresult := 'a tzresult + 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 + include Protocol_environment.V1 + with type Context.t = Context.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 @@ -81,48 +64,3 @@ 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 - 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 - -module LiftProtocol(Name : sig val name: string end) - (Env : Node_protocol_environment_sigs.V1) - (P : Env.Updater.PROTOCOL) : - NODE_PROTOCOL with type operation := P.operation - and type validation_state := P.validation_state diff --git a/src/proto_alpha/lib_client/client_proto_context_commands.ml b/src/proto_alpha/lib_client/client_proto_context_commands.ml index 9897adb42..40fe18ab5 100644 --- a/src/proto_alpha/lib_client/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client/client_proto_context_commands.ml @@ -252,7 +252,7 @@ let commands () = @@ Protocol_hash.param ~name:"version" ~desc:"protocol version (b58check)" @@ prefixes [ "with" ; "key" ] - @@ Environment.Ed25519.Secret_key.param + @@ Ed25519.Secret_key.param ~name:"password" ~desc:"dictator's key" @@ stop) begin fun () hash seckey cctxt -> @@ -267,7 +267,7 @@ let commands () = @@ Protocol_hash.param ~name:"version" ~desc:"protocol version (b58check)" @@ prefixes [ "with" ; "key" ] - @@ Environment.Ed25519.Secret_key.param + @@ Ed25519.Secret_key.param ~name:"password" ~desc:"dictator's key" @@ stop) begin fun () hash seckey cctxt ->