Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 259 lines (237 sloc) 10.16 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 }
7e07d58 @nrs135 [feature] Badop_light: First version.
nrs135 authored
44 let default_light_options =
45 { Badop.
46 lpath = default_file ~name:"db_light" ();
47 }
fccc685 Initial open-source release
MLstate authored
48
49 let default =
50 (module Badop_local : Badop.S), (Badop.Options_Local default_local_options)
51
52 let badop_wrapper functo modul =
53 let module M = (val modul : Badop.S) in
54 let module F = (val functo : Badop_wrapper) in
55 (module F(M) : Badop.S)
56
57 let get_local_options = function
58 | Badop.Options_Local o -> o
59 | _ -> raise Not_found
60
7e07d58 @nrs135 [feature] Badop_light: First version.
nrs135 authored
61 let get_light_options = function
62 | Badop.Options_Light o -> o
63 | _ -> raise Not_found
64
fccc685 Initial open-source release
MLstate authored
65
66 let consume_option name =
67 let rec aux acc lst =
68 match lst with
69 | [] -> false, acc
70 | x::y ->
71 if x = name then
72 true, y @ acc
73 else
74 aux (x::acc) y
75 in
76 aux []
77
78
79 let options_parser_with_default ?name (_default_m, default_o) =
80 let spec_msg = match name with None -> "" | Some n -> Printf.sprintf " for database \"%s\"" n in
81 [
82 ["--db-remote"],
83 A.func A.parse_addr
84 (fun (_,o) (addr,portopt) ->
0f29589 [fix] badop: fixed closure comparison during command-line parsing
Louis Gesbert authored
85 if o != default_o
86 then Logger.warning "Warning: database options before --db-remote will be ignored%s" spec_msg;
fccc685 Initial open-source release
MLstate authored
87 (module Badop_client : Badop.S),
6ff7da0 [fix] database: adding the possibility to automatically attempt to re…
Louis Gesbert authored
88 Badop.Options_Client (Scheduler.default, (addr, Option.default default_port portopt), fun () -> `abort)),
fccc685 Initial open-source release
MLstate authored
89 "<host>[:<port>]",
90 (let default_str = match default_o with
17be19a [feature] database/client: adding an error-handler to the parameters,…
Louis Gesbert authored
91 | Badop.Options_Client(_,(host,port),_) ->
fccc685 Initial open-source release
MLstate authored
92 Printf.sprintf " (default: %s:%d)" (Unix.string_of_inet_addr host) port
93 | _ -> ""
94 in
95 Printf.sprintf "Use a remote database on given server%s" default_str)
96 ;
97 ["--db-local"],
98 A.func (A.option A.string)
99 (fun (_,o) str_opt ->
0f29589 [fix] badop: fixed closure comparison during command-line parsing
Louis Gesbert authored
100 if o != default_o
101 then Logger.warning "Warning: database options before --db-local will be ignored%s" spec_msg;
fccc685 Initial open-source release
MLstate authored
102 let path,flags = match str_opt with
103 | Some str -> Base.String.split_char_last ':' str
104 | None -> "", ""
105 in
106 let path = match path with
107 | "" ->
108 (match o with Badop.Options_Local({ Badop.path = path; _ }) -> path | _ -> default_file ?name ())
109 | p -> (match name with None -> p | Some n -> Filename.concat p n)
110 in
111
461365b [cleanup] Base.String: changed String.split to a much simpler String.…
Louis Gesbert authored
112 let lflags = BaseString.slice ',' flags in
fccc685 Initial open-source release
MLstate authored
113 let restore,lflags =
114 let found, lflags = consume_option "restore" lflags in
115 let r =
116 if found then Some true
117 else
118 (match o with Badop.Options_Local({ Badop.restore = r; _ }) -> r | _ -> None)
119 in r,lflags in
120
121 let dot,lflags =
122 let found, lflags = consume_option "dot" lflags in
123 let r =
124 if found then true
125 else
126 (match o with Badop.Options_Local({ Badop.dot = d; _ }) -> d | _ -> false)
127 in r,lflags in
128
129 let readonly,lflags =
130 let found, lflags = consume_option "readonly" lflags in
131 let r =
132 if found then true
133 else
134 (match o with Badop.Options_Local({ Badop.readonly = d; _ }) -> d | _ -> false)
135 in r,lflags in
136
137 if not (List.is_empty lflags) then
0f29589 [fix] badop: fixed closure comparison during command-line parsing
Louis Gesbert authored
138 (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
139
140 (module Badop_local : Badop.S),
141 Badop.Options_Local { Badop. path; restore; dot; readonly; revision = None }),
142 "[<path>][:<flags>]",
143 (let default_str = match default_o with
144 | Badop.Options_Local({ Badop.path = path; _ }) ->
145 Printf.sprintf " (default: %s)" path
146 | _ -> ""
147 in
148 Printf.sprintf
86cb15b [feature] database: a replicated mode for the database
Louis Gesbert authored
149 "Use a local database at given path%s. Use additional flag 'restore' to try and recover a corrupted database, \
150 or 'dot' to have a database dot output each commit. You can specify several flags, separated by ','." default_str)
151 ;
7e07d58 @nrs135 [feature] Badop_light: First version.
nrs135 authored
152 ["--db-light"],
153 A.func (A.option A.string)
154 (fun (_,o) str_opt ->
155 if o <> default_o
156 then prerr_endline ("Warning: database options before --db-light will be ignored"^spec_msg);
157 let path,_flags = match str_opt with
158 | Some str -> Base.String.split_char_last ':' str
159 | None -> "", ""
160 in
161 let path = match path with
162 | "" ->
163 (match o with Badop.Options_Light({ Badop.lpath = path; _ }) -> path | _ -> default_file ?name ())
164 | p -> (match name with None -> p | Some n -> Filename.concat p n)
165 in
166 let lpath = path^"_light" in
167 Logger.log ~color:`red "path: %s" path;
168 (module Badop_light : Badop.S),
169 Badop.Options_Light { Badop. lpath }),
170 "[<path>][:<flags>]",
171 (let default_str = match default_o with
172 | Badop.Options_Light({ Badop.lpath = lpath }) ->
173 Printf.sprintf " (default: %s_light)" lpath
174 | _ -> ""
175 in
176 Printf.sprintf
f764139 @nrs135 [feature] Badop_light: Attempt at OPA integration (partially success…
nrs135 authored
177 "Same as --db-local, but using the lightweight, history-less backend%s."
178 default_str)
fccc685 Initial open-source release
MLstate authored
179 ]
180 @
181 #<If:BADOP_DEBUG> [
86cb15b [feature] database: a replicated mode for the database
Louis Gesbert authored
182 ["--db-remote-replicated"],
183 A.func (A.list ',' A.parse_addr)
184 (fun (_,o) addrlist ->
0f29589 [fix] badop: fixed closure comparison during command-line parsing
Louis Gesbert authored
185 if o != default_o
186 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
187 (module Badop_dispatcher.F(Badop_client) : Badop.S),
188 Badop.Options_Dispatcher
189 (List.length addrlist,
190 List.map
191 (fun (addr,portopt) ->
17be19a [feature] database/client: adding an error-handler to the parameters,…
Louis Gesbert authored
192 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
193 addrlist)),
194 "<host>[:<port>],<host>[:<port>],...",
195 "Use a remote database replicated on all the given servers"
196 ;
fccc685 Initial open-source release
MLstate authored
197 ["--db-revision"],
198 A.func A.int
199 (fun (_,o) i ->
200 let opt = get_local_options o in
201 (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.…
Louis Gesbert authored
202 "<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
203 ["--db-template"],
204 A.func A.unit
205 (fun (m,o) () ->
206 badop_wrapper (module Badop_wrapper_template.F : Badop_wrapper) m, o),
207 "", "Wrap the database defined in previous arguments with a template identity layer";
208 ["--db-stash"],
209 A.func A.unit
210 (fun (m,o) () ->
211 badop_wrapper (module Badop_stash.F : Badop_wrapper) m, o),
212 "", "Wrap the database defined in previous arguments with a trivial caching layer";
4e1fc79 @nrs135 [feature] Badop_cache: Cloned from Badop_stash.
nrs135 authored
213 ["--db-cache"],
214 A.func A.unit
215 (fun (m,o) () ->
216 badop_wrapper (module Badop_cache.F : Badop_wrapper) m, o),
217 "", "Wrap the database defined in previous arguments with another trivial caching layer";
fccc685 Initial open-source release
MLstate authored
218 ["--db-debug"],
219 A.func (A.option A.string)
220 (fun (m,o) pfx ->
221 badop_wrapper (module Badop_debug.F : Badop_wrapper) m,
222 Badop.Options_Debug
223 (Printf.sprintf
224 "[Badop%s] "
225 (Option.default_map "" (Printf.sprintf "(%s)") pfx), o)),
226 "[string]", "Wrap the database defined in previous arguments with a debugging layer (prints about all database operations on stderr, with an optional tag)";
227 ["--db-stats"],
228 A.func A.unit
229 (fun (m,o) () ->
230 badop_wrapper (module Badop_stats.F : Badop_wrapper) m, o),
231 "", "Wrap the database defined in previous arguments with a layer that prints statistics at exit";
232 ["--db-dispatch"],
233 A.func A.int
234 (fun (m,o) n ->
235 let rec specialise_opts i = function
236 | Badop.Options_Local opt -> Badop.Options_Local {opt with Badop.path = (opt.Badop.path^"_"^string_of_int i)}
237 | Badop.Options_Debug (s,o) ->
238 Badop.Options_Debug (Printf.sprintf "%s[3%dm<%d> " s (1 + i mod 6) i, specialise_opts i o)
239 | _ -> failwith ("dispatch to that backend unsupported yet"^spec_msg)
240 in
241 badop_wrapper (module Badop_dispatcher.F : Badop_wrapper) m,
242 Badop.Options_Dispatcher
243 (1, Base.List.init n (fun i -> specialise_opts i o))),
244 "<int>", "Dispatch the database accesses to <n> database instances";
245 ["--db-workaround"],
246 A.func A.unit
247 (fun (m,o) () ->
248 badop_wrapper (module Badop_workaround.F : Badop_wrapper) m, o),
249 "", "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";
250 ["--db-check"],
251 A.func A.unit
252 (fun (m,o) () ->
253 badop_wrapper (module Badop_check.F : Badop_wrapper) m, o),
254 "", "Wrap the database defined in previous arguments with a layer that check some operations";
255 ]
256 #<Else> [] #<End>
257
258 let options_parser = options_parser_with_default default
Something went wrong with that request. Please try again.