Protocol_environment: more sharing between node and client

src/lib_base/protocol_environment.ml

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

src/lib_base/tzPervasives.ml

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

src/lib_base/tzPervasives.mli

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

src/lib_protocol_compiler/jbuild_embedded_protocol_template

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

src/lib_protocol_environment_client/fake.ml

@@ -7,27 +7,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-module Make(Param : sig val name: string end)() = struct
+module Make(Param : sig val name: string end)() =
-
+  Tezos_base.Protocol_environment.MakeV1
-  include Tezos_base.Protocol_environment.Make(Param)()
+    (Param)(Fake_context)(Fake_updater.Make(Fake_context))()
-
-  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

src/lib_protocol_environment_client/fake_context.ml

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

src/lib_protocol_environment_client/fake_context.mli

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

src/lib_protocol_environment_client/fake_updater.ml

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

src/lib_protocol_environment_client/fake_updater.mli

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

src/lib_protocol_updater/tezos_protocol_environment.ml

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

src/lib_protocol_updater/updater.ml

@@ -11,6 +11,8 @@ open Logging.Updater
 
 let (//) = Filename.concat
 
+module Raw = struct
+
   type validation_result = {
     context: Context.t ;
     fitness: Fitness.t ;
@@ -92,6 +94,10 @@ let compile hash p =
       Lwt.return loaded
     end
 
+end
+
+include Raw
+
 module Node_protocol_environment_sigs = struct
 
   module type V1 = sig
@@ -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
+module MakeV1(Name : sig val name: string end)()
-  type error = ..
+  : Node_protocol_environment_sigs.V1 =
-  type 'a tzresult = ('a, error list) result
+  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)

src/lib_protocol_updater/updater.mli

@@ -37,9 +37,52 @@ type rpc_context = {
   context: Context.t ;
 }
 
-module type RAW_PROTOCOL = sig
+(* The end of this file is not exported to the protocol... *)
-  type error = ..
+
-  type 'a tzresult = ('a, error list) result
+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) :

src/lib_shell/state.ml

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

src/lib_storage/context.ml

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

src/lib_storage/context.mli

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

src/lib_storage/test/test_context.ml

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