Add copy to the proto raw_context

src/proto_alpha/lib_protocol/src/raw_context.ml

@@ -41,7 +41,7 @@ let set_current_fitness ctxt fitness = { ctxt with fitness }
 
 type storage_error =
   | Incompatible_protocol_version of string
-  | Missing_key of string list * [`Get | `Set | `Del]
+  | Missing_key of string list * [`Get | `Set | `Del | `Copy]
   | Existing_key of string list
   | Corrupted_data of string list
 
@@ -85,6 +85,10 @@ let pp_storage_error ppf = function
       Format.fprintf ppf
         "Cannot delete undefined key '%s'."
         (String.concat "/" key)
+  | Missing_key (key, `Copy) ->
+      Format.fprintf ppf
+        "Cannot copy undefined key '%s'."
+        (String.concat "/" key)
   | Existing_key key ->
       Format.fprintf ppf
         "Cannot initialize defined key '%s'."
@@ -330,6 +334,7 @@ module type T = sig
   val delete: context -> key -> context tzresult Lwt.t
   val remove: context -> key -> context Lwt.t
   val remove_rec: context -> key -> context Lwt.t
+  val copy: context -> from:key -> to_:key -> context tzresult Lwt.t
 
   val fold:
     context -> key -> init:'a ->
@@ -397,6 +402,12 @@ let remove_rec ctxt k =
   Context.remove_rec ctxt.context k >>= fun context ->
   Lwt.return { ctxt with context }
 
+let copy ctxt ~from ~to_ =
+  Context.copy ctxt.context ~from ~to_ >>= function
+  | None -> storage_error (Missing_key (from, `Copy))
+  | Some context ->
+      return { ctxt with context }
+
 let fold ctxt k ~init ~f =
   Context.fold ctxt.context k ~init ~f
 

src/proto_alpha/lib_protocol/src/raw_context.mli

@@ -12,7 +12,7 @@
 (** An internal storage error that should not happen *)
 type storage_error =
   | Incompatible_protocol_version of string
-  | Missing_key of string list * [`Get | `Set | `Del]
+  | Missing_key of string list * [`Get | `Set | `Del | `Copy]
   | Existing_key of string list
   | Corrupted_data of string list
 
@@ -115,6 +115,8 @@ module type T = sig
       nothing if no bucket exists. *)
   val remove_rec: context -> key -> context Lwt.t
 
+  val copy: context -> from:key -> to_:key -> context tzresult Lwt.t
+
   (** Iterator on all the items of a given directory. *)
   val fold:
     context -> key -> init:'a ->

src/proto_alpha/lib_protocol/src/storage_functors.ml

@@ -53,6 +53,7 @@ module Make_subcontext (C : Raw_context.T) (N : NAME)
   let delete t k = C.delete t (to_key k)
   let remove t k = C.remove t (to_key k)
   let remove_rec t k = C.remove_rec t (to_key k)
+  let copy t ~from ~to_ = C.copy t ~from:(to_key from) ~to_:(to_key to_)
   let fold t k ~init ~f =
     C.fold t (to_key k) ~init
       ~f:(fun k acc -> f (map_key of_key k) acc)
@@ -288,6 +289,9 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
       C.remove t (to_key i k) >>= fun t -> Lwt.return (t, i)
     let remove_rec (t, i) k =
       C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (t, i)
+    let copy (t, i) ~from ~to_ =
+      C.copy t ~from:(to_key i from) ~to_:(to_key i to_) >>=? fun t ->
+      return (t, i)
     let fold (t, i) k ~init ~f =
       C.fold t (to_key i k) ~init
         ~f:(fun k acc -> f (map_key of_key k) acc)