Skip to content
This repository
Newer
Older
100644 115 lines (95 sloc) 4.057 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
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
24 (* todo: extend with details *)
25 let read_op_to_string = function
26 | Badop.Stat _ -> "Stat"
27 | Badop.Contents _ -> "Contents"
28 | Badop.Children _ -> "Children"
29 | Badop.Revisions _ -> "Revisions"
30 | Badop.Search _ -> "Search"
31
32 let write_op_to_string = function
33 | Badop.Set _ -> "Set"
34 | Badop.Clear _ -> "Clear"
35 | Badop.Link _ -> "Link"
36 | Badop.Copy _ -> "Copy"
37
38 module F (Bk: Badop.S) = struct
39 type database = { db: Bk.database; db_pfx: string; mutable last_id: int }
40 type transaction = { id: int; tr: Bk.transaction; pfx: string }
41 type revision = Bk.revision
42
43 let print pfx fmt = Printf.eprintf ("%s"^^fmt^^"\n%!") pfx
44 let new_id xdb = xdb.last_id <- xdb.last_id + 1; xdb.last_id
45
46 (* todo: add option to print messages also at the end of operations *)
47
48 let open_database options k =
49 let pfx, bk_options = match options with
50 | Badop.Options_Debug (pfx,bk_options) -> pfx, bk_options
51 | _ -> assert false
52 in
53 print pfx "Opening database";
54 Bk.open_database bk_options @> fun db -> { db = db; db_pfx = pfx; last_id = 0 } |> k
55
56 let close_database xdb k =
57 print xdb.db_pfx "Closing database";
58 Bk.close_database xdb.db @> k
59
60 let status xdb k = Bk.status xdb.db @> fun st -> Badop.Layer("Wrapper_template", st) |> k
61
62 module Tr = struct
63 let start xdb k =
64 let id = new_id xdb in print xdb.db_pfx "Transaction %d: START" id;
65 Bk.Tr.start xdb.db
66 @> fun tr -> { tr = tr; id = id; pfx = xdb.db_pfx } |> k
67 let start_at_revision xdb rev k =
68 let id = new_id xdb in print xdb.db_pfx "Transaction %d: START (at revision %s)" id (Bk.Debug.revision_to_string rev);
69 Bk.Tr.start_at_revision xdb.db rev
70 @> fun tr -> { tr = tr; id = id; pfx = xdb.db_pfx } |> k
71 let prepare xtr k =
72 print xtr.pfx "Transaction %d: PREPARE" xtr.id;
73 Bk.Tr.prepare xtr.tr @> fun (tr,ok) -> ({ xtr with tr = tr }, ok) |> k
74 let commit xtr k =
75 print xtr.pfx "Transaction %d: COMMIT" xtr.id;
76 Bk.Tr.commit xtr.tr @> k
77 let abort xtr k =
78 print xtr.pfx "Transaction %d: ABORT" xtr.id;
79 Bk.Tr.abort xtr.tr @> k
80 end
81
82 type 'which read_op = 'which Bk.read_op
83 type 'which write_op = ('which,transaction,revision) Badop.generic_write_op
84
85 let read xtr path read_op k =
86 print xtr.pfx "%d> READ.%s at %s" xtr.id (read_op_to_string read_op) (Path.to_string path);
87 Bk.read xtr.tr path read_op @> k
88
89 let write xtr path write_op k =
90 print xtr.pfx "%d> WRITE.%s at %s" xtr.id (write_op_to_string write_op) (Path.to_string path);
91 Badop.Aux.map_write_op ~transaction:(fun xtr k -> xtr.tr |> k) ~revision:(fun r k -> r |> k) write_op
92 @> fun write_op ->
93 Bk.write xtr.tr path write_op
94 @> fun resp ->
95 Badop.Aux.map_write_op
96 ~transaction:(fun tr k -> { xtr with tr = tr } |> k)
97 ~revision:(fun r k -> r |> k)
98 resp
99 @> k
100
101 let write_list xtr path_write_op_list k =
102 print xtr.pfx "%d> WRITE_LIST:\n" xtr.id;
103 let wr xtr (path, op) k =
104 write xtr path op (fun resp -> Badop.Aux.result_transaction resp |> k)
105 in
106 Cps.List.fold wr xtr path_write_op_list k
107
108 let node_properties xdb config k =
109 print xdb.db_pfx "Set node configuration";
110 Bk.node_properties xdb.db config @> k
111
112 module Debug = struct
113 let revision_to_string = Bk.Debug.revision_to_string
114 end
115 end
Something went wrong with that request. Please try again.