Proto/env: move signature from Updater to Protocol_environment

src/lib_base/jbuild

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

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
+    module type PROTOCOL =
-      open Error_monad
+      T with type context := Context.t
-      val max_block_length: int
+         and type quota := Updater.quota
-      val validation_passes: quota list
+         and type validation_result := Updater.validation_result
-      type operation
+         and type rpc_context := Updater.rpc_context
-      val parse_operation:
+         and type 'a tzresult := 'a Error_monad.tzresult
-        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
@@ -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
 
 

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
+

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

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 Env.Lift(P)
-    include Updater.LiftProtocol(Name)(Env)(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 Env.Lift(Proto)
-        include Updater.LiftProtocol(Name)(Env)(Proto)
         let complete_b58prefix = Env.Context.complete
       end : T)
 

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
+  module type V1 = Protocol_environment.V1
-
+    with type Context.t = Context.t
-    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
 
@@ -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

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
+    include Protocol_environment.V1
-      with type Format.formatter = Format.formatter
+      with type Context.t = Context.t
-       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
 
@@ -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

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