| 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 *)
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
(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
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
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
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);
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 () =
| 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;
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 *)
| [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))
| 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
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
| _ (* < 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 *)
+;;
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
* 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
projects / helm.git / commitdiff