Proto/env: move signature from Updater to Protocol_environment

This commit is contained in:
Grégoire Henry 2018-02-11 19:17:39 +01:00
parent c9822abab7
commit 4d69404049
8 changed files with 302 additions and 225 deletions

View File

@ -17,6 +17,7 @@
tezos-error-monad
tezos-rpc
tezos-micheline
tezos-protocol-environment-sigs
calendar
ezjsonm
lwt.unix

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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 ->