X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fsrc%2Focaml%2Fuwobo.ml;h=bea96a2a09b1cf1d61af184e658b9ddea5825138;hb=caab26f85122e0040555139c48a9111a0b2b9fff;hp=bc9646b062e0dd3e1a5b16ef907b64bcd6decd1f;hpb=37ac9346846cc656742dd94bba1c7b272ab98128;p=helm.git diff --git a/helm/uwobo/src/ocaml/uwobo.ml b/helm/uwobo/src/ocaml/uwobo.ml index bc9646b06..bea96a2a0 100644 --- a/helm/uwobo/src/ocaml/uwobo.ml +++ b/helm/uwobo/src/ocaml/uwobo.ml @@ -1,49 +1,45 @@ - -(* 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 + * 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 libxslt support 'http_proxy' variables, but IIRC access to this -variables is mentioned in non-reentrant stuff, so having those variables set -cause uwobo not to work properly when invoked recursively *) - -(* 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_level = `Debug;; +let debug = false;; +let debug_level = `Notice;; 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 = 0o640;; - (* 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";; @@ -54,127 +50,100 @@ let port = | 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 "

Error: %s

" 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 -" - - - UWOBO's help message - - -

- Usage: http://hostname:uwoboport/command -

- Available commands: -

- help
- display this help message -

- add?bind=key,uri[&bind=key,stylesheet[&...]]
- load a new stylesheet, specified by uri, and bind it to key - key -

- remove?[?keys=key1,key2,...]
- unload stylesheets specified by key1, key2, ... or all - stylesheets if no key was given -

- reload?[?keys=key1,key2,...]
- reload stylesheets specified by key1, key2, ... or all - stylesheets if no key was given -

- list
- return a list of loaded stylesheets -

- 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][&...]]]
- apply a chain of stylesheets, specified by key1, key2, ..., to an - input document, specified by uri.
- Additional parameters can be set for each stylesheet application: global - parameters (i.e. parameters passed to all stylesheets) are set using - param.name=value syntax, per stylesheet parameters are set using - param.key.name=value where key is the key of a loaded - stylesheet.
- Properties of the final chain output can be set too: valueless properties - can be set using prop.name syntax, others can be set using - prop.name=value syntax.
- Current supported properties are: %s. -

- - -" - (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 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 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_request.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); (match req#path with | "/add" -> @@ -182,88 +151,198 @@ let callback req outchan = 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 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) + Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan); + syslogger#log `Debug (sprintf "%s done!" req#path); with - | Http_request.Param_not_found attr_name -> + | 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 last_process = ref true in + let http_child = ref None in + let die_nice () = (** at_exit callback *) + if !last_process then begin + (match !http_child with + | None -> () + | Some pid -> Unix.kill pid Sys.sigterm); + syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name); + syslogger#disable; + close_out logger_outchan + end + in + at_exit die_nice; + ignore (Sys.signal Sys.sigterm + (Sys.Signal_handle (fun _ -> raise Sys.Break))); + 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 -> (* (4) parent: listen on cmd pipe for updates *) + http_child := Some child; + 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 + 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 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 -> (* (5) child: serve http requests *) + Unix.close cmd_pipe_exit; + Unix.close res_pipe_entrance; + last_process := false; + 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 ())); -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 *) +