-
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
*)
-(* TODO braindead situation: /add of a stylesheet which uri is an uwobo
-invocation *)
-
open Printf;;
open Uwobo_common;;
(* debugging settings *)
-let debug = true;;
+let debug = false;;
let debug_level = `Debug;;
let debug_print s = if debug then prerr_endline s;;
-let http_debug = false;;
-Http_common.debug := http_debug;;
+Http_common.debug := false;;
+let logfile = Some "uwobo.log";; (* relative to execution dir *)
+let logfile_perm = 0o644;;
- (* environment settings *)
+ (* other settings *)
let daemon_name = "UWOBO OCaml";;
-let default_port = 8082;;
+let default_port = 58080;;
let port_env_var = "UWOBO_PORT";;
let default_media_type = "text/html";;
let default_encoding = "utf8";;
| Not_found -> default_port
| Failure "int_of_string" ->
prerr_endline "Warning: invalid port, reverting to default";
- default_port
-in
+ default_port;;
- (* facilities *)
-let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" in
-let return_error msg outchan =
- (* return an ok (200) http response, which display in html an error message *)
- Http_daemon.respond ~body:(pp_error msg) outchan
-in
-let bad_request body outchan = (* return a bad request http response *)
- Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
-in
+ (** perform an 'action' that can be applied to a list of keys or, if no keys
+ was given, to all keys *)
+let act_on_keys keys_param styles outchan per_key_action all_keys_action logmsg
+=
+ let log = new Uwobo_logger.processingLogger () in
+ let keys =
+ try
+ Pcre.split ~pat:"," keys_param
+ with Http_types.Param_not_found _ -> []
+ in
+ (match keys with
+ | [] -> (* no key provided, act on all stylesheets *)
+ log#log "reloading all stylesheets ...";
+ (try all_keys_action () with e -> log#log (Printexc.to_string e))
+ | keys ->
+ List.iter
+ (fun key -> (* act on a single stylesheet *)
+ log#log (sprintf "%s stylesheet %s" logmsg key);
+ (try per_key_action key with e -> log#log (Printexc.to_string e)))
+ keys);
+ output_string outchan log#asHtml;
+ flush outchan
+;;
- (* values common to all threads *)
-let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
-syslogger#enable;
-let styles = new Uwobo_styles.styles in
-let usage_string =
- sprintf
-"
-<html>
- <head>
- <title>UWOBO's help message</title>
- </head>
- <body>
- <p>
- Usage: <kbd>http://hostname:uwoboport/</kbd><em>command</em>
- </p>
- <p>
- Available commands:
- </p>
- <p>
- <b><kbd>help</kbd></b><br />
- display this help message
- </p>
- <p>
- <b><kbd>add?bind=key,uri[&bind=key,stylesheet[&...]]</kbd></b><br />
- load a new stylesheet, specified by <em>uri</em>, and bind it to key
- <em>key</em>
- </p>
- <p>
- <b><kbd>remove?[?keys=key1,key2,...]</kbd></b><br />
- unload stylesheets specified by <em>key1, key2, ...</em> or all
- stylesheets if no key was given
- </p>
- <p>
- <b><kbd>reload?[?keys=key1,key2,...]</kbd></b><br />
- reload stylesheets specified by <em>key1, key2, ...</em> or all
- stylesheets if no key was given
- </p>
- <p>
- <b><kbd>list</kbd></b><br />
- return a list of loaded stylesheets
- </p>
- <p>
- <b><kbd>apply?xmluri=uri&keys=key1,key2,...[¶m.name=value[¶m.name=value[&...]]][¶m.key.name=value[¶m.key.name=value[&...]]][&name[=value][&prop.name[=value][&...]]]</kbd></b><br />
- apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
- input document, specified by <em>uri</em>.<br />
- Additional parameters can be set for each stylesheet application: global
- parameters (i.e. parameters passed to all stylesheets) are set using
- <em>param.name=value</em> syntax, per stylesheet parameters are set using
- <em>param.key.name=value</em> where <em>key</em> is the key of a loaded
- stylesheet.<br />
- Properties of the final chain output can be set too: valueless properties
- can be set using <em>prop.name</em> syntax, others can be set using
- <em>prop.name=value</em> syntax.<br />
- Current supported properties are: %s.
- </p>
- </body>
-</html>
-"
- (String.concat ", " Uwobo_common.supported_properties)
-in
+ (** parse parameters for '/apply' action *)
+let parse_apply_params =
+ let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
+ let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
+ let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
+ List.fold_left
+ (fun (old_params, old_properties) (name, value) ->
+ match name with
+ | name when is_global_param name ->
+ let name = Pcre.replace ~pat:"^param\\." name in
+ ((fun x -> (old_params x) @ [name, value]), old_properties)
+ | name when is_local_param name ->
+ let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
+ let (key, name) = (pieces.(1), pieces.(2)) in
+ ((function
+ | x when x = key -> [name, value] @ (old_params x)
+ | x -> old_params x),
+ old_properties)
+ | name when is_property name ->
+ let name = Pcre.replace ~pat:"^prop\\." name in
+ (old_params, ((name, value) :: old_properties))
+ | _ -> (old_params, old_properties))
+ ((fun _ -> []), []) (* no parameters, no properties *)
+;;
- (* thread action *)
-let callback (req: Http_types.request) outchan =
- (* perform an 'action' that can be applied to a list of keys or, if no
- keys was given, to all keys *)
- let act_on_keys (req: Http_types.request)
- styles outchan per_key_action all_keys_action logmsg
- =
- let log = new Uwobo_logger.processingLogger () in
- let keys =
- try
- Pcre.split ~pat:"," (req#param "keys")
- with Http_types.Param_not_found _ -> []
- in
- (match keys with
- | [] -> (* no key provided, act on all stylesheets *)
- log#log "reloading all stylesheets ...";
- (try all_keys_action () with e -> log#log (Printexc.to_string e))
- | keys ->
- List.iter
- (fun key -> (* act on a single stylesheet *)
- log#log (sprintf "%s stylesheet %s" logmsg key);
- (try per_key_action key with e -> log#log (Printexc.to_string e)))
- keys);
- Http_daemon.respond ~body:log#asHtml outchan
- in
- let parse_apply_params = (* parse parameters for '/apply' action *)
- let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
- let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
- let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
- List.fold_left
- (fun (old_params, old_properties) (name, value) ->
- match name with
- | name when is_global_param name ->
- let name = Pcre.replace ~pat:"^param\\." name in
- ((fun x -> (old_params x) @ [name, value]), old_properties)
- | name when is_local_param name ->
- let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
- let (key, name) = (pieces.(1), pieces.(2)) in
- ((function
- | x when x = key -> [name, value] @ (old_params x)
- | x -> old_params x),
- old_properties)
- | name when is_property name ->
- let name = Pcre.replace ~pat:"^prop\\." name in
- (old_params, ((name, value) :: old_properties))
- | _ -> (old_params, old_properties))
- ((fun _ -> []), []) (* no parameters, no properties *)
+ (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer
+ on ~res_pipe (with a timeout of 60 seconds) and send over outchan data
+ received from ~res_pipe *)
+let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
+ debug_print (sprintf "Sending command '%s' to grandparent ..." cmd);
+ output_string cmd_pipe (cmd ^ "\n"); (* send command to grandfather *)
+ flush cmd_pipe;
+ let res_pipe_fd = Unix.descr_of_in_channel res_pipe in
+ let (read_fds, _, _) = (* wait for an answer *)
+ Unix.select [res_pipe_fd] [] [] 60.0
in
+ (match read_fds with
+ | [fd] when fd = res_pipe_fd -> (* send answer to http client *)
+ Http_daemon.send_basic_headers ~code:200 outchan;
+ Http_daemon.send_CRLF outchan;
+ (try
+ while true do
+ output_string outchan ((input_line res_pipe) ^ "\n")
+ done
+ with End_of_file -> flush outchan)
+ | _ -> (* no answer received from grandfather *)
+ return_error "Timeout!" outchan)
+;;
+
+let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE) =
+ (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ")
+;;
+
+exception Restart_HTTP_daemon;;
+
+ (* thread action
+ @param syslogger Uwobo_logger.sysLogger instance used for logginf
+ @param styles Uwobo_styles.styles instance which keeps the stylesheets list
+ @param cmd_pipe output _channel_ used to _write_ update messages
+ @param res_pipe input _channel_ used to _read_ grandparent results
+ @param req http request instance
+ @param outchan output channel connected to http client
+ *)
+let callback
+ ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
+ =
try
syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
syslogger#log `Debug (sprintf "Received request: %s" req#path);
if bindings = [] then
return_error "No [key,stylesheet] binding provided" outchan
else begin
- let log = new Uwobo_logger.processingLogger () in
- List.iter
- (fun binding -> (* add a <key, stylesheet> binding *)
- let pieces = Pcre.split ~pat:"," binding in
- match pieces with
- | [key; style] ->
- log#log (sprintf "adding binding <%s,%s>" key style);
- (try
- styles#add key style;
- with e ->
- log#log (Printexc.to_string e))
- | _ -> log#log (sprintf "invalid binding %s" binding))
- bindings;
- Http_daemon.respond ~body:log#asHtml outchan
+ let cmd = sprintf "add %s" (String.concat ";" bindings) in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
end)
+ | "/remove" ->
+ let cmd = sprintf "remove %s" (req#param "keys") in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+ | "/reload" ->
+ let cmd = sprintf "reload %s" (req#param "keys") in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
| "/list" ->
(let log = new Uwobo_logger.processingLogger () in
log#log "Stylesheet list:";
List.iter (fun s -> log#log s) styles#list;
Http_daemon.respond ~body:log#asHtml outchan)
- | "/remove" ->
- act_on_keys
- req styles outchan
- styles#remove (fun () -> styles#removeAll) "removing"
- | "/reload" ->
- act_on_keys
- req styles outchan
- styles#reload (fun () -> styles#reloadAll) "reloading"
| "/apply" ->
- if Unix.fork () = 0 then
- (let logger = new Uwobo_logger.processingLogger () in
- let xmluri = req#param "xmluri" in
- let keys = Pcre.split ~pat:"," (req#param "keys") in
- (* notation: "local" parameters are those defined on a per-stylesheet
- pasis (i.e. param.key.param=value), "global" parameters are those
- defined for all stylesheets (i.e. param.param=value) *)
- let (params, props) = parse_apply_params req#params in
- syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
- let domImpl = Gdome.domImplementation () in
- let input = domImpl#createDocumentFromURI ~uri:xmluri () in
- syslogger#log `Debug "Applying stylesheet chain ...";
- try
- let (write_result, media_type, encoding) = (* out_channel -> unit *)
- Uwobo_engine.apply
- ~logger:syslogger ~styles ~keys ~input ~params ~props
- in
- let content_type = (* value of Content-Type HTTP response header *)
- sprintf
- "%s; charset=%s"
- (match media_type with None -> default_media_type | Some t -> t)
- (match encoding with None -> default_encoding | Some e -> e)
- in
- syslogger#log
- `Debug
- (sprintf
- "sending output to client (Content-Type: %s)...."
- content_type);
- Http_daemon.send_basic_headers ~code:200 outchan;
- Http_daemon.send_header "Content-Type" content_type outchan;
- Http_daemon.send_CRLF outchan;
- write_result outchan
- with Uwobo_failure errmsg ->
- return_error
- (sprintf "Stylesheet chain application failed: %s" errmsg)
- outchan)
- | "/help" -> Http_daemon.respond ~body:usage_string outchan
+ let logger = new Uwobo_logger.processingLogger () in
+ let xmluri = req#param "xmluri" in
+ let keys = Pcre.split ~pat:"," (req#param "keys") in
+ (* notation: "local" parameters are those defined on a per-stylesheet
+ pasis (i.e. param.key.param=value), "global" parameters are those
+ defined for all stylesheets (i.e. param.param=value) *)
+ let (params, props) = parse_apply_params req#params in
+ syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
+ let domImpl = Gdome.domImplementation () in
+ let input = domImpl#createDocumentFromURI ~uri:xmluri () in
+ syslogger#log `Debug "Applying stylesheet chain ...";
+ (try
+ let (write_result, media_type, encoding) = (* out_channel -> unit *)
+ let res = Uwobo_engine.apply
+ ~logger:syslogger ~styles ~keys ~input ~params ~props in
+ res
+ in
+ let content_type = (* value of Content-Type HTTP response header *)
+ sprintf "%s; charset=%s"
+ (match media_type with None -> default_media_type | Some t -> t)
+ (match encoding with None -> default_encoding | Some e -> e)
+ in
+ syslogger#log `Debug
+ (sprintf "sending output to client (Content-Type: %s)...."
+ content_type);
+ Http_daemon.send_basic_headers ~code:200 outchan;
+ Http_daemon.send_header "Content-Type" content_type outchan;
+ Http_daemon.send_CRLF outchan;
+ write_result outchan
+ with Uwobo_failure errmsg ->
+ return_error
+ (sprintf "Stylesheet chain application failed: %s" errmsg)
+ outchan)
+ | "/help" ->
+ output_string cmd_pipe "test\n";
+ flush cmd_pipe;
+ debug_print
+ (sprintf "Grandchild: grandparent said '%s'" (input_line res_pipe));
+ Http_daemon.respond ~body:usage_string outchan
| invalid_request ->
Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
syslogger#log `Debug (sprintf "%s done!" req#path);
| Http_types.Param_not_found attr_name ->
bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
| exc ->
- Http_daemon.respond
- ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
- outchan
+ return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
+in
+
+ (* UWOBO's startup *)
+let main () =
+ (* (1) system logger *)
+ let logger_outchan =
+ match logfile with
+ | None -> stderr
+ | Some f ->
+ open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm f
+ in
+ let syslogger =
+ new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
+ in
+ syslogger#enable;
+ (* (2) stylesheets list *)
+ let styles = new Uwobo_styles.styles in
+ (* (3) clean up actions *)
+ let die_nice () = (** at_exit callback *)
+ syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
+ syslogger#disable;
+ close_out logger_outchan
+ in
+ syslogger#log `Notice
+ (sprintf "%s started and listening on port %d" daemon_name port);
+ syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
+ Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *)
+ while true do
+ let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
+ let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
+ match Unix.fork () with
+ | child when child > 0 -> (* (5) parent: listen on cmd pipe for updates *)
+ let stop_http_daemon () = (* kill child *)
+ debug_print (sprintf "Grandparent: killing pid %d" child);
+ Unix.kill child Sys.sigterm; (* kill child ... *)
+ debug_print "Grandparent: waiting for its zombie ...";
+ ignore (Unix.waitpid [] child); (* ... and its zombie *)
+ debug_print "Grandparent: murder completed!!!"
+ in
+ at_exit die_nice;
+ Unix.close cmd_pipe_entrance;
+ Unix.close res_pipe_exit;
+ let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
+ let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
+ (try
+ while true do
+ (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
+ child process has been killed *)
+ debug_print "Grandparent: waiting for commands ...";
+ let cmd = input_line cmd_pipe in
+ debug_print (sprintf "Grandparent: received %s command" cmd);
+ (match cmd with (* command from grandchild *)
+ | "test" ->
+ debug_print "Grandparent: Hello, world!";
+ stop_http_daemon ();
+ output_string res_pipe "Grandparent: Hello, world!\n";
+ flush res_pipe;
+ raise Restart_HTTP_daemon
+ | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *)
+ let bindings =
+ Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line)
+ in
+ stop_http_daemon ();
+ let log = new Uwobo_logger.processingLogger () in
+ List.iter
+ (fun binding -> (* add a <key, stylesheet> binding *)
+ let pieces = Pcre.split ~pat:"," binding in
+ match pieces with
+ | [key; style] ->
+ log#log (sprintf "adding binding <%s,%s>" key style);
+ (try
+ styles#add key style;
+ with e ->
+ log#log (Printexc.to_string e))
+ | _ -> log#log (sprintf "invalid binding %s" binding))
+ bindings;
+ output_string res_pipe log#asHtml;
+ flush res_pipe;
+ raise Restart_HTTP_daemon
+ | line when Pcre.pmatch ~rex:remove_cmd_RE line -> (* /remove *)
+ stop_http_daemon ();
+ let arg = Pcre.replace ~rex:remove_cmd_RE line in
+ act_on_keys
+ arg styles res_pipe
+ styles#remove (fun () -> styles#removeAll)
+ "removing";
+ raise Restart_HTTP_daemon
+ | line when Pcre.pmatch ~rex:reload_cmd_RE line -> (* /reload *)
+ stop_http_daemon ();
+ let arg = Pcre.replace ~rex:reload_cmd_RE line in
+ act_on_keys
+ arg styles res_pipe
+ styles#reload (fun () -> styles#reloadAll)
+ "reloading";
+ raise Restart_HTTP_daemon
+ | cmd -> (* invalid interprocess command received *)
+ syslogger#log `Warning
+ (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
+ done
+ with Restart_HTTP_daemon ->
+ close_in cmd_pipe; (* these calls close also fds *)
+ close_out res_pipe;)
+ | 0 -> (* (6) child: serve http requests *)
+ Unix.close cmd_pipe_exit;
+ Unix.close res_pipe_entrance;
+ let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in
+ let res_pipe = Unix.in_channel_of_descr res_pipe_exit in
+ debug_print "Starting HTTP daemon ...";
+ Http_daemon.start'~port ~mode:`Fork
+ (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
+ | _ (* < 0 *) -> (* fork failed :-((( *)
+ failwith "Can't fork :-("
+ done
in
(* daemon initialization *)
-syslogger#log
- `Notice
- (sprintf "%s started and listening on port %d" daemon_name port);
-syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
-Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *)
-Http_daemon.start' ~port ~mode:`Thread callback;
-syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
+try
+ Sys.catch_break true;
+ main ()
+with Sys.Break -> () (* 'die_nice' registered with at_exit *)
+
projects / helm.git / commitdiff