X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo.ml;h=729c5c01721bfcb4936023fb57c8b86e046532df;hb=1f9b11657c822cc762f808e0bfc5f5f2b4fb6ec7;hp=9dc9b539405f4b5b08480249d5d5ad3edb1e0d9a;hpb=828ef0c1de3cd18634ca2a5070818e521fb5f19e;p=helm.git
diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml
index 9dc9b5394..729c5c017 100644
--- a/helm/uwobo/uwobo.ml
+++ b/helm/uwobo/uwobo.ml
@@ -110,6 +110,33 @@ 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 *)
@@ -139,18 +166,21 @@ let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE) =
(Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ")
;;
-exception Restart_HTTP_daemon;;
+ (** 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 =
+let log_libxslt_msgs logger libxslt_logger =
List.iter
(function
- | Uwobo_styles.LibXsltErrorMsg msg ->
- logger#logBold ("LibXSLT ERROR: " ^ msg)
- | Uwobo_styles.LibXsltDebugMsg msg ->
- logger#logEmph ("LibXSLT DEBUG " ^ msg))
+ | (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 ;;
+
(* request handler action
@param syslogger Uwobo_logger.sysLogger instance used for logginf
@param styles Uwobo_styles.styles instance which keeps the stylesheets list
@@ -181,30 +211,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
+ (let logger = new Uwobo_logger.processingLogger () in
(match styles#list with
- | [] -> log#log "No stylesheets loaded (yet)!"
+ | [] -> logger#log "No stylesheets loaded (yet)!"
| l ->
- log#log "Stylesheets list:";
- List.iter (fun s -> log#log s) l);
- respond_html log#asHtml outchan)
+ 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"
@@ -220,7 +255,10 @@ 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" -> respond_html usage_string outchan
| invalid_request ->
@@ -304,43 +342,45 @@ let main () =
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
- log_libxslt_msgs log (styles#add key style)
+ 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 logger
- (fun key -> log_libxslt_msgs logger (styles#remove key))
- (fun () -> log_libxslt_msgs logger styles#removeAll)
- styles#keys
+ 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
- (fun key -> log_libxslt_msgs logger (styles#reload key))
- (fun () -> log_libxslt_msgs logger styles#reloadAll)
- styles#keys
+ styles#reload (fun () -> styles#reloadAll) styles#keys
"reloading";
output_string res_pipe (logger#asHtml);
raise Restart_HTTP_daemon