-
Notifications
You must be signed in to change notification settings - Fork 125
/
badop_workaround.ml
143 lines (126 loc) · 5.31 KB
/
badop_workaround.ml
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
(*
Copyright © 2011 MLstate
This file is part of Opa.
Opa is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
Opa is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>.
*)
(*
@author Louis Gesbert
**)
open Cps.Ops
module D = Badop.Dialog
module F (Bk: Badop.S) = struct
type database = Bk.database
type transaction = Bk.transaction
type revision = Bk.revision
let open_database options k = Bk.open_database options @> k
let close_database db k = Bk.close_database db @> k
let status db k = Bk.status db @> fun st -> Badop.Layer("Workaround", st) |> k
module Tr = struct
let start db errk k = Bk.Tr.start db errk @> k
let start_at_revision db rev errk k = Bk.Tr.start_at_revision db rev errk @> k
let prepare tr k = Bk.Tr.prepare tr @> k
let commit tr k = Bk.Tr.commit tr @> k
let abort tr k = Bk.Tr.abort tr @> k
end
type 'which read_op = 'which Bk.read_op
type 'which write_op = 'which Bk.write_op
let follow_path tr path ?(no_follow_last=false) k =
let rec aux origin pathlst k = match pathlst with
| [] ->
origin |> k
| [key] when no_follow_last ->
Path.add origin key |> k
| key::pathlst ->
let path = Path.add origin key in
Bk.read tr path (Badop.Stat (D.query ()))
@> function
| `Answer (Badop.Stat (D.Response (real_path, _, _))) ->
#<If:BADOP_DEBUG$minlevel 10>
if path <> real_path then
Printf.eprintf ">> follow_path: following %s => %s\n"
(Path.to_string path) (Path.to_string real_path)
#<End>;
aux real_path pathlst @> k
| `Answer _ -> assert false
| `Absent | `Linkto _ ->
#<If:BADOP_DEBUG$minlevel 10>
Printf.eprintf ">> follow_path: stopping at %s/( %s )\n"
(Path.to_string origin) (Path.to_string (Path.of_list (key::pathlst)))
#<End>;
Path.concat path (Path.of_list pathlst) |> k
in
aux Path.root (Path.to_list path)
@> fun path2 ->
#<If:BADOP_DEBUG$minlevel 10>
Printf.eprintf ">> create_path: %s finally got to %s\n" (Path.to_string path) (Path.to_string path2)
#<End>;
path2 |> k
let read tr path read_op k =
follow_path tr path
~no_follow_last:(match read_op with
| Badop.Stat _ | Badop.Revisions _ -> true
| Badop.Contents _ | Badop.Children _ | Badop.Search _ -> false)
@> fun path -> Bk.read tr path read_op @> k
let create_path tr path ?(no_follow_last=false) k =
let rec aux tr origin pathlst k = match pathlst with
| [] -> (tr,origin) |> k
| [key] when no_follow_last -> (tr, Path.add origin key) |> k
| key::pathlst ->
let path = Path.add origin key in
Bk.read tr path (Badop.Stat (D.query ()))
@> function
| `Answer (Badop.Stat (D.Response (real_path, _, _))) ->
#<If:BADOP_DEBUG$minlevel 10>
if path <> real_path then
Printf.eprintf ">> create_path: following %s => %s\n"
(Path.to_string path) (Path.to_string real_path)
#<End>;
aux tr real_path pathlst @> k
| `Answer _ -> assert false
| `Absent | `Linkto _ ->
if pathlst = [] then (tr,path) |> k
else
(#<If:BADOP_DEBUG$minlevel 10>
Printf.eprintf ">> create_path: %s doesn't exist, create\n" (Path.to_string path)
#<End>;
Bk.write tr path (Badop.Set (D.query Badop.Data.Unit))
@> function
| Badop.Set (D.Response tr) -> (* todo: do not continue checking subpaths for exist/link *)
aux tr path pathlst @> k
| _ -> assert false)
in
aux tr Path.root (Path.to_list path)
@> fun (tr,path2) ->
#<If:BADOP_DEBUG$minlevel 10>
Printf.eprintf ">> create_path: %s finally got to %s\n" (Path.to_string path) (Path.to_string path2)
#<End>;
(tr,path2) |> k
let write tr path write_op k =
match write_op with
| Badop.Clear _ ->
follow_path tr path ~no_follow_last:true
@> fun path -> Bk.write tr path write_op @> k
| _ ->
create_path tr path
~no_follow_last:(match write_op with
| Badop.Link _ | Badop.Clear _ -> true
| Badop.Set _ | Badop.Copy _ -> false)
@> fun (tr,path) -> Bk.write tr path write_op @> k
let write_list trans path_op_list k =
let wr trans (path, op) k =
write trans path op (fun resp -> Badop.Aux.result_transaction resp |> k)
in
Cps.List.fold wr trans path_op_list k
let node_properties db config k = Bk.node_properties db config @> k
module Debug = struct
let revision_to_string = Bk.Debug.revision_to_string
end
end