X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo.ml;fp=helm%2Fuwobo%2Fuwobo.ml;h=0000000000000000000000000000000000000000;hb=c7514aaa249a96c5fdd39b1123fbdb38d92f20b6;hp=0a0294c41a051828d528f0eabf0f7f688283b1aa;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff;p=helm.git diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml deleted file mode 100644 index 0a0294c41..000000000 --- a/helm/uwobo/uwobo.ml +++ /dev/null @@ -1,523 +0,0 @@ -(* - * 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://helm.cs.unibo.it/ - *) - -open Printf;; -open Uwobo_common;; - - (* debugging settings *) -let debug = false ;; -let debug_level = `Notice ;; -let debug_print s = if debug then prerr_endline s ;; -Http_common.debug := false ;; - - (* other settings *) -let daemon_name = "UWOBO OCaml" ;; -let default_log_base_file = "log/uwobo" ;; (* relative to execution dir *) -let log_extension = ".log" ;; -let default_port = 58080 ;; -let port_env_var = "UWOBO_PORT" ;; -let log_env_var = "UWOBO_LOG_FILE" ;; (* The extension _pid.log will be added *) -let default_media_type = "text/html" ;; -let default_encoding = "utf8" ;; -let port = - try - int_of_string (Sys.getenv port_env_var) - with - | Not_found -> default_port - | Failure "int_of_string" -> - prerr_endline "Warning: invalid port number" ; - exit (-1) -;; -let logfilename_of_port port = - let basename = - try - Sys.getenv log_env_var - with - Not_found -> default_log_base_file - in - basename ^ "_" ^ string_of_int port ^ log_extension -;; -let logfile = logfilename_of_port port;; -let logfile_perm = 0o640 ;; - -let respond_html body outchan = - Http_daemon.respond ~body ~headers:["Content-Type", "text/html"] 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 - keys_param styles logger per_key_action all_keys_action all_keys logmsg -= - 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 *) - logger#log (sprintf "%s all stylesheets (keys = %s) ..." - logmsg (String.concat ", " all_keys)); - (try all_keys_action () with e -> logger#log (Printexc.to_string e)); - logger#log (sprintf "Done! (all stylesheets)") - | keys -> - List.iter - (fun key -> (* act on a single stylesheet *) - logger#log (sprintf "%s stylesheet %s" logmsg key); - (try per_key_action key with e -> logger#log (Printexc.to_string e)); - logger#log (sprintf "Done! (stylesheet %s)" key)) - keys -;; - - (** 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 *) -;; - - (** Parse libxslt's message modes for error and debugging messages. Default is - to ignore mesages of both kind *) -let parse_libxslt_msgs_mode (req: Http_types.request) = - ((try - (match req#param "errormode" with - | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore - | s when String.lowercase s = "comment" -> LibXsltMsgComment - | s when String.lowercase s = "embed" -> LibXsltMsgEmbed - | err -> - raise (Uwobo_failure - (sprintf - "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'" - err "errormode" "ignore" "comment"))) - with Http_types.Param_not_found _ -> LibXsltMsgIgnore), - (try - (match req#param "debugmode" with - | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore - | s when String.lowercase s = "comment" -> LibXsltMsgComment - | s when String.lowercase s = "embed" -> LibXsltMsgEmbed - | err -> - raise (Uwobo_failure - (sprintf - "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'" - err "debugmode" "ignore" "comment"))) - with Http_types.Param_not_found _ -> LibXsltMsgIgnore)) -;; - - (** 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_header "Content-Type" "text/html" 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, kill_cmd_RE) = - (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ", - Pcre.regexp "^kill") -;; - - (** raised by child processes when HTTP daemon process have to be restarted *) -exception Restart_HTTP_daemon ;; - - (** log a list of libxslt's messages using a processing logger *) -let log_libxslt_msgs logger libxslt_logger = - List.iter - (function - | (LibXsltErrorMsg _) as msg -> logger#logBold (string_of_xslt_msg msg) - | (LibXsltDebugMsg _) as msg -> logger#logEmph (string_of_xslt_msg msg)) - libxslt_logger#msgs -;; - - (* LibXSLT logger *) -let veillogger = new Uwobo_common.libXsltLogger ;; - - (* start_new_session cmd_pipe_exit res_pipe_entrance outchan port logfile - @param cmd_pipe Pipe to be closed before forking - @param res_pipe Pipe to be closed before forking - @param outchan To be closed before forking - @param port The port to be used - @param logfile The logfile to redirect the stdout and sterr to - *) - (* It can raise Failure "Connection refused" *) - (* It can raise Failure "Port already in use" *) -let start_new_session cmd_pipe res_pipe outchan port logfile = - let environment = - (* Here I am loosing the current value of port_env_var; *) - (* this should not matter *) - Unix.putenv port_env_var (string_of_int port) ; - Unix.environment () - in - (* Let's check that the port is free *) - (try - ignore - (Http_client.Convenience.http_head_message - ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ; - raise (Failure "Port already in use") - with - Failure "Connection refused" -> () - ) ; - match Unix.fork () with - 0 -> - Unix.handle_unix_error - (function () -> - (* 1. We close all the open pipes to avoid duplicating them *) - Unix.close (Unix.descr_of_out_channel cmd_pipe) ; - Unix.close (Unix.descr_of_in_channel res_pipe) ; - Unix.close (Unix.descr_of_out_channel outchan) ; - (* 2. We redirect stdout and stderr to the logfile *) - Unix.close Unix.stdout ; - assert - (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT] - 0o664 = Unix.stdout) ; - Unix.close Unix.stderr ; - assert - (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT] - 0o664 = Unix.stderr) ; - prerr_endline "***** Starting a new session" ; - (* 3. We exec a new copy of uwobo *) - Unix.execve Sys.executable_name [||] environment ; - (* It should never reach this point *) - assert false - ) () - | child when child > 0 -> - (* let's check if the new UWOBO started correctly *) - Unix.sleep 5 ; - (* It can raise Failure "Connection refused" *) - ignore - (Http_client.Convenience.http_head_message - ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) - | _ -> failwith "Can't fork :-(" -;; - - (* request handler 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" -> - (let bindings = req#paramAll "bind" in - if bindings = [] then - return_error "No [key,stylesheet] binding provided" outchan - else begin - let cmd = sprintf "add %s" (String.concat ";" bindings) in - short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan - end) - | "/kill" -> - let logger = new Uwobo_logger.processingLogger () in - logger#log "Exiting" ; - respond_html logger#asHtml outchan ; - let cmd = "kill" in - short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan - | "/newsession" -> - let logger = new Uwobo_logger.processingLogger () in - let port = int_of_string (req#param "port") in - let logfile = logfilename_of_port port in - (try - start_new_session cmd_pipe res_pipe outchan port logfile ; - logger#log (sprintf "New session started: port = %d" port) ; - respond_html logger#asHtml outchan - with - Failure "int_of_string" -> - logger#log (sprintf "Invalid port number") ; - respond_html logger#asHtml outchan - | Failure "Port already in use" -> - Uwobo_common.return_error "port already in use" outchan - | Failure "Connection refused" -> - let log = ref [] in - (try - let ch = open_in logfile in - while true do log := (input_line ch ^ "\n") :: !log ; done - with - Sys_error _ - | End_of_file -> () - ) ; - let rec get_last_lines acc = - function - (n,he::tl) when n > 0 -> - get_last_lines (he ^ "
" ^ acc) (n-1,tl) - | _ -> acc - in - (* we just show the last 10 lines of the log file *) - let msg = - (if List.length !log > 0 then "
...
" else "
") ^ - get_last_lines "" (10,!log) - in - Uwobo_common.return_error "daemon not initialized" - ~body:msg outchan) - | "/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 logger = new Uwobo_logger.processingLogger () in - (match styles#list with - | [] -> logger#log "No stylesheets loaded (yet)!" - | l -> - logger#log "Stylesheets list:"; - List.iter (fun s -> logger#log s) l); - respond_html logger#asHtml outchan) - | "/apply" -> - let logger = new Uwobo_logger.processingLogger () in - veillogger#clearMsgs; - 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 - let (libxslt_errormode, libxslt_debugmode) = - parse_libxslt_msgs_mode req - 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 ~params ~props ~veillogger - ~errormode:libxslt_errormode ~debugmode:libxslt_debugmode - input - 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 - ("Stylesheet chain application failed: " ^ errmsg) - ~body: ("

LibXSLT's messages:

" ^ - String.concat "
\n" - (List.map string_of_xslt_msg veillogger#msgs)) - outchan) - | "/help" -> respond_html usage_string outchan - | invalid_request -> - Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan); - syslogger#log `Debug (sprintf "%s done!" req#path); - with - | Http_types.Param_not_found attr_name -> - bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan - | exc -> - return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan -;; - - (* UWOBO's startup *) -let main () = - (* (1) system logger *) - let logger_outchan = - debug_print (sprintf "Logging to file %s" logfile); - open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm logfile - 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 "UWOBOmaster: killing pid %d" child); - Unix.kill child Sys.sigterm; (* kill child ... *) - ignore (Unix.waitpid [] child); (* ... and its zombie *) - 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 "UWOBOmaster: waiting for commands ..."; - let cmd = input_line cmd_pipe in - debug_print (sprintf "UWOBOmaster: received %s command" cmd); - (match cmd with (* command from grandchild *) - | "test" -> - stop_http_daemon (); - output_string res_pipe "UWOBOmaster: Hello, world!\n"; - flush res_pipe; - raise Restart_HTTP_daemon - | line when Pcre.pmatch ~rex:kill_cmd_RE line -> (* /kill *) - exit 0 - | 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 logger = new Uwobo_logger.processingLogger () in - List.iter - (fun binding -> (* add a binding *) - let pieces = Pcre.split ~pat:"," binding in - match pieces with - | [key; style] -> - logger#log (sprintf "adding binding <%s,%s>" key style); - veillogger#clearMsgs; - (try - veillogger#clearMsgs; - styles#add key style; - log_libxslt_msgs logger veillogger; - with e -> - logger#log (Printexc.to_string e)) - | _ -> logger#log (sprintf "invalid binding %s" binding)) - bindings; - output_string res_pipe logger#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 - let logger = new Uwobo_logger.processingLogger () in - veillogger#clearMsgs; - act_on_keys - arg styles logger - styles#remove (fun () -> styles#removeAll) styles#keys - "removing"; - log_libxslt_msgs logger veillogger; - output_string res_pipe (logger#asHtml); - 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 - let logger = new Uwobo_logger.processingLogger () in - veillogger#clearMsgs; - act_on_keys - arg styles logger - styles#reload (fun () -> styles#reloadAll) styles#keys - "reloading"; - output_string res_pipe (logger#asHtml); - 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 (sprintf "Starting HTTP daemon on port %d ..." port); - (* next invocation doesn't return, process will keep on serving HTTP - requests until it will get killed by father *) - Http_daemon.start'~port ~mode:`Fork - (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ()) - | _ (* < 0 *) -> (* fork failed :-((( *) - failwith "Can't fork :-(" - done -;; - - (* daemon initialization *) -try - Sys.catch_break true; - main () -with Sys.Break -> () (* 'die_nice' registered with at_exit *) -;; -