Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 261 lines (237 sloc) 10.598 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 (** The format to export the database schema *)
23 type schema_output =
24 | Gml (** The format used internally, needed by database_import *)
25 | Dot (** Export to dot *)
26 | Aa (** Print an ascii-art tree *)
27
28 (** There are two kind of operations permitted :
29 * those which need to open the db, and do a transaction on it, using badop interface
30 * those which don't need *)
31 type command_open =
32 | Schema of schema_output
33 | Dump of string
34 | Import of string * string option (** Xml file, Gml schema *)
35 | Config
36
37 type command_close =
38 | Backup of string
39
40 type command =
41 | Open of command_open
42 | Close of command_close
43 | Unset
44
45 type options = {
46 command: command;
47 time: Time.t option;
48 backend: (module Badop.S) * Badop.options;
49 }
50
51 let options =
52 let default = {
53 command = Unset;
54 backend = Badop_meta.default;
55 time = None;
56 } in
57 let set_command o c = match o.command with
58 | Unset -> { o with command = c }
59 | _ ->
60 Printf.eprintf "Error: conflicting arguments (you can only choose one of --schema, --dump or --import)\n";
61 raise Exit
62 in
63 try
64 let wrap_parser parse =
65 fun o -> ServerArg.wrap (parse o.backend) (fun bo -> { o with backend = bo }) in
66 let p =
67 ServerArg.filter default
68 (ServerArg.make_parser ~final:true "Database manipulation tool" (
69 (["--schema";"-s"],
70 ServerArg.func
71 (ServerArg.option (ServerArg.stringset ["gml", Gml; "dot", Dot; "aa", Aa]))
72 (fun o out -> set_command o (Open (Schema (Option.default Aa out)))),
73 "[gml|dot|aa]", "Print the database schema in the given format to stdout")
74 ::
75 (["--config";"-c"],
76 (ServerArg.func ServerArg.unit (fun o () -> set_command o (Open Config))),
77 "", "Print the database node configuration to stdout")
78 ::
79 (["--dump";"-d"], ServerArg.func ServerArg.string (fun o s -> set_command o (Open (Dump s))),
80 "<file>", "Dump the contents of the database to this XML file")
81 ::
82 (["--import";"-i"],
83 ServerArg.func
84 (ServerArg.pair ServerArg.string (ServerArg.option ServerArg.string))
85 (fun o (xml,schema_opt) -> set_command o (Open (Import (xml,schema_opt)))),
86 "<file> [schema]", "Import the database data from the given XML file, using the given GML schema (or the one from the database if unspecified).")
87 ::
88 (["--time"], ServerArg.func ServerArg.int (fun o i -> { o with time = Some (Time.seconds i) }),
89 "<timestamp>", "Use the database as it was at the given timestamp, instead of now (for -s and -d only)")
90 ::
91 (["--backup"], ServerArg.func ServerArg.string (fun o s -> set_command o (Close (Backup s))),
3f3d300 @aszlig [fix] database_tool: Spelling corrections.
aszlig authored
92 "<dirpath>", "Do a backup of the database, stored at the given path. Local databases only")
fccc685 Initial open-source release
MLstate authored
93 ::
94 List.map
95 (fun (arg,parse,params,help) -> arg, wrap_parser parse, params, help)
96 Badop_meta.options_parser
97 ))
98 in
99 if not (ServerArg.is_empty (ServerArg.get_argv ())) then
100 (Printf.eprintf "Error: unknown command-line argument: %s\n" (ServerArg.argv_to_string ());
101 raise Exit)
102 else if p.command = Unset then
103 (Printf.eprintf "Error: you need to specify a command (either --schema, --dump or --import)\n";
104 raise Exit)
105 else
106 p
107 with Exit -> exit 1
108
109 module Db = (val (fst options.backend) : Badop.S)
110
111 module SimpleCpsBackend = struct
112 type 'a continuation = 'a -> unit
113 let mkcont _ = fun k -> k
114 let return x k = k x
115 end
116
117 module DbSerializer = Xml_dump.F(SimpleCpsBackend)
118 module DbImporter = Xml_import.F(Db)(SimpleCpsBackend)
119
120
121 open Cps.Ops
122
123 let read_schema_from_db tr k =
124 let path_schema = Badop.Path.of_list [ Badop.Key.IntKey 2; Badop.Key.IntKey 0 ] in
125 let path_schema_version = Badop.Path.of_list [ Badop.Key.IntKey 2; Badop.Key.IntKey (-1) ] in
126 Db.read tr path_schema_version (Badop.Contents (Badop.Dialog.query ()))
127 @> function
128 | `Answer (Badop.Contents (Badop.Dialog.Response (Badop.Data.Int version))) ->
129 (if version > Dbgraph.version then
130 (Printf.eprintf
131 "Error: unexpected schema version %d (this program was built with version %d)\n"
132 version Dbgraph.version;
133 exit 2);
134 Db.read tr path_schema (Badop.Contents (Badop.Dialog.query ()))
135 @> function
136 | `Answer (Badop.Contents (Badop.Dialog.Response (Badop.Data.Binary gml_schema))) ->
137 Some gml_schema |> k
138 | `Answer _ | `Linkto _ ->
139 prerr_endline "Error: inconsistency while trying to read database schema";
140 exit 2
141 | `Absent -> None |> k)
142 | _ ->
143 None |> k
144
145 let get_transaction_at_revision db k =
146 match options.time with
3321f32 [enhance] database: fatal database errors now trigger the fail-transa…
Louis Gesbert authored
147 | None ->
148 Db.Tr.start db
149 (fun exc -> Logger.critical "Database error: %s" (Printexc.to_string exc); exit 4)
150 @> k
fccc685 Initial open-source release
MLstate authored
151 | Some revision_timestamp ->
152 Db.Tr.start db
3321f32 [enhance] database: fatal database errors now trigger the fail-transa…
Louis Gesbert authored
153 (fun exc -> Logger.critical "Database error: %s" (Printexc.to_string exc); exit 4)
fccc685 Initial open-source release
MLstate authored
154 @> fun tr ->
155 Db.read tr Badop.Path.root (Badop.Revisions (Badop.Dialog.query (None,0)))
156 @> function
157 | `Answer (Badop.Revisions (Badop.Dialog.Response revision_list)) ->
158 let rec find_last_before acc timestamp = function
159 | (revision,ts)::r when ts < timestamp -> find_last_before (Some (revision,ts)) timestamp r
160 | _ -> acc
161 in
162 (match find_last_before None revision_timestamp revision_list with
163 | None -> Printf.eprintf "Sorry, couldn't find any revision before the given timestamp\n"; exit 3
164 | Some (revision,ts) ->
165 Printf.eprintf "Using revision %s, of the %d/%d/%d at %d:%d:%d\n"
166 (Db.Debug.revision_to_string revision)
167 (Time.local_mday ts) (Time.local_mon ts) (Time.local_year ts)
168 (Time.local_hour ts) (Time.local_min ts) (Time.local_sec ts);
3321f32 [enhance] database: fatal database errors now trigger the fail-transa…
Louis Gesbert authored
169 Db.Tr.start_at_revision db revision
170 (fun exc -> Logger.critical "Database error: %s" (Printexc.to_string exc); exit 4)
171 @> k)
fccc685 Initial open-source release
MLstate authored
172 | _ ->
173 Printf.eprintf "Error while looking for revisions of the database"; exit 2
174
175 let treat_open command =
176 Db.open_database (snd options.backend)
177 @> fun db ->
178 at_exit (fun () -> Db.close_database db ignore);
179 get_transaction_at_revision db
180 @> fun tr ->
181 match command with
182 | Schema format ->
183 (read_schema_from_db tr
184 @> function
185 | Some gml_schema ->
186 (match format with
187 | Gml ->
188 print_endline gml_schema
189 | Dot ->
190 let schema = QmlDbGen.Schema.from_gml gml_schema in
191 QmlDbGen.Schema.to_dot schema stdout
192 | Aa ->
193 let schema = Dbgraph.import_schema gml_schema in
194 let tree = Dbgraph.to_tree schema in
195 print_endline (Dbgraph.print_tree ~color:(Unix.isatty (Unix.descr_of_out_channel stdout)) tree))
196 | None ->
197 prerr_endline "Read failed: sorry, couldn't find a schema in this database";
198 exit 2)
199 | Dump file ->
200 (DbSerializer.to_file (Db.read tr) file
201 @> fun () ->
202 Printf.eprintf "XML dump to %s done.\n" file)
203 | Import (file,schema_file_opt) ->
204 (let schema_from_file_opt = match schema_file_opt with
205 | None -> None
206 | Some f ->
207 try Some (File.content f)
208 with Unix.Unix_error _ ->
209 Printf.eprintf "Error: could not open the schema file \"%s\".\n" f; exit 2
210 in
211 (fun k ->
212 read_schema_from_db tr
213 @> fun schema_from_db_opt -> match schema_from_file_opt, schema_from_db_opt with
214 | Some s, None | None, Some s -> Dbgraph.to_tree (Dbgraph.import_schema s) |> k
215 | None, None ->
216 prerr_endline "Error: no schema found either from the command-line or from the database.";
217 prerr_endline "Either use an initialised database or provide a gml file.";
218 exit 2
219 | Some s1, Some s2 ->
220 let t1 = Dbgraph.to_tree (Dbgraph.import_schema s1)
221 and t2 = Dbgraph.to_tree (Dbgraph.import_schema s2)
222 in
223 if t1 <> t2 then
224 (prerr_endline "Error: you specified a schema that is different from the one in that database.";
225 prerr_endline "Either import into an empty database or use the schema from the existing one.";
226 exit 2)
227 else t1 |> k)
228 @> fun t ->
229 Printf.eprintf "Starting import from %s.\n" file;
230 DbImporter.from_file db t file
231 @> fun () ->
232 Printf.eprintf "XML import from %s done.\n" file)
233 | Config ->
234 (read_schema_from_db tr
235 @> function
236 | Some gml_schema ->
237 let node_config = Badop_structure.Node_property.construct gml_schema in
238 Printf.printf "Node configuration : %s\n%!" (Badop_structure.Node_property.StringOf.config node_config);
239 | None ->
240 prerr_endline "Read failed: sorry, couldn't find a schema in this database";
241 exit 2)
242
243
244 let treat_close command =
245 match command with
246 | Backup path ->
247 (let loc =
248 match options.backend with
249 | _, Badop.Options_Local opt -> opt.Badop.path
250 | _, _ -> prerr_endline "Wrong option, missing location. --backup can be used only on local database."; exit 2 in
251
252 Backup.do_backup path loc)
253
254 let _ =
255 match options.command with
256 | Open command -> treat_open command
257 | Close command -> treat_close command
258 | Unset -> assert false
259
260 let _ = Scheduler.run Scheduler.default
Something went wrong with that request. Please try again.