vblt.org
forked from
gazagnaire.org/irmin
Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
1(** Persistent pointers to OCaml values. *)
2
3(* Address is a hex-encoded hash - algorithm agnostic *)
4type address = string
5
6(* Content store - fetch/persist functions shared by links *)
7type content_store = {
8 fetch : address -> string option;
9 persist : string -> address;
10}
11
12(* Links embed their content store *)
13
14type 'a t = { content : content_store; mutable location : 'a location }
15
16and 'a location =
17 | In_memory of 'a (* value not yet persisted *)
18 | At of address (* persisted but not in memory, needs fetch *)
19 | Both of 'a * address (* in memory and persisted *)
20
21(* Stores - parameterized by root type *)
22
23type 'a store = {
24 content : content_store;
25 mutable root : 'a option;
26 mutable open' : bool;
27}
28
29(* Serialization - placeholder, needs repr for production *)
30let encode v = Marshal.to_string v [ Marshal.No_sharing ]
31let decode s = Marshal.from_string s 0
32
33(* Links *)
34
35let v (s : _ store) x = { content = s.content; location = In_memory x }
36let of_address (s : _ store) addr = { content = s.content; location = At addr }
37
38let get l =
39 match l.location with
40 | In_memory x | Both (x, _) -> x
41 | At addr -> (
42 match l.content.fetch addr with
43 | None -> failwith (Printf.sprintf "Link.get: address not found: %s" addr)
44 | Some data ->
45 let x = decode data in
46 l.location <- Both (x, addr);
47 x)
48
49let address l =
50 match l.location with
51 | In_memory x ->
52 let data = encode x in
53 let addr = l.content.persist data in
54 l.location <- Both (x, addr);
55 addr
56 | At addr | Both (_, addr) -> addr
57
58let equal l0 l1 = address l0 = address l1
59
60let is_val l =
61 match l.location with In_memory _ | Both _ -> true | At _ -> false
62
63let pp ppf l =
64 match l.location with
65 | In_memory _ -> Format.fprintf ppf "<mem>"
66 | At addr | Both (_, addr) ->
67 Format.fprintf ppf "%s" (String.sub addr 0 (min 7 (String.length addr)))
68
69(* Store operations *)
70
71let read (s : 'a store) : 'a =
72 match s.root with Some x -> x | None -> failwith "Link.read: no root set"
73
74let write (s : 'a store) (x : 'a) : unit =
75 if not s.open' then failwith "Link.write: store is closed";
76 s.root <- Some x
77
78let is_open s = s.open'
79let close s = s.open' <- false
80
81(* Store creation functor *)
82
83module Make (F : Codec.S) = struct
84 let v () =
85 let tbl = Hashtbl.create 128 in
86 let content =
87 {
88 fetch = Hashtbl.find_opt tbl;
89 persist =
90 (fun data ->
91 let addr = F.hash_to_hex (F.hash_contents data) in
92 Hashtbl.replace tbl addr data;
93 addr);
94 }
95 in
96 { content; root = None; open' = true }
97end
98
99module Git = Make (Codec.Git)
100module Mst = Make (Codec.Mst)