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_base_file = "log/uwobo" ;; (* relative to execution dir *)
41 let log_extension = ".log" ;;
42 let default_port = 58080 ;;
43 let port_env_var = "UWOBO_PORT" ;;
44 let log_env_var = "UWOBO_LOG_FILE" ;; (* The extension _pid.log will be added *)
45 let default_media_type = "text/html" ;;
46 let default_encoding = "utf8" ;;
48 let get_media_type props =
50 List.assoc "media-type" props
52 Not_found -> default_media_type
55 let get_encoding props =
57 List.assoc "encoding" props
59 Not_found -> default_encoding
64 int_of_string (Sys.getenv port_env_var)
66 | Not_found -> default_port
67 | Failure "int_of_string" ->
68 prerr_endline "Warning: invalid port number" ;
71 let logfilename_of_port port =
74 Sys.getenv log_env_var
76 Not_found -> default_log_base_file
78 basename ^ "_" ^ string_of_int port ^ log_extension
80 let logfile = logfilename_of_port port;;
81 let logfile_perm = 0o640 ;;
83 let respond_html body outchan =
84 Http_daemon.respond ~body ~headers:["Content-Type", "text/html"] outchan
87 (** perform an 'action' that can be applied to a list of keys or, if no keys
88 was given, to all keys *)
90 keys_param styles logger per_key_action all_keys_action all_keys logmsg
94 Pcre.split ~pat:"," keys_param
95 with Http_types.Param_not_found _ -> []
98 | [] -> (* no key provided, act on all stylesheets *)
99 logger#log (sprintf "%s all stylesheets (keys = %s) ..."
100 logmsg (String.concat ", " all_keys));
101 (try all_keys_action () with e -> logger#log (Printexc.to_string e));
102 logger#log (sprintf "Done! (all stylesheets)")
105 (fun key -> (* act on a single stylesheet *)
106 logger#log (sprintf "%s stylesheet %s" logmsg key);
107 (try per_key_action key with e -> logger#log (Printexc.to_string e));
108 logger#log (sprintf "Done! (stylesheet %s)" key))
112 (** parse parameters for '/apply' action *)
113 let parse_apply_params =
114 let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
115 let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
116 let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
118 (fun (old_params, old_properties) (name, value) ->
120 | name when is_global_param name ->
121 let name = Pcre.replace ~pat:"^param\\." name in
122 ((fun x -> (old_params x) @ [name, value]), old_properties)
123 | name when is_local_param name ->
124 let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
125 let (key, name) = (pieces.(1), pieces.(2)) in
127 | x when x = key -> [name, value] @ (old_params x)
128 | x -> old_params x),
130 | name when is_property name ->
131 let name = Pcre.replace ~pat:"^prop\\." name in
132 (old_params, ((name, value) :: old_properties))
133 | _ -> (old_params, old_properties))
134 ((fun _ -> []), []) (* no parameters, no properties *)
137 (** Parse libxslt's message modes for error and debugging messages. Default is
138 to ignore mesages of both kind *)
139 let parse_libxslt_msgs_mode (req: Http_types.request) =
141 (match req#param "errormode" with
142 | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
143 | s when String.lowercase s = "comment" -> LibXsltMsgComment
144 | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
148 "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
149 err "errormode" "ignore" "comment")))
150 with Http_types.Param_not_found _ -> LibXsltMsgIgnore),
152 (match req#param "debugmode" with
153 | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
154 | s when String.lowercase s = "comment" -> LibXsltMsgComment
155 | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
159 "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
160 err "debugmode" "ignore" "comment")))
161 with Http_types.Param_not_found _ -> LibXsltMsgIgnore))
164 (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer
165 on ~res_pipe (with a timeout of 60 seconds) and send over outchan data
166 received from ~res_pipe *)
167 let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
168 (* debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); *)
169 output_string cmd_pipe (cmd ^ "\n"); (* send command to grandfather *)
171 let res_pipe_fd = Unix.descr_of_in_channel res_pipe in
172 let (read_fds, _, _) = (* wait for an answer *)
173 Unix.select [res_pipe_fd] [] [] 60.0
176 | [fd] when fd = res_pipe_fd -> (* send answer to http client *)
177 Http_daemon.send_basic_headers ~code:200 outchan;
178 Http_daemon.send_header "Content-Type" "text/html" outchan;
179 Http_daemon.send_CRLF outchan;
182 output_string outchan ((input_line res_pipe) ^ "\n")
184 with End_of_file -> flush outchan)
185 | _ -> (* no answer received from grandfather *)
186 return_error "Timeout!" outchan)
189 let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE, kill_cmd_RE) =
190 (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ",
194 (** raised by child processes when HTTP daemon process have to be restarted *)
195 exception Restart_HTTP_daemon ;;
197 (** log a list of libxslt's messages using a processing logger *)
198 let log_libxslt_msgs logger libxslt_logger =
201 | (LibXsltErrorMsg _) as msg -> logger#logBold (string_of_xslt_msg msg)
202 | (LibXsltDebugMsg _) as msg -> logger#logEmph (string_of_xslt_msg msg))
207 let veillogger = new Uwobo_common.libXsltLogger ;;
209 (* start_new_session cmd_pipe_exit res_pipe_entrance outchan port logfile
210 @param cmd_pipe Pipe to be closed before forking
211 @param res_pipe Pipe to be closed before forking
212 @param outchan To be closed before forking
213 @param port The port to be used
214 @param logfile The logfile to redirect the stdout and sterr to
216 (* It can raise Failure "Connection refused" *)
217 (* It can raise Failure "Port already in use" *)
218 let start_new_session cmd_pipe res_pipe outchan port logfile =
220 (* Here I am loosing the current value of port_env_var; *)
221 (* this should not matter *)
222 Unix.putenv port_env_var (string_of_int port) ;
225 (* Let's check that the port is free *)
228 (Http_client.Convenience.http_head_message
229 ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ;
230 raise (Failure "Port already in use")
232 Failure "Connection refused" -> ()
234 match Unix.fork () with
236 Unix.handle_unix_error
238 (* 1. We close all the open pipes to avoid duplicating them *)
239 Unix.close (Unix.descr_of_out_channel cmd_pipe) ;
240 Unix.close (Unix.descr_of_in_channel res_pipe) ;
241 Unix.close (Unix.descr_of_out_channel outchan) ;
242 (* 2. We redirect stdout and stderr to the logfile *)
243 Unix.close Unix.stdout ;
245 (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
246 0o664 = Unix.stdout) ;
247 Unix.close Unix.stderr ;
249 (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
250 0o664 = Unix.stderr) ;
251 prerr_endline "***** Starting a new session" ;
252 (* 3. We exec a new copy of uwobo *)
253 Unix.execve Sys.executable_name [||] environment ;
254 (* It should never reach this point *)
257 | child when child > 0 ->
258 (* let's check if the new UWOBO started correctly *)
260 (* It can raise Failure "Connection refused" *)
262 (Http_client.Convenience.http_head_message
263 ("http://127.0.0.1:" ^ string_of_int port ^ "/help"))
264 | _ -> failwith "Can't fork :-("
267 (* request handler action
268 @param syslogger Uwobo_logger.sysLogger instance used for logginf
269 @param styles Uwobo_styles.styles instance which keeps the stylesheets list
270 @param cmd_pipe output _channel_ used to _write_ update messages
271 @param res_pipe input _channel_ used to _read_ grandparent results
272 @param req http request instance
273 @param outchan output channel connected to http client
276 ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
279 syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
280 syslogger#log `Debug (sprintf "Received request: %s" req#path);
283 (let bindings = req#paramAll "bind" in
284 if bindings = [] then
285 return_error "No [key,stylesheet] binding provided" outchan
287 let cmd = sprintf "add %s" (String.concat ";" bindings) in
288 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
291 let logger = new Uwobo_logger.processingLogger () in
292 logger#log "Exiting" ;
293 respond_html logger#asHtml outchan ;
295 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
297 let logger = new Uwobo_logger.processingLogger () in
298 let port = int_of_string (req#param "port") in
299 let logfile = logfilename_of_port port in
301 start_new_session cmd_pipe res_pipe outchan port logfile ;
302 logger#log (sprintf "New session started: port = %d" port) ;
303 respond_html logger#asHtml outchan
305 Failure "int_of_string" ->
306 logger#log (sprintf "Invalid port number") ;
307 respond_html logger#asHtml outchan
308 | Failure "Port already in use" ->
309 Uwobo_common.return_error "port already in use" outchan
310 | Failure "Connection refused" ->
313 let ch = open_in logfile in
314 while true do log := (input_line ch ^ "\n") :: !log ; done
319 let rec get_last_lines acc =
321 (n,he::tl) when n > 0 ->
322 get_last_lines (he ^ "<br />" ^ acc) (n-1,tl)
325 (* we just show the last 10 lines of the log file *)
327 (if List.length !log > 0 then "<br />...<br />" else "<br />") ^
328 get_last_lines "" (10,!log)
330 Uwobo_common.return_error "daemon not initialized"
333 let cmd = sprintf "remove %s" (req#param "keys") in
334 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
336 let cmd = sprintf "reload %s" (req#param "keys") in
337 short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
339 (let logger = new Uwobo_logger.processingLogger () in
340 (match styles#list with
341 | [] -> logger#log "No stylesheets loaded (yet)!"
343 logger#log "Stylesheets list:";
344 List.iter (fun s -> logger#log s) l);
345 respond_html logger#asHtml outchan)
347 let logger = new Uwobo_logger.processingLogger () in
348 veillogger#clearMsgs;
349 let xmluri = req#param "xmluri" in
350 let keys = Pcre.split ~pat:"," (req#param "keys") in
351 (* notation: "local" parameters are those defined on a per-stylesheet
352 pasis (i.e. param.key.param=value), "global" parameters are those
353 defined for all stylesheets (i.e. param.param=value) *)
354 let (params, props) = parse_apply_params req#params in
355 let (libxslt_errormode, libxslt_debugmode) =
356 parse_libxslt_msgs_mode req
358 syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
359 let domImpl = Gdome.domImplementation () in
360 let input = domImpl#createDocumentFromURI ~uri:xmluri () in
361 syslogger#log `Debug "Applying stylesheet chain ...";
363 let (write_result, media_type, encoding) = (* out_channel -> unit *)
365 ~logger:syslogger ~styles ~keys ~params ~props ~veillogger
366 ~errormode:libxslt_errormode ~debugmode:libxslt_debugmode
369 let content_type = (* value of Content-Type HTTP response header *)
370 sprintf "%s; charset=%s"
371 (match media_type with None -> get_media_type props | Some t -> t)
372 (match encoding with None -> get_encoding props | Some e -> e)
375 (sprintf "sending output to client (Content-Type: %s)...."
377 Http_daemon.send_basic_headers ~code:200 outchan;
378 Http_daemon.send_header "Content-Type" content_type outchan;
379 Http_daemon.send_CRLF outchan;
381 with Uwobo_failure errmsg ->
383 ("Stylesheet chain application failed: " ^ errmsg)
384 ~body: ("<h2>LibXSLT's messages:</h2>" ^
385 String.concat "<br />\n"
386 (List.map string_of_xslt_msg veillogger#msgs))
388 | "/help" -> respond_html usage_string outchan
390 Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
391 syslogger#log `Debug (sprintf "%s done!" req#path);
393 | Http_types.Param_not_found attr_name ->
394 bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
396 return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
399 (* UWOBO's startup *)
401 (* (1) system logger *)
403 debug_print (sprintf "Logging to file %s" logfile);
404 open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm logfile
407 new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
410 (* (2) stylesheets list *)
411 let styles = new Uwobo_styles.styles in
412 (* (3) clean up actions *)
413 let last_process = ref true in
414 let http_child = ref None in
415 let die_nice () = (** at_exit callback *)
416 if !last_process then begin
417 (match !http_child with
419 | Some pid -> Unix.kill pid Sys.sigterm);
420 syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
422 close_out logger_outchan
426 ignore (Sys.signal Sys.sigterm
427 (Sys.Signal_handle (fun _ -> raise Sys.Break)));
428 syslogger#log `Notice
429 (sprintf "%s started and listening on port %d" daemon_name port);
430 syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
431 Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *)
433 let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
434 let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
435 match Unix.fork () with
436 | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *)
437 http_child := Some child;
438 let stop_http_daemon () = (* kill child *)
439 debug_print (sprintf "UWOBOmaster: killing pid %d" child);
440 Unix.kill child Sys.sigterm; (* kill child ... *)
441 ignore (Unix.waitpid [] child); (* ... and its zombie *)
443 Unix.close cmd_pipe_entrance;
444 Unix.close res_pipe_exit;
445 let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
446 let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
449 (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
450 child process has been killed *)
451 debug_print "UWOBOmaster: waiting for commands ...";
452 let cmd = input_line cmd_pipe in
453 debug_print (sprintf "UWOBOmaster: received %s command" cmd);
454 (match cmd with (* command from grandchild *)
457 output_string res_pipe "UWOBOmaster: Hello, world!\n";
459 raise Restart_HTTP_daemon
460 | line when Pcre.pmatch ~rex:kill_cmd_RE line -> (* /kill *)
462 | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *)
464 Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line)
467 let logger = new Uwobo_logger.processingLogger () in
469 (fun binding -> (* add a <key, stylesheet> binding *)
470 let pieces = Pcre.split ~pat:"," binding in
473 logger#log (sprintf "adding binding <%s,%s>" key style);
474 veillogger#clearMsgs;
476 veillogger#clearMsgs;
477 styles#add key style;
478 log_libxslt_msgs logger veillogger;
480 logger#log (Printexc.to_string e))
481 | _ -> logger#log (sprintf "invalid binding %s" binding))
483 output_string res_pipe logger#asHtml;
485 raise Restart_HTTP_daemon
486 | line when Pcre.pmatch ~rex:remove_cmd_RE line -> (* /remove *)
488 let arg = Pcre.replace ~rex:remove_cmd_RE line in
489 let logger = new Uwobo_logger.processingLogger () in
490 veillogger#clearMsgs;
493 styles#remove (fun () -> styles#removeAll) styles#keys
495 log_libxslt_msgs logger veillogger;
496 output_string res_pipe (logger#asHtml);
497 raise Restart_HTTP_daemon
498 | line when Pcre.pmatch ~rex:reload_cmd_RE line -> (* /reload *)
500 let arg = Pcre.replace ~rex:reload_cmd_RE line in
501 let logger = new Uwobo_logger.processingLogger () in
502 veillogger#clearMsgs;
505 styles#reload (fun () -> styles#reloadAll) styles#keys
507 output_string res_pipe (logger#asHtml);
508 raise Restart_HTTP_daemon
509 | cmd -> (* invalid interprocess command received *)
510 syslogger#log `Warning
511 (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
513 with Restart_HTTP_daemon ->
514 close_in cmd_pipe; (* these calls close also fds *)
516 | 0 -> (* (5) child: serve http requests *)
517 Unix.close cmd_pipe_exit;
518 Unix.close res_pipe_entrance;
519 last_process := false;
520 let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in
521 let res_pipe = Unix.in_channel_of_descr res_pipe_exit in
522 debug_print (sprintf "Starting HTTP daemon on port %d ..." port);
523 (* next invocation doesn't return, process will keep on serving HTTP
524 requests until it will get killed by father *)
525 Http_daemon.start'~port ~mode:`Fork
526 (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
527 | _ (* < 0 *) -> (* fork failed :-((( *)
528 failwith "Can't fork :-("
532 (* daemon initialization *)
534 Sys.catch_break true;
536 with Sys.Break -> () (* 'die_nice' registered with at_exit *)