Add v1 serialisation formats

src/irmin-git/irmin_git.ml

@@ -210,6 +210,7 @@ module Make_private
       let metadata_t = Metadata.t
       let hash_t = Key.t
       let step_t = Path.step_t
+      let default = Metadata.default
 
       let value_t =
         let open Irmin.Type in

src/irmin/commit.ml

@@ -445,3 +445,57 @@ module History (S: S.COMMIT_STORE) = struct
       | Some c -> lca t ~info ?max_depth ?n (c::cs)
 
 end
+
+module V1 (C: S.COMMIT) = struct
+
+  module K = struct
+
+    let h = Type.string_of `Int64
+
+    let size_of x =
+      Type.size_of h (Type.to_bin_string C.hash_t x)
+
+    let encode_bin buf off e =
+      Type.encode_bin h buf off (Type.to_bin_string C.hash_t e)
+
+    let decode_bin buf off =
+      let n, v = Type.decode_bin h buf off in
+      n, match Type.of_bin_string C.hash_t v with
+      | Ok v -> v
+      | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e
+
+    let t = Type.like C.hash_t ~bin:(encode_bin, decode_bin, size_of)
+
+  end
+
+  type hash = C.hash
+  let hash_t = K.t
+
+  type t = {
+    parents: hash list;
+    c: C.t;
+  }
+
+  let node t = C.node t.c
+  let parents t = t.parents
+  let info t = C.info t.c
+
+  let v ~info ~node ~parents = { parents; c = C.v ~node ~parents ~info }
+
+  let info_t: Info.t Type.t =
+    let open Type in
+    record "info" (fun date author message -> Info.v ~date ~author message)
+    |+ field "date"    int64  (fun t -> Info.date t)
+    |+ field "author"  (string_of `Int64) (fun t -> Info.author t)
+    |+ field "message" (string_of `Int64) (fun t -> Info.message t)
+    |> sealr
+
+  let t: t Type.t =
+    let open Type in
+    record "commit" (fun node parents info -> v ~info ~node ~parents)
+    |+ field "node"    K.t                     node
+    |+ field "parents" (list ~len:`Int64 K.t)  parents
+    |+ field "info"    info_t                  info
+    |> sealr
+
+end

src/irmin/commit.mli

@@ -16,8 +16,7 @@
 
 (** Manage the database history. *)
 
-module Make (K: Type.S):
-  S.COMMIT with type hash = K.t
+module Make (K: Type.S): S.COMMIT with type hash = K.t
 
 module Store
     (N: S.NODE_STORE)
@@ -39,3 +38,5 @@ module History (C: S.COMMIT_STORE):
                     and type v = C.Val.t
                     and type node = C.Node.key
                     and type commit = C.key
+
+module V1 (C: S.COMMIT): S.COMMIT with type hash = C.hash

src/irmin/contents.ml

@@ -298,3 +298,15 @@ struct
     Merge.like_lwt Type.(option Key.t) Val.merge (read_opt t) (add_opt t)
 
 end
