From 40d69bb0d68b6da47c625cca9c276fa19d6cc3aa Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Sat, 15 Mar 2003 18:39:37 +0000 Subject: [PATCH] - catch libxslt error and debugging messages and return them to the user - preprocess stylesheet on add and reload just to show warning to the user - fixed feedback messages for reload action - better feedback messages for strange conditions (e.g. reload with no stylesheet loaded) - send text/html content type on feedback - removed some ancient debugging messages - commented Uwobo_styles interface --- helm/uwobo/uwobo.ml | 84 ++++++++++++++++----------- helm/uwobo/uwobo_styles.ml | 110 ++++++++++++++++++++++++------------ helm/uwobo/uwobo_styles.mli | 50 +++++++++++++--- 3 files changed, 169 insertions(+), 75 deletions(-) diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml index 741b8d20f..6b18f8bdd 100644 --- a/helm/uwobo/uwobo.ml +++ b/helm/uwobo/uwobo.ml @@ -50,30 +50,32 @@ let port = | Not_found -> default_port | Failure "int_of_string" -> prerr_endline "Warning: invalid port, reverting to default"; - default_port;; + default_port +;; + +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 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 ..." logmsg); + (try all_keys_action () with e -> logger#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 + logger#log (sprintf "%s stylesheet %s" logmsg key); + (try per_key_action key with e -> logger#log (Printexc.to_string e))) + keys ;; (** parse parameters for '/apply' action *) @@ -105,7 +107,7 @@ let parse_apply_params = 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 +117,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 @@ -131,7 +134,17 @@ let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE) = exception Restart_HTTP_daemon;; - (* reuquest handler action + (** log a list of libxslt's messages using a processing logger *) +let log_libxslt_msgs logger = + List.iter + (function + | Uwobo_styles.LibXsltErrorMsg msg -> + logger#logBold ("LibXSLT ERROR: " ^ msg) + | Uwobo_styles.LibXsltDebugMsg msg -> + logger#logEmph ("LibXSLT DEBUG " ^ msg)) +;; + + (* 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 @@ -162,9 +175,12 @@ let callback 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) + (match styles#list with + | [] -> log#log "No stylesheets loaded (yet)!" + | l -> + log#log "Stylesheets list:"; + List.iter (fun s -> log#log s) l); + respond_html log#asHtml outchan) | "/apply" -> let logger = new Uwobo_logger.processingLogger () in let xmluri = req#param "xmluri" in @@ -199,7 +215,7 @@ let callback return_error (sprintf "Stylesheet chain application failed: %s" errmsg) 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,7 +224,7 @@ 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 () = @@ -252,11 +268,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,14 +280,13 @@ 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:add_cmd_RE line -> (* /add *) @@ -289,7 +302,7 @@ let main () = | [key; style] -> log#log (sprintf "adding binding <%s,%s>" key style); (try - styles#add key style; + log_libxslt_msgs log (styles#add key style) with e -> log#log (Printexc.to_string e)) | _ -> log#log (sprintf "invalid binding %s" binding)) @@ -300,18 +313,24 @@ let main () = | 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 act_on_keys - arg styles res_pipe - styles#remove (fun () -> styles#removeAll) + arg styles logger + (fun key -> log_libxslt_msgs logger (styles#remove key)) + (fun () -> log_libxslt_msgs logger styles#removeAll) "removing"; + 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 act_on_keys - arg styles res_pipe - styles#reload (fun () -> styles#reloadAll) + arg styles logger + (fun key -> log_libxslt_msgs logger (styles#reload key)) + (fun () -> log_libxslt_msgs logger styles#reloadAll) "reloading"; + output_string res_pipe (logger#asHtml); raise Restart_HTTP_daemon | cmd -> (* invalid interprocess command received *) syslogger#log `Warning @@ -326,7 +345,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 +353,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 *) +;; diff --git a/helm/uwobo/uwobo_styles.ml b/helm/uwobo/uwobo_styles.ml index 9f954f63d..d866ede5d 100644 --- a/helm/uwobo/uwobo_styles.ml +++ b/helm/uwobo/uwobo_styles.ml @@ -28,74 +28,112 @@ open Printf;; -exception Stylesheet_not_found of string;; -exception Stylesheet_already_in of string;; +exception Stylesheet_not_found of string ;; +exception Stylesheet_already_in of string ;; + +type xslt_msg = + | LibXsltErrorMsg of string + | LibXsltDebugMsg of string +;; +type log = xslt_msg list ;; class styles = object (self) (* INVARIANT: 'stylesheets' and 'uris' are in sync *) - val mutable stylesheets = [] - val mutable uris = [] + initializer + Gdome_xslt.setErrorCallback + (Some (fun msg -> self#appendMsg (LibXsltErrorMsg msg))); + Gdome_xslt.setDebugCallback + (Some (fun msg -> self#appendMsg (LibXsltDebugMsg msg))) + + + val mutable stylesheets = [] (** association list: key -> Gdome.document *) + val mutable uris = [] (** association list: key -> uri *) + val mutable libXsltMsgs = [] (** libxslt's error and debugging messages *) + val domImpl = Gdome.domImplementation () (** process an XSLT stylesheet *) - method private process uri = domImpl#createDocumentFromURI ~uri () + method private process uri = + let dom = domImpl#createDocumentFromURI ~uri () in + ignore (Gdome_xslt.processStylesheet dom); (* fills libXsltMsgs in case + of errors *) + dom - method get keys = - let rev_keys = List.rev keys in - let last_key = List.hd rev_keys in - let p_stylesheets = - List.fold_left - (fun collected_styles key -> - let (key, stylesheet) = - try - List.find (fun (k, _) -> k = key) stylesheets - with Not_found -> raise (Stylesheet_not_found key) - in - (key, Gdome_xslt.processStylesheet stylesheet)::collected_styles) - [] - rev_keys - in - let last_stylesheet = - snd (List.find (fun (k, _) -> k = last_key) stylesheets) - in - (p_stylesheets, last_stylesheet) + (* libxslt's error and debugging messages handling *) + + method private appendMsg msg = libXsltMsgs <- msg :: libXsltMsgs + method private clearMsgs = libXsltMsgs <- [] + + (* stylesheets management *) method add key uri = if (List.mem_assoc key uris) then raise (Stylesheet_already_in key) else begin + self#clearMsgs; uris <- (key, uri) :: uris; - stylesheets <- (key, self#process uri) :: stylesheets + stylesheets <- (key, self#process uri) :: stylesheets; + libXsltMsgs end - method remove key = + method remove key : log = if not (List.mem_assoc key uris) then raise (Stylesheet_not_found key) else begin uris <- List.remove_assoc key uris; - stylesheets <- List.remove_assoc key stylesheets + stylesheets <- List.remove_assoc key stylesheets; + [] (* no XSLT action -> no logs *) end - method removeAll = uris <- []; stylesheets <- [] - - method list = - List.map - (fun (key, uri) -> - sprintf "key = %s, uri = %s" key (List.assoc key uris)) - uris + method removeAll : log = + uris <- []; + stylesheets <- []; + [] (* no XSLT action -> no logs *) method reload key = (try + self#clearMsgs; let uri = List.assoc key uris in stylesheets <- - (key, self#process uri) :: (List.remove_assoc key stylesheets) + (key, self#process uri) :: (List.remove_assoc key stylesheets); + libXsltMsgs with Not_found -> raise (Stylesheet_not_found key)) method reloadAll = - stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris + self#clearMsgs; + stylesheets <- List.map (fun (key, uri) -> (key, self#process uri)) uris; + libXsltMsgs + + (* stylesheets usage *) + + method list = + List.map + (fun (key, uri) -> + sprintf "key = %s, uri = %s" key (List.assoc key uris)) + uris + + method get keys = + let rev_keys = List.rev keys in + let last_key = List.hd rev_keys in + let p_stylesheets = + List.fold_left + (fun collected_styles key -> + let (key, stylesheet) = + try + List.find (fun (k, _) -> k = key) stylesheets + with Not_found -> raise (Stylesheet_not_found key) + in + (key, Gdome_xslt.processStylesheet stylesheet)::collected_styles) + [] + rev_keys + in + let last_stylesheet = + snd (List.find (fun (k, _) -> k = last_key) stylesheets) + in + (p_stylesheets, last_stylesheet) end diff --git a/helm/uwobo/uwobo_styles.mli b/helm/uwobo/uwobo_styles.mli index 5a0722f03..9d03b0924 100644 --- a/helm/uwobo/uwobo_styles.mli +++ b/helm/uwobo/uwobo_styles.mli @@ -26,19 +26,55 @@ * http://helm.cs.unibo.it/ *) -exception Stylesheet_not_found of string;; -exception Stylesheet_already_in of string;; +exception Stylesheet_not_found of string ;; +exception Stylesheet_already_in of string ;; + (** libxslt's message *) +type xslt_msg = + | LibXsltErrorMsg of string (** libxslt's error messages *) + | LibXsltDebugMsg of string (** libxslt's debugging messages *) +type log = xslt_msg list ;; + + (** hold UWOBO styles at runtime *) class styles: object - method add: string -> string -> unit - method remove: string -> unit - method removeAll: unit + + (** {2 Stylesheets management} *) + + (** add a stylesheet, bound to a given key, to the UWOBO loaded + stylesheets + @param key key to which the stylesheets will be bound + @param uri uri of the stylesheet to be loaded + @raise Stylesheet_already_in if key is already bound *) + method add: string -> string -> log + + (** remove the stylesheet bound to a given key *) + method remove: string -> log + + (** remove all loaded stylesheet *) + method removeAll: log + + (** reload the stylesheet bound to a given key *) + method reload: string -> log + + (** reload all stylesheets *) + method reloadAll: log + + (** {2 Stylesheets usage} *) + + (** @return a list of strings, each string is a textual representation of + information related to a loaded stylesheet. This representation includes + at least stylesheet's key and URI *) method list: string list - method reload: string -> unit - method reloadAll: unit + + (** @param key_list list of keys + @return a pair. First component of the returned pair is an association + list that maps given keys to gdome2-xslt processed stylesheets. Second + component of the returned pair is an unprocessed version of the + stylesheets corresponding to the latest key provided *) method get: string list -> (string * I_gdome_xslt.processed_stylesheet) list * Gdome.document + end -- 2.39.2