1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
type t = string list
let this = []
let ( @/ ) x y = x :: y
let of_list segments = segments
let to_list path = path
let to_string path =
path
|> List.map (fun x ->
BatString.nreplace ~str:(BatString.nreplace ~str:x ~sub:"^" ~by:"^^") ~sub:"\\" ~by:"^\\" )
|> BatIO.to_string (BatList.print ~first:"\\" ~last:"" ~sep:"\\" BatString.print)
module Error = struct
open Concepts.Condition
let path_not_found path =
condition "path-not-found" "A given path was not found under the specified object"
("path" |=| Concepts.Value.String (to_string path))
let overlapping_change path =
condition "overlapping-change"
"A batch of changes both replaced an object and changed inside it"
("path" |=| Concepts.Value.String (to_string path))
end
let walking f g handle path =
let rec walk handle = function
| [] -> g handle
| x :: xs -> (
let open Utilities.Result in
let open Protocols in
let* dir =
Handle.require Directory.from handle
|> Result.map_error
Concepts.Condition.(complement ("before-segment" |=| Concepts.Value.String x))
in
let* elem = Directory.find dir x in
match elem with
| None -> Error (Error.path_not_found path)
| Some elem -> f x handle (fun () -> walk elem xs) )
in
walk handle path
|> Result.map_error
Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path)))
(* Handles we find in the middle of a walk get released once we're
done with them, but never the caller's root. If you leak one and
its refcount never drops, nothing under that path gets collected,
and an exclusive object, like a session, stays locked forever. *)
let releasing root handle f =
Fun.protect ~finally:(fun () -> if handle != root then Protocols.Handle.release handle) f
let lookup handle path = walking (fun _ parent -> releasing handle parent) Result.ok handle path
let update handle path key reference value =
let open Utilities.Result in
let open Protocols in
let* target = lookup handle path in
releasing handle target (fun () ->
let* registry = Handle.require Registry.from target in
Registry.update registry key reference value )
(* Changes under the same name are applied to the child together, so
every object on the way is derived once however many changes reach
it: a batch of changes to a branch is one successor state. *)
let assoc_all handle changes =
let open Utilities.Result in
let open Protocols in
let assoc_on node (key, value) =
let* a = Handle.require Associative.from node in
let* a' = Associative.update a key value in
Ok (Handle.from a')
in
let rec apply prefix node changes =
let here, below = List.partition (fun (path, _, _) -> path = []) changes in
let segments =
List.fold_left
(fun segments (path, _, _) ->
let x = List.hd path in
if List.mem x segments then segments else segments @ [x] )
[] below
in
let beneath x =
List.filter_map
(fun (path, key, value) ->
match path with y :: rest when y = x -> Some (rest, key, value) | _ -> None )
below
in
match List.find_opt (fun (_, key, _) -> List.mem key segments) here with
| Some (_, key, _) -> Error (Error.overlapping_change (prefix @ [key]))
| None ->
let* children =
List.map
(fun x ->
let* dir = Handle.require Directory.from node in
let* found = Directory.find dir x in
match found with
| None -> Error (Error.path_not_found (prefix @ [x]))
| Some child ->
releasing handle child (fun () -> apply (prefix @ [x]) child (beneath x))
|> Result.map (fun child' -> x, Some child') )
segments
|> Utilities.List.sequence
in
(* each step derives from the last; only the steps in between are
ours to release *)
List.fold_left
(fun current change ->
let* current = current in
let* next = assoc_on current change in
if current != node then Handle.release current;
Ok next )
(Ok node)
(children @ List.map (fun (_, key, value) -> key, value) here)
in
apply [] handle changes
let assoc handle path key value = assoc_all handle [path, key, value]
let diff a b =
let open Utilities.Result in
let open Protocols in
let address h = Option.map Addressable.address (Addressable.from h) in
let same x y =
match address x, address y with
| Some p, Some q -> Concepts.Hash.hash_equals p q
| _ -> Handle.equal x y
in
let names h =
let* dir = Handle.require Directory.from h in
let* names = Directory.list dir in
Ok (BatFingerTree.to_list names)
in
let find h name =
let* dir = Handle.require Directory.from h in
Directory.find dir name
in
let rec walk prefix a b =
let* left = names a in
let* right = names b in
List.sort_uniq String.compare (left @ right)
|> List.map (fun name ->
let path = prefix @ [name] in
let* x = find a name in
let* y = find b name in
Fun.protect
~finally:(fun () -> List.iter Handle.release (Option.to_list x @ Option.to_list y))
(fun () ->
match x, y with
| None, None -> Ok []
| Some x, Some y when same x y -> Ok []
| Some x, Some y when Directory.from x <> None && Directory.from y <> None ->
let* below = walk path x y in
Ok (if below = [] then [path] else below)
| _ -> Ok [path] ) )
|> Utilities.List.sequence
|> Result.map List.concat
in
walk [] a b
|