+
+module V1 = struct
+
+  module String = struct
+    include String
+
+    let t =
+      Type.(like_map (pair unit (string_of `Int64)))
+        (fun (_, x) -> x) (fun x -> (), x)
+  end
+
+end

src/irmin/contents.mli

@@ -39,6 +39,10 @@ module Json_tree(Store: S.STORE with type contents = json): sig
   val set : Store.t -> Store.key -> json -> info:Info.f -> unit Lwt.t
 end
 
+module V1: sig
+  module String: S.CONTENTS with type t = string
+end
+
 module Store
     (C: sig
        include S.CONTENT_ADDRESSABLE_STORE

src/irmin/hash.ml

@@ -49,3 +49,28 @@ module With_digest (K: S.HASH) (V: Type.S) = struct
   include K
   let digest v = K.digest (Type.to_bin_string V.t v)
 end
+
+module V1 (K: S.HASH): S.HASH with type t = K.t = struct
+
+  type t = K.t
+  let hash = K.hash
+  let digest = K.digest
+  let digest_size = K.digest_size
+
+  let h = Type.string_of `Int64
+
+  let size_of x =
+    Type.size_of h (Type.to_bin_string K.t x)
+
+  let encode_bin buf off e =
+    Type.encode_bin h buf off (Type.to_bin_string K.t e)
+
+  let decode_bin buf off =
+    let n, v = Type.decode_bin h buf off in
+    n, match Type.of_bin_string K.t v with
+    | Ok v -> v
+    | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e
+
+  let t = Type.like K.t ~bin:(encode_bin, decode_bin, size_of)
+
+end

src/irmin/hash.mli

@@ -31,3 +31,5 @@ module With_digest (K: S.HASH) (V: Type.S): sig
   include S.HASH with type t = K.t
   val digest: V.t -> t
 end
+
+module V1 (H: S.HASH): S.HASH with type t = H.t

src/irmin/irmin.mli

@@ -1044,6 +1044,9 @@ module Hash: sig
   module BLAKE2B: S
   module BLAKE2S: S
 
+  module V1 (H: S): S with type t = H.t
+  (** v1 serialisation *)
+
 end
 
 (** [Metadata] defines metadata that is attached to contents but stored in
@@ -1136,6 +1139,13 @@ module Contents: sig
   module Json_value: S with type t = json
   (** [Json_value] allows any kind of json value to be stored, not only objects. *)
 
+  module V1: sig
+
+    module String: S with type t = string
+    (** Same as {!String} but use v1 serialisation format. *)
+
+  end
+
   (** Contents store. *)
   module type STORE = sig
 
@@ -1532,6 +1542,9 @@ module Private: sig
       val t: t Type.t
       (** [t] is the value type for {!t}. *)
 
+      val default: metadata
+      (** [default] is the default metadata value. *)
+
       val metadata_t: metadata Type.t
       (** [metadata_t] is the value type for {!metadata}. *)
 
@@ -1546,13 +1559,19 @@ module Private: sig
 
     end
 
-    (** [Node] provides a simple node implementation, parameterized by
+    (** [Make] provides a simple node implementation, parameterized by
         the contents and notes keys [K], paths [P] and metadata [M]. *)
     module Make (K: Type.S) (P: Path.S) (M: Metadata.S):
       S with type hash = K.t
          and type step = P.step
          and type metadata = M.t
 
+    (** v1 serialisation *)
+    module V1 (S: S):
+      S with type hash = S.hash
+           and type step = S.step
+           and type metadata = S.metadata
+
     (** [STORE] specifies the signature for node stores. *)
     module type STORE = sig
 
@@ -1747,8 +1766,10 @@ module Private: sig
 
     (** [Make] provides a simple implementation of commit values,
         parameterized by the commit and node keys [K]. *)
-    module Make (K: Type.S):
-      S with type hash = K.t
+    module Make (K: Type.S): S with type hash = K.t
+
+    module V1 (S: S): S with type hash = S.hash
+    (** V1 serialisation. *)
 
     (** [STORE] specifies the signature for commit stores. *)
     module type STORE = sig

src/irmin/node.ml

@@ -98,6 +98,7 @@ struct
   let step_t = P.step_t
   let hash_t = K.t
   let metadata_t = M.t
+  let default = M.default
 
   let value_t =
     let open Type in
@@ -366,3 +367,116 @@ module Graph (S: S.NODE_STORE) = struct
     |> sealv
 
 end
+
+module V1 (N: S.NODE) = struct
+
+  module K = struct
+
+    let h = Type.string_of `Int64
+
+    let size_of x =
+      Type.size_of h (Type.to_bin_string N.hash_t x)
+
+    let encode_bin buf off e =
+      Type.encode_bin h buf off (Type.to_bin_string N.hash_t e)
+
+    let decode_bin buf off =
+      let n, v = Type.decode_bin h buf off in
+      n, match Type.of_bin_string N.hash_t v with
+      | Ok v -> v
+      | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e
+
+    let t = Type.like N.hash_t ~bin:(encode_bin, decode_bin, size_of)
+
+  end
+
+  type step = N.step
+  type hash = N.hash
+  type metadata = N.metadata
+  type value = N.value
+
+  let hash_t = N.hash_t
+  let metadata_t = N.metadata_t
+
+  type v =
+    | N of N.t
+    | V of (step * value) list
+    | Both of N.t * (step * value) list
+
+  type t = { mutable v: v }
+
+  let v l = { v = V l }
+
+  let list t = match t.v with
+    | V l | Both (_, l) -> l
+    | N n ->
+      let l = N.list n in
+      t.v <- Both (n, l);
+      l
+
+  let empty = { v = Both (N.empty, []) }
+
+  let is_empty t = match t.v with
+    | V l | Both (_, l) -> l = []
+    | N n -> N.is_empty n
+
+  let default = N.default
+
+  let to_n t = match t.v with
+    | N n | Both (n, _) -> n
+    | V l ->
+      let n = N.v l in
+      t.v <- Both (n, l);
+      n
+
+  let find t k = N.find (to_n t) k
+
+  let update t k v =
+    let n1 = to_n t in
+    let n2 = N.update n1 k v in
+    if n1 == n2 then t else (
+      t.v <- N n2;
+      t
+    )
+
+  let remove t k =
+    let n1 = to_n t in
+    let n2 = N.remove n1 k in
+    if n1 == n2 then t else (
+      t.v <- N n2;
+      t
+    )
+
+  let step_t: step Type.t =
+    let to_string p = Type.to_bin_string N.step_t p in
+    let of_string s =
+      Type.of_bin_string N.step_t s |> function
+      | Ok x -> x
+      | Error (`Msg e) -> Fmt.failwith "Step.of_string: %s" e
+    in
+    Type.(like_map (string_of `Int64)) of_string to_string
+
+  let value_t =
+    let open Type in
+    record "node" (fun contents metadata node ->
+        match contents, metadata, node with
+        | Some c, None  , None   -> `Contents (c, N.default)
+        | Some c, Some m, None   -> `Contents (c, m)
+        | None  , None  , Some n -> `Node n
+        | _ -> failwith "invalid node")
+    |+ field "contents" (option K.t) (function
+        | `Contents (x, _) -> Some x
+        | _ -> None)
+    |+ field "metadata" (option N.metadata_t) (function
+        | `Contents (_, x) when not (equal N.metadata_t N.default x) -> Some x
+        | _ -> None)
+    |+ field "node" (option K.t) (function
+        | `Node n -> Some n
+        | _ -> None)
+    |> sealr
+
+
+  let t: t Type.t =
+    Type.like_map Type.(list ~len:`Int64 (pair step_t value_t)) v list
+
+end

src/irmin/node.mli

@@ -52,3 +52,8 @@ module Graph (N: S.NODE_STORE):
                 and type node = N.key
                 and type step = N.Path.step
                 and type path = N.Path.t
+
+module V1 (N: S.NODE): S.NODE
+  with type hash = N.hash
+   and type step = N.step
+   and type metadata = N.metadata

src/irmin/s.ml

@@ -90,6 +90,7 @@ module type NODE = sig
   val update: t -> step -> value -> t
   val remove: t -> step -> t
   val t: t Type.t
+  val default: metadata
   val metadata_t: metadata Type.t
   val hash_t: hash Type.t
   val step_t: step Type.t