X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo.ml;h=0a0294c41a051828d528f0eabf0f7f688283b1aa;hb=1c7fb836e2af4f2f3d18afd0396701f2094265ff;hp=741b8d20f44ab6aa20cc55681068c0d04e56c217;hpb=47b0c2c1b421b62302b1957954912b4c0dfba9fa;p=helm.git
diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml
index 741b8d20f..0a0294c41 100644
--- a/helm/uwobo/uwobo.ml
+++ b/helm/uwobo/uwobo.ml
@@ -30,50 +30,68 @@ 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;;
-let logfile = Some "uwobo.log";; (* relative to execution dir *)
-let logfile_perm = 0o640;;
+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_port = 58080;;
-let port_env_var = "UWOBO_PORT";;
-let default_media_type = "text/html";;
-let default_encoding = "utf8";;
+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, reverting to default";
- default_port;;
+ 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 outchan per_key_action all_keys_action logmsg
+let act_on_keys
+ keys_param styles logger per_key_action all_keys_action all_keys 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
+ 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))
+ 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 *)
- 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
+ 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 *)
@@ -101,11 +119,38 @@ let parse_apply_params =
((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);
+(* 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
@@ -115,6 +160,7 @@ let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
(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
@@ -125,13 +171,85 @@ let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
return_error "Timeout!" outchan)
;;
-let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE) =
- (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ")
+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
;;
-exception Restart_HTTP_daemon;;
+ (* LibXSLT logger *)
+let veillogger = new Uwobo_common.libXsltLogger ;;
- (* reuquest handler action
+ (* 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
@@ -154,6 +272,48 @@ let callback
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
@@ -161,27 +321,35 @@ let callback
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)
+ (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 *)
- let res = Uwobo_engine.apply
- ~logger:syslogger ~styles ~keys ~input ~params ~props in
- res
+ 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"
@@ -197,9 +365,12 @@ let callback
write_result outchan
with Uwobo_failure errmsg ->
return_error
- (sprintf "Stylesheet chain application failed: %s" errmsg)
+ ("Stylesheet chain application failed: " ^ errmsg)
+ ~body: ("LibXSLT's messages:
" ^
+ String.concat "
\n"
+ (List.map string_of_xslt_msg veillogger#msgs))
outchan)
- | "/help" -> Http_daemon.respond ~body:usage_string 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);
@@ -208,16 +379,14 @@ let callback
bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
| exc ->
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
+ 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 ()
@@ -252,11 +421,9 @@ let main () =
| 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);
+ debug_print (sprintf "UWOBOmaster: 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;
@@ -266,52 +433,63 @@ let main () =
while true do
(* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
child process has been killed *)
- debug_print "Grandparent: waiting for commands ...";
+ debug_print "UWOBOmaster: waiting for commands ...";
let cmd = input_line cmd_pipe in
- debug_print (sprintf "Grandparent: received %s command" cmd);
+ debug_print (sprintf "UWOBOmaster: 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";
+ 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 log = new Uwobo_logger.processingLogger () in
+ 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] ->
- log#log (sprintf "adding binding <%s,%s>" 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 ->
- log#log (Printexc.to_string e))
- | _ -> log#log (sprintf "invalid binding %s" binding))
+ logger#log (Printexc.to_string e))
+ | _ -> logger#log (sprintf "invalid binding %s" binding))
bindings;
- output_string res_pipe log#asHtml;
+ 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 res_pipe
- styles#remove (fun () -> styles#removeAll)
+ 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 res_pipe
- styles#reload (fun () -> styles#reloadAll)
+ 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
@@ -326,7 +504,7 @@ let main () =
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 ...";
+ 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
@@ -334,11 +512,12 @@ let main () =
| _ (* < 0 *) -> (* fork failed :-((( *)
failwith "Can't fork :-("
done
-in
+;;
(* daemon initialization *)
try
Sys.catch_break true;
main ()
with Sys.Break -> () (* 'die_nice' registered with at_exit *)
+;;