3 * Stefano Zacchiroli <zack@cs.unibo.it>
4 * for the HELM Team http://helm.cs.unibo.it/
6 * This file is part of HELM, an Hypertextual, Electronic
7 * Library of Mathematics, developed at the Computer Science
8 * Department, University of Bologna, Italy.
10 * HELM is free software; you can redistribute it and/or
11 * modify it under the terms of the GNU General Public License
12 * as published by the Free Software Foundation; either version 2
13 * of the License, or (at your option) any later version.
15 * HELM is distributed in the hope that it will be useful,
16 * but WITHOUT ANY WARRANTY; without even the implied warranty of
17 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 * GNU General Public License for more details.
20 * You should have received a copy of the GNU General Public License
21 * along with HELM; if not, write to the Free Software
22 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
25 * For details, see the HELM World-Wide-Web page,
26 * http://helm.cs.unibo.it/
32 (* debugging settings *)
34 let debug_level = `Notice ;;
35 let debug_print s = if debug then prerr_endline s ;;
36 Http_common.debug := false ;;
39 let daemon_name = "UWOBO OCaml" ;;
40 let default_log_file = "uwobo.log" ;; (* relative to execution dir *)
41 let default_port = 58080 ;;
42 let port_env_var = "UWOBO_PORT" ;;
43 let default_media_type = "text/html" ;;
44 let default_encoding = "utf8" ;;
46 Some (try Sys.getenv "UWOBO_LOG_FILE" with Not_found -> default_log_file)
48 let logfile_perm = 0o640 ;;
51 int_of_string (Sys.getenv port_env_var)
53 | Not_found -> default_port
54 | Failure "int_of_string" ->
55 prerr_endline "Warning: invalid port, reverting to default";
59 let respond_html body outchan =
60 Http_daemon.respond ~body ~headers:["Content-Type", "text/html"] outchan
63 (** perform an 'action' that can be applied to a list of keys or, if no keys
64 was given, to all keys *)
66 keys_param styles logger per_key_action all_keys_action all_keys logmsg
70 Pcre.split ~pat:"," keys_param
71 with Http_types.Param_not_found _ -> []
74 | [] -> (* no key provided, act on all stylesheets *)
75 logger#log (sprintf "%s all stylesheets (keys = %s) ..."
76 logmsg (String.concat ", " all_keys));
77 (try all_keys_action () with e -> logger#log (Printexc.to_string e));
78 logger#log (sprintf "Done! (all stylesheets)")
81 (fun key -> (* act on a single stylesheet *)
82 logger#log (sprintf "%s stylesheet %s" logmsg key);
83 (try per_key_action key with e -> logger#log (Printexc.to_string e));
84 logger#log (sprintf "Done! (stylesheet %s)" key))
88 (** parse parameters for '/apply' action *)
89 let parse_apply_params =
90 let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
91 let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
92 let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
94 (fun (old_params, old_properties) (name, value) ->
96 | name when is_global_param name ->
97 let name = Pcre.replace ~pat:"^param\\." name in
98 ((fun x -> (old_params x) @ [name, value]), old_properties)
99 | name when is_local_param name ->
100 let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
101 let (key, name) = (pieces.(1), pieces.(2)) in
103 | x when x = key -> [name, value] @ (old_params x)
104 | x -> old_params x),
106 | name when is_property name ->
107 let name = Pcre.replace ~pat:"^prop\\." name in
108 (old_params, ((name, value) :: old_properties))
109 | _ -> (old_params, old_properties))
110 ((fun _ -> []), []) (* no parameters, no properties *)
113 (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer
114 on ~res_pipe (with a timeout of 60 seconds) and send over outchan data
115 received from ~res_pipe *)
116 let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
117 (* debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); *)
118 output_string cmd_pipe (cmd ^ "\n"); (* send command to grandfather *)
120 let res_pipe_fd = Unix.descr_of_in_channel res_pipe in
121 let (read_fds, _, _) = (* wait for an answer *)
122 Unix.select [res_pipe_fd] [] [] 60.0
125 | [fd] when fd = res_pipe_fd -> (* send answer to http client *)
126 Http_daemon.send_basic_headers ~code:200 outchan;
127 Http_daemon.send_header "Content-Type" "text/html" outchan;
128 Http_daemon.send_CRLF outchan;
131 output_string outchan ((input_line res_pipe) ^ "\n")
133 with End_of_file -> flush outchan)
134 | _ -> (* no answer received from grandfather *)
135 return_error "Timeout!" outchan)
138 let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE) =
139 (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ")
142 exception Restart_HTTP_daemon;;
144 (** log a list of libxslt's messages using a processing logger *)
145 let log_libxslt_msgs logger =
148 | Uwobo_styles.LibXsltErrorMsg msg ->
149 logger#logBold ("LibXSLT ERROR: " ^ msg)
150 | Uwobo_styles.LibXsltDebugMsg msg ->
151 logger#logEmph ("LibXSLT DEBUG " ^ msg))
154 (* request handler action
155 @param syslogger Uwobo_logger.sysLogger instance used for logginf
156 @param styles Uwobo_styles.styles instance which keeps the stylesheets list
157 @param cmd_pipe output _channel_ used to _write_ update messages
158 @param res_pipe input _channel_ used to _read_ grandparent results
159 @param req http request instance
160 @param outchan output channel connected to http client
163 ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
166 syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
167 syslogger#log `Debug (sprintf "Received request: %s" req#path);
170 (let bindings = req#paramAll "bind" in
171 if bindings = [] then
172 return_error "No [key,stylesheet] binding provided" outchan
174 let cmd = sprintf "add %s" (String.concat ";" bindings) in
175 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
178 let cmd = sprintf "remove %s" (req#param "keys") in
179 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
181 let cmd = sprintf "reload %s" (req#param "keys") in
182 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
184 (let log = new Uwobo_logger.processingLogger () in
185 (match styles#list with
186 | [] -> log#log "No stylesheets loaded (yet)!"
188 log#log "Stylesheets list:";
189 List.iter (fun s -> log#log s) l);
190 respond_html log#asHtml outchan)
192 let logger = new Uwobo_logger.processingLogger () in
193 let xmluri = req#param "xmluri" in
194 let keys = Pcre.split ~pat:"," (req#param "keys") in
195 (* notation: "local" parameters are those defined on a per-stylesheet
196 pasis (i.e. param.key.param=value), "global" parameters are those
197 defined for all stylesheets (i.e. param.param=value) *)
198 let (params, props) = parse_apply_params req#params in
199 syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
200 let domImpl = Gdome.domImplementation () in
201 let input = domImpl#createDocumentFromURI ~uri:xmluri () in
202 syslogger#log `Debug "Applying stylesheet chain ...";
204 let (write_result, media_type, encoding) = (* out_channel -> unit *)
205 let res = Uwobo_engine.apply
206 ~logger:syslogger ~styles ~keys ~input ~params ~props in
209 let content_type = (* value of Content-Type HTTP response header *)
210 sprintf "%s; charset=%s"
211 (match media_type with None -> default_media_type | Some t -> t)
212 (match encoding with None -> default_encoding | Some e -> e)
215 (sprintf "sending output to client (Content-Type: %s)...."
217 Http_daemon.send_basic_headers ~code:200 outchan;
218 Http_daemon.send_header "Content-Type" content_type outchan;
219 Http_daemon.send_CRLF outchan;
221 with Uwobo_failure errmsg ->
223 (sprintf "Stylesheet chain application failed: %s" errmsg)
225 | "/help" -> respond_html usage_string outchan
227 Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
228 syslogger#log `Debug (sprintf "%s done!" req#path);
230 | Http_types.Param_not_found attr_name ->
231 bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
233 return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
236 (* UWOBO's startup *)
238 (* (1) system logger *)
242 debug_print "Logging to standard error";
245 debug_print (sprintf "Logging to file %s" f);
246 open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm f
249 new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
252 (* (2) stylesheets list *)
253 let styles = new Uwobo_styles.styles in
254 (* (3) clean up actions *)
255 let last_process = ref true in
256 let http_child = ref None in
257 let die_nice () = (** at_exit callback *)
258 if !last_process then begin
259 (match !http_child with
261 | Some pid -> Unix.kill pid Sys.sigterm);
262 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
264 close_out logger_outchan
268 ignore (Sys.signal Sys.sigterm
269 (Sys.Signal_handle (fun _ -> raise Sys.Break)));
270 syslogger#log `Notice
271 (sprintf "%s started and listening on port %d" daemon_name port);
272 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
273 Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *)
275 let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
276 let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
277 match Unix.fork () with
278 | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *)
279 http_child := Some child;
280 let stop_http_daemon () = (* kill child *)
281 debug_print (sprintf "UWOBOmaster: killing pid %d" child);
282 Unix.kill child Sys.sigterm; (* kill child ... *)
283 ignore (Unix.waitpid [] child); (* ... and its zombie *)
285 Unix.close cmd_pipe_entrance;
286 Unix.close res_pipe_exit;
287 let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
288 let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
291 (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
292 child process has been killed *)
293 debug_print "UWOBOmaster: waiting for commands ...";
294 let cmd = input_line cmd_pipe in
295 debug_print (sprintf "UWOBOmaster: received %s command" cmd);
296 (match cmd with (* command from grandchild *)
299 output_string res_pipe "UWOBOmaster: Hello, world!\n";
301 raise Restart_HTTP_daemon
302 | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *)
304 Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line)
307 let log = new Uwobo_logger.processingLogger () in
309 (fun binding -> (* add a <key, stylesheet> binding *)
310 let pieces = Pcre.split ~pat:"," binding in
313 log#log (sprintf "adding binding <%s,%s>" key style);
315 log_libxslt_msgs log (styles#add key style)
317 log#log (Printexc.to_string e))
318 | _ -> log#log (sprintf "invalid binding %s" binding))
320 output_string res_pipe log#asHtml;
322 raise Restart_HTTP_daemon
323 | line when Pcre.pmatch ~rex:remove_cmd_RE line -> (* /remove *)
325 let arg = Pcre.replace ~rex:remove_cmd_RE line in
326 let logger = new Uwobo_logger.processingLogger () in
329 (fun key -> log_libxslt_msgs logger (styles#remove key))
330 (fun () -> log_libxslt_msgs logger styles#removeAll)
333 output_string res_pipe (logger#asHtml);
334 raise Restart_HTTP_daemon
335 | line when Pcre.pmatch ~rex:reload_cmd_RE line -> (* /reload *)
337 let arg = Pcre.replace ~rex:reload_cmd_RE line in
338 let logger = new Uwobo_logger.processingLogger () in
341 (fun key -> log_libxslt_msgs logger (styles#reload key))
342 (fun () -> log_libxslt_msgs logger styles#reloadAll)
345 output_string res_pipe (logger#asHtml);
346 raise Restart_HTTP_daemon
347 | cmd -> (* invalid interprocess command received *)
348 syslogger#log `Warning
349 (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
351 with Restart_HTTP_daemon ->
352 close_in cmd_pipe; (* these calls close also fds *)
354 | 0 -> (* (5) child: serve http requests *)
355 Unix.close cmd_pipe_exit;
356 Unix.close res_pipe_entrance;
357 last_process := false;
358 let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in
359 let res_pipe = Unix.in_channel_of_descr res_pipe_exit in
360 debug_print (sprintf "Starting HTTP daemon on port %d ..." port);
361 (* next invocation doesn't return, process will keep on serving HTTP
362 requests until it will get killed by father *)
363 Http_daemon.start'~port ~mode:`Fork
364 (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
365 | _ (* < 0 *) -> (* fork failed :-((( *)
366 failwith "Can't fork :-("
370 (* daemon initialization *)
372 Sys.catch_break true;
374 with Sys.Break -> () (* 'die_nice' registered with at_exit *)