Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 219 lines (198 sloc) 8.622 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 module List = BaseList
19 module A = ServerArg
20
21 module type Badop_wrapper = functor (Backend: Badop.S) -> Badop.S
22
23 let default_file ?(name="db") () =
24 let (/) = Filename.concat in
25 let mlstate_dir =
26 try
27 let id = Unix.geteuid() in
28 (Unix.getpwuid id).Unix.pw_dir /
29 (if id = 0 || id >= 500 then ".mlstate" else "mlstate")
30 with Not_found ->
31 Lazy.force File.mlstate_dir (* Useful on windows (getpwuid raises that) *)
32 in
33 mlstate_dir / (Filename.basename (Sys.argv.(0))) / name
34
35 let default_port = 4849
36 let default_local_options =
37 { Badop.
38 path = default_file();
39 revision = None;
40 restore = None;
41 dot = false;
42 readonly = false;
43 }
44
45 let default =
46 (module Badop_local : Badop.S), (Badop.Options_Local default_local_options)
47
48 let badop_wrapper functo modul =
49 let module M = (val modul : Badop.S) in
50 let module F = (val functo : Badop_wrapper) in
51 (module F(M) : Badop.S)
52
53 let get_local_options = function
54 | Badop.Options_Local o -> o
55 | _ -> raise Not_found
56
57
58 let consume_option name =
59 let rec aux acc lst =
60 match lst with
61 | [] -> false, acc
62 | x::y ->
63 if x = name then
64 true, y @ acc
65 else
66 aux (x::acc) y
67 in
68 aux []
69
70
71 let options_parser_with_default ?name (_default_m, default_o) =
72 let spec_msg = match name with None -> "" | Some n -> Printf.sprintf " for database \"%s\"" n in
73 [
74 ["--db-remote"],
75 A.func A.parse_addr
76 (fun (_,o) (addr,portopt) ->
0f29589 [fix] badop: fixed closure comparison during command-line parsing
Louis Gesbert authored
77 if o != default_o
78 then Logger.warning "Warning: database options before --db-remote will be ignored%s" spec_msg;
fccc685 Initial open-source release
MLstate authored
79 (module Badop_client : Badop.S),
6ff7da0 [fix] database: adding the possibility to automatically attempt to recon...
Louis Gesbert authored
80 Badop.Options_Client (Scheduler.default, (addr, Option.default default_port portopt), fun () -> `abort)),
fccc685 Initial open-source release
MLstate authored
81 "<host>[:<port>]",
82 (let default_str = match default_o with
17be19a [feature] database/client: adding an error-handler to the parameters, tr...
Louis Gesbert authored
83 | Badop.Options_Client(_,(host,port),_) ->
fccc685 Initial open-source release
MLstate authored
84 Printf.sprintf " (default: %s:%d)" (Unix.string_of_inet_addr host) port
85 | _ -> ""
86 in
87 Printf.sprintf "Use a remote database on given server%s" default_str)
88 ;
89 ["--db-local"],
90 A.func (A.option A.string)
91 (fun (_,o) str_opt ->
0f29589 [fix] badop: fixed closure comparison during command-line parsing
Louis Gesbert authored
92 if o != default_o
93 then Logger.warning "Warning: database options before --db-local will be ignored%s" spec_msg;
fccc685 Initial open-source release
MLstate authored
94 let path,flags = match str_opt with
95 | Some str -> Base.String.split_char_last ':' str
96 | None -> "", ""
97 in
98 let path = match path with
99 | "" ->
100 (match o with Badop.Options_Local({ Badop.path = path; _ }) -> path | _ -> default_file ?name ())
101 | p -> (match name with None -> p | Some n -> Filename.concat p n)
102 in
103
461365b [cleanup] Base.String: changed String.split to a much simpler String.sli...
Louis Gesbert authored
104 let lflags = BaseString.slice ',' flags in
fccc685 Initial open-source release
MLstate authored
105 let restore,lflags =
106 let found, lflags = consume_option "restore" lflags in
107 let r =
108 if found then Some true
109 else
110 (match o with Badop.Options_Local({ Badop.restore = r; _ }) -> r | _ -> None)
111 in r,lflags in
112
113 let dot,lflags =
114 let found, lflags = consume_option "dot" lflags in
115 let r =
116 if found then true
117 else
118 (match o with Badop.Options_Local({ Badop.dot = d; _ }) -> d | _ -> false)
119 in r,lflags in
120
121 let readonly,lflags =
122 let found, lflags = consume_option "readonly" lflags in
123 let r =
124 if found then true
125 else
126 (match o with Badop.Options_Local({ Badop.readonly = d; _ }) -> d | _ -> false)
127 in r,lflags in
128
129 if not (List.is_empty lflags) then
0f29589 [fix] badop: fixed closure comparison during command-line parsing
Louis Gesbert authored
130 (Logger.warning "Error: unknown db flag %s%s" (List.print (fun x -> x) lflags) spec_msg; raise Exit);
fccc685 Initial open-source release
MLstate authored
131
132 (module Badop_local : Badop.S),
133 Badop.Options_Local { Badop. path; restore; dot; readonly; revision = None }),
134 "[<path>][:<flags>]",
135 (let default_str = match default_o with
136 | Badop.Options_Local({ Badop.path = path; _ }) ->
137 Printf.sprintf " (default: %s)" path
138 | _ -> ""
139 in
140 Printf.sprintf
86cb15b [feature] database: a replicated mode for the database
Louis Gesbert authored
141 "Use a local database at given path%s. Use additional flag 'restore' to try and recover a corrupted database, \
142 or 'dot' to have a database dot output each commit. You can specify several flags, separated by ','." default_str)
143 ;
fccc685 Initial open-source release
MLstate authored
144 ]
145 @
146 #<If:BADOP_DEBUG> [
86cb15b [feature] database: a replicated mode for the database
Louis Gesbert authored
147 ["--db-remote-replicated"],
148 A.func (A.list ',' A.parse_addr)
149 (fun (_,o) addrlist ->
0f29589 [fix] badop: fixed closure comparison during command-line parsing
Louis Gesbert authored
150 if o != default_o
151 then Logger.warning "Warning: database options before --db-remote-replicated will be ignored%s "spec_msg;
86cb15b [feature] database: a replicated mode for the database
Louis Gesbert authored
152 (module Badop_dispatcher.F(Badop_client) : Badop.S),
153 Badop.Options_Dispatcher
154 (List.length addrlist,
155 List.map
156 (fun (addr,portopt) ->
17be19a [feature] database/client: adding an error-handler to the parameters, tr...
Louis Gesbert authored
157 Badop.Options_Client (Scheduler.default, (addr, Option.default default_port portopt), fun () -> `abort))
86cb15b [feature] database: a replicated mode for the database
Louis Gesbert authored
158 addrlist)),
159 "<host>[:<port>],<host>[:<port>],...",
160 "Use a remote database replicated on all the given servers"
161 ;
fccc685 Initial open-source release
MLstate authored
162 ["--db-revision"],
163 A.func A.int
164 (fun (_,o) i ->
165 let opt = get_local_options o in
166 (module Badop_local : Badop.S), Badop.Options_Local { opt with Badop.revision = Some i }),
461365b [cleanup] Base.String: changed String.split to a much simpler String.sli...
Louis Gesbert authored
167 "<int>", "Revert the database to the given revision. Be careful, all data after that revision will be cleared";
fccc685 Initial open-source release
MLstate authored
168 ["--db-template"],
169 A.func A.unit
170 (fun (m,o) () ->
171 badop_wrapper (module Badop_wrapper_template.F : Badop_wrapper) m, o),
172 "", "Wrap the database defined in previous arguments with a template identity layer";
173 ["--db-stash"],
174 A.func A.unit
175 (fun (m,o) () ->
176 badop_wrapper (module Badop_stash.F : Badop_wrapper) m, o),
177 "", "Wrap the database defined in previous arguments with a trivial caching layer";
178 ["--db-debug"],
179 A.func (A.option A.string)
180 (fun (m,o) pfx ->
181 badop_wrapper (module Badop_debug.F : Badop_wrapper) m,
182 Badop.Options_Debug
183 (Printf.sprintf
184 "[Badop%s] "
185 (Option.default_map "" (Printf.sprintf "(%s)") pfx), o)),
186 "[string]", "Wrap the database defined in previous arguments with a debugging layer (prints about all database operations on stderr, with an optional tag)";
187 ["--db-stats"],
188 A.func A.unit
189 (fun (m,o) () ->
190 badop_wrapper (module Badop_stats.F : Badop_wrapper) m, o),
191 "", "Wrap the database defined in previous arguments with a layer that prints statistics at exit";
192 ["--db-dispatch"],
193 A.func A.int
194 (fun (m,o) n ->
195 let rec specialise_opts i = function
196 | Badop.Options_Local opt -> Badop.Options_Local {opt with Badop.path = (opt.Badop.path^"_"^string_of_int i)}
197 | Badop.Options_Debug (s,o) ->
198 Badop.Options_Debug (Printf.sprintf "%s[3%dm<%d> " s (1 + i mod 6) i, specialise_opts i o)
199 | _ -> failwith ("dispatch to that backend unsupported yet"^spec_msg)
200 in
201 badop_wrapper (module Badop_dispatcher.F : Badop_wrapper) m,
202 Badop.Options_Dispatcher
203 (1, Base.List.init n (fun i -> specialise_opts i o))),
204 "<int>", "Dispatch the database accesses to <n> database instances";
205 ["--db-workaround"],
206 A.func A.unit
207 (fun (m,o) () ->
208 badop_wrapper (module Badop_workaround.F : Badop_wrapper) m, o),
209 "", "Wrap the database defined in previous arguments with a layer that starts all operations from the root. This is inefficient but makes the dispatcher work properly until we handle locality correctly in links and maps";
210 ["--db-check"],
211 A.func A.unit
212 (fun (m,o) () ->
213 badop_wrapper (module Badop_check.F : Badop_wrapper) m, o),
214 "", "Wrap the database defined in previous arguments with a layer that check some operations";
215 ]
216 #<Else> [] #<End>
217
218 let options_parser = options_parser_with_default default
Something went wrong with that request. Please try again.