X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo.ml;h=6b18f8bdd14d4295caf62a216c8a9509f5776fd2;hb=40d69bb0d68b6da47c625cca9c276fa19d6cc3aa;hp=741b8d20f44ab6aa20cc55681068c0d04e56c217;hpb=3579acf4950fc4f9a4ddc3e2cfca372d67cba712;p=helm.git

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 *)
+;;