Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 231 lines (213 sloc) 9.723 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 (* DB-serialisation: dump of the database, driven by the database schema --
22 which is first read from the database itself. XML format is documented in the
23 OPA stdlib, please keep up-to-date. *)
24
25 module D = Badop.Dialog
26 module G = Dbgraph
27
28 let xml_dump_version = "1.0"
29
30 (* This file follows the duck-style cps guidelines © *)
31
32 (* raises CharacterNull if character 0 encountered *)
33 exception CharacterNull
34 let escape_string ?(quote=true) s =
35 let len =
36 Base.String.fold
37 (fun acc -> function
38 | '&' -> acc + 5 (* &amp; *)
39 | '<' | '>' -> acc + 4 (* &lt; &gt; *)
40 | '"' when quote -> acc + 6 (* &quot; *)
41 | '\000' -> raise CharacterNull (* Character 0 not allowed in XML strings *)
42 | _ -> acc + 1)
43 0 s
44 in
45 let s' = String.create len in
46 let _len = Base.String.fold
47 (fun pos -> function
48 | '&' -> String.unsafe_blit "&amp;" 0 s' pos 5; pos + 5
49 | '<' -> String.unsafe_blit "&lt;" 0 s' pos 4; pos + 4
50 | '>' -> String.unsafe_blit "&gt;" 0 s' pos 4; pos + 4
51 | '"' when quote -> String.unsafe_blit "&quot;" 0 s' pos 6; pos + 6
52 | c -> String.unsafe_set s' pos c; pos + 1)
53 0 s
54 in s'
55
56 let rec key_to_xml = function
57 | Badop.Key.IntKey i -> string_of_int i
58 | Badop.Key.StringKey s ->
59 (try Printf.sprintf "\"%s\"" (escape_string s) with
60 | CharacterNull -> Printf.sprintf "<base64>%s</base64>" (Base.String.base64encode s))
61 | Badop.Key.ListKey l -> Base.String.concat_map ~left:"{" ~right:"}" "," key_to_xml (Array.to_list l)
62 | Badop.Key.VariableKey _ -> assert false
63
64 (* we take this as parameter so that the following functions can be used inside
65 or outside of OPA, with or without a scheduler. It's tricky because it'll
66 still be mixed with function-continuations from Badop. *)
67 module type SigCpsBackend = sig
68 type 'a continuation
69 val mkcont : 'b continuation -> ('a -> unit) -> 'a continuation
70 val return : 'a -> 'a continuation -> unit
71 end
72
73 module F (C: SigCpsBackend) = struct
74
75 (* our tiny CPS lib... *)
76 let mkcont = C.mkcont
77 let (@>) f k = f k
78 let (|>) = C.return
79 let rec fold_list f acc l k = match l with
80 | [] -> acc |> k
81 | hd::tl -> f acc hd @> mkcont k @> fun acc -> fold_list f acc tl @> k
82
83 let print_tag f tag args contents k =
84 Format.fprintf f "@[<hv><%s%s%s>@;<0 2>@[<hv>" tag (if args = "" then "" else " ") args;
85 contents @> mkcont k
86 @> fun _void_ ->
87 Format.fprintf f "@]@,</%s>@]" tag;
88 () |> k
89
90 let path_schema = Badop.Path.of_list [ Badop.Key.IntKey 2; Badop.Key.IntKey 0 ]
91 (* Path /2/0 to schema defined in dbGen_private.ml (/2 is config_keys, config key 0 is schema) *)
92 let path_root = Badop.Path.of_list [ Badop.Key.IntKey 1 ]
93
94 let to_format db_read f k =
95 db_read path_schema (Badop.Contents (D.query ()))
96 @> function
97 | `Answer (Badop.Contents (D.Response (Badop.Data.Binary schema))) ->
98 let tree = G.to_tree (G.import_schema schema) in
99 let rec tree_node = function
100 | G.Tlink id -> tree_node (G.find_id id tree)
101 | G.Tnode (_id,node,edges) -> node, G.filter_dead edges
102 in
103 let rec tree_down key tree ~errk k =
104 let _node,edges = tree_node tree in
105 let find = List.fold_left
106 (fun acc e -> match acc with Some _ as e -> e | None -> match e with
107 | (G.Multi_edge _ | G.Hidden_edge), n -> Some n
108 | G.SumCase id, n when Badop.Key.IntKey id = key -> Some n
109 | G.Field (_str,id), n when Badop.Key.IntKey id = key -> Some n
110 | _ -> None)
111 None edges
112 in
113 match find with
114 | None ->
115 #<If:DEBUG_DB>
116 Printf.eprintf "While dumping db, key %s not found in\n%s\n"
117 (key_to_xml key)
118 (G.print_tree ~color:true tree)
119 #<End>;
120 Logger.warning "Found key %s as a child of node %s, that doesn't match anything in the current database graph. This data has probably been made obsolete during a migration" (Keys.to_string key) (G.tnode_id tree);
121 () |> errk
122 | Some n -> n |> k
123 in
124 let rec aux tree f path k =
125 match tree_node tree with
126 | G.Multi, _ ->
127 tree_down (Badop.Key.IntKey 0) tree ~errk:k @> mkcont k
128 @> fun tree ->
129 print_tag f "map" ""
130 (fun k ->
131 db_read path (Badop.Children (D.query (None,0)))
132 @> function
133 | `Answer (Badop.Children (D.Response children)) ->
134 fold_list
135 (fun isfirst path k ->
136 if not isfirst then Format.pp_print_cut f ();
137 print_tag f "entry" ""
138 (fun k ->
139 print_tag f "key" ""
140 (fun k ->
141 Format.fprintf f "%s" (key_to_xml (Badop.Path.last path)); () |> k)
142 @> mkcont k
143 @> fun _void_ ->
144 Format.pp_print_cut f ();
145 print_tag f "value" ""
146 (aux tree f path)
147 @> k)
148 @> mkcont k
149 @> fun _void_ -> false |> k)
150 true children
151 @> mkcont k
152 @> (fun _bool_ -> () |> k)
153 | `Linkto _ -> assert false
154 | `Answer _ | `Absent -> () |> k)
155 @> k
156 | G.Hidden, _ ->
157 let key = Badop.Key.IntKey 0 in
158 tree_down key tree ~errk:k @> mkcont k
159 @> fun tree -> aux tree f (Badop.Path.add path key) @> k
160 | G.Sum, _ ->
161 (db_read path (Badop.Contents (D.query ()))
162 @> function
163 | `Answer (Badop.Contents (D.Response (Badop.Data.Int sumcase))) ->
164 let key = Badop.Key.IntKey sumcase in
165 tree_down key tree ~errk:k @> mkcont k
166 @> fun tree -> aux tree f (Badop.Path.add path key) @> k
167 | `Answer (Badop.Contents (D.Response data)) ->
168 Logger.warning "During XML dump: invalid contents for sum type at %s, skipping: %s"
169 (G.tnode_id tree) (Badop.Data.to_string data);
170 () |> k
171 | `Answer _ | `Linkto _ -> assert false
172 | `Absent -> () |> k)
173 | G.Product, edges ->
174 fold_list
175 (fun isfirst (e,_n) k ->
176 match e with
177 | G.Field (s,id) ->
178 if not isfirst then Format.pp_print_cut f ();
179 let key = Badop.Key.IntKey id in
180 tree_down key tree ~errk:(mkcont k (fun () -> isfirst |> k)) @> mkcont k
181 @> fun tree -> print_tag f s "" (aux tree f (Badop.Path.add path key))
182 @> mkcont k
183 @> (fun _void_ -> false |> k)
184 | _ -> failwith "bad field")
185 true edges
186 @> mkcont k
187 @> fun _bool_ -> () |> k
188 | G.Leaf lf, _ ->
189 db_read path (Badop.Contents (D.query ()))
190 @> function
191 | `Answer (Badop.Contents (D.Response resp)) ->
192 (let x = DataImpl.get_string resp in
193 match lf with
194 | G.Leaf_binary ->
195 Format.fprintf f "<base64>%s</base64>" (Base.String.base64encode x)
196 | G.Leaf_text ->
197 (try Format.fprintf f "\"%s\"" (escape_string x) with
198 | CharacterNull -> Format.fprintf f "<base64>%s</base64>" (Base.String.base64encode x))
199 | G.Leaf_int | G.Leaf_float ->
200 Format.fprintf f "%s" x);
201 () |> k
202 | `Answer _ | `Linkto _ -> assert false
203 | `Absent -> () |> k
204 in
205 Format.fprintf f "<?xml version=\"1.0\"?>@\n";
206 Format.fprintf f "@[<hv><opa_database_root version=\"%s\">@;<0 2>@[<hv>" xml_dump_version;
207 aux tree f path_root @> mkcont k
208 @> fun _void_ ->
209 Format.fprintf f "@]@,</opa_database_root>@]@.";
210 () |> k
211 | `Answer _ | `Linkto _ | `Absent ->
212 Logger.error "Database dump failed: could not read schema";
213 () |> k
214
215 let to_channel db_read ch k =
216 let f = Format.formatter_of_out_channel ch in
217 to_format db_read f @> k
218
219 let to_file db_read file k =
220 let ch = try Some (open_out file) with Sys_error _ -> None in
221 match ch with
222 | Some ch ->
223 to_channel db_read ch @> mkcont k
224 @> fun _void_ ->
225 close_out ch;
226 () |> k
227 | None ->
228 Logger.error "Could not open file %s for writing database XML dump" file;
229 () |> k
230 end
Something went wrong with that request. Please try again.