+++ /dev/null
-(*
- * 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://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 ^ "<br />" ^ 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 "<br />...<br />" else "<br />") ^
- 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: ("<h2>LibXSLT's messages:</h2>" ^
- String.concat "<br />\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 <key, stylesheet> 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 *)
-;;
-
projects / helm.git / blobdiff