Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 144 lines (126 sloc) 5.421 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 @author Louis Gesbert
20 **)
21
22 open Cps.Ops
23 module D = Badop.Dialog
24
25 module F (Bk: Badop.S) = struct
26 type database = Bk.database
27 type transaction = Bk.transaction
28 type revision = Bk.revision
29
30 let open_database options k = Bk.open_database options @> k
31 let close_database db k = Bk.close_database db @> k
32 let status db k = Bk.status db @> fun st -> Badop.Layer("Workaround", st) |> k
33
34
35 module Tr = struct
36 let start db k = Bk.Tr.start db @> k
37 let start_at_revision db rev k = Bk.Tr.start_at_revision db rev @> k
38 let prepare tr k = Bk.Tr.prepare tr @> k
39 let commit tr k = Bk.Tr.commit tr @> k
40 let abort tr k = Bk.Tr.abort tr @> k
41 end
42
43 type 'which read_op = 'which Bk.read_op
44 type 'which write_op = 'which Bk.write_op
45
46 let follow_path tr path ?(no_follow_last=false) k =
47 let rec aux origin pathlst k = match pathlst with
48 | [] ->
49 origin |> k
50 | [key] when no_follow_last ->
51 Path.add origin key |> k
52 | key::pathlst ->
53 let path = Path.add origin key in
54 Bk.read tr path (Badop.Stat (D.query ()))
55 @> function
56 | `Answer (Badop.Stat (D.Response (real_path, _, _))) ->
57 #<If:BADOP_DEBUG$minlevel 10>
58 if path <> real_path then
59 Printf.eprintf ">> follow_path: following %s => %s\n"
60 (Path.to_string path) (Path.to_string real_path)
61 #<End>;
62 aux real_path pathlst @> k
63 | `Answer _ -> assert false
64 | `Absent | `Linkto _ ->
65 #<If:BADOP_DEBUG$minlevel 10>
66 Printf.eprintf ">> follow_path: stopping at %s/( %s )\n"
67 (Path.to_string origin) (Path.to_string (Path.of_list (key::pathlst)))
68 #<End>;
69 Path.concat path (Path.of_list pathlst) |> k
70 in
71 aux Path.root (Path.to_list path)
72 @> fun path2 ->
73 #<If:BADOP_DEBUG$minlevel 10>
74 Printf.eprintf ">> create_path: %s finally got to %s\n" (Path.to_string path) (Path.to_string path2)
75 #<End>;
76 path2 |> k
77
78 let read tr path read_op k =
79 follow_path tr path
80 ~no_follow_last:(match read_op with
81 | Badop.Stat _ | Badop.Revisions _ -> true
82 | Badop.Contents _ | Badop.Children _ | Badop.Search _ -> false)
83 @> fun path -> Bk.read tr path read_op @> k
84
85 let create_path tr path ?(no_follow_last=false) k =
86 let rec aux tr origin pathlst k = match pathlst with
87 | [] -> (tr,origin) |> k
88 | [key] when no_follow_last -> (tr, Path.add origin key) |> k
89 | key::pathlst ->
90 let path = Path.add origin key in
91 Bk.read tr path (Badop.Stat (D.query ()))
92 @> function
93 | `Answer (Badop.Stat (D.Response (real_path, _, _))) ->
94 #<If:BADOP_DEBUG$minlevel 10>
95 if path <> real_path then
96 Printf.eprintf ">> create_path: following %s => %s\n"
97 (Path.to_string path) (Path.to_string real_path)
98 #<End>;
99 aux tr real_path pathlst @> k
100 | `Answer _ -> assert false
101 | `Absent | `Linkto _ ->
102 if pathlst = [] then (tr,path) |> k
103 else
104 (#<If:BADOP_DEBUG$minlevel 10>
105 Printf.eprintf ">> create_path: %s doesn't exist, create\n" (Path.to_string path)
106 #<End>;
107 Bk.write tr path (Badop.Set (D.query Badop.Data.Unit))
108 @> function
109 | Badop.Set (D.Response tr) -> (* todo: do not continue checking subpaths for exist/link *)
110 aux tr path pathlst @> k
111 | _ -> assert false)
112 in
113 aux tr Path.root (Path.to_list path)
114 @> fun (tr,path2) ->
115 #<If:BADOP_DEBUG$minlevel 10>
116 Printf.eprintf ">> create_path: %s finally got to %s\n" (Path.to_string path) (Path.to_string path2)
117 #<End>;
118 (tr,path2) |> k
119
120 let write tr path write_op k =
121 match write_op with
122 | Badop.Clear _ ->
123 follow_path tr path ~no_follow_last:true
124 @> fun path -> Bk.write tr path write_op @> k
125 | _ ->
126 create_path tr path
127 ~no_follow_last:(match write_op with
128 | Badop.Link _ | Badop.Clear _ -> true
129 | Badop.Set _ | Badop.Copy _ -> false)
130 @> fun (tr,path) -> Bk.write tr path write_op @> k
131
132 let write_list trans path_op_list k =
133 let wr trans (path, op) k =
134 write trans path op (fun resp -> Badop.Aux.result_transaction resp |> k)
135 in
136 Cps.List.fold wr trans path_op_list k
137
138 let node_properties db config k = Bk.node_properties db config @> k
139
140 module Debug = struct
141 let revision_to_string = Bk.Debug.revision_to_string
142 end
143 end
Something went wrong with that request. Please try again.