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

diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml
index 6b18f8bdd..d680f9e28 100644
--- a/helm/uwobo/uwobo.ml
+++ b/helm/uwobo/uwobo.ml
@@ -30,36 +30,56 @@ 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 ;;
+
+
+  (* First of all we load the configuration *)
+let _ =
+ let configuration_file = "/projects/helm/etc/uwobo.conf.xml" in
+  Helm_registry.load_from configuration_file
+;;
 
   (* 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 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
+let daemon_name = "UWOBO OCaml" ;;
+let default_media_type = "text/html" ;;
+let default_encoding = "utf8" ;;
+
+let get_media_type props =
+ try
+  List.assoc "media-type" props
+ with
+  Not_found -> default_media_type
 ;;
 
+let get_encoding props =
+ try
+  List.assoc "encoding" props
+ with
+  Not_found -> default_encoding
+;;
+
+let port = Helm_registry.get_int "uwobo.port";;
+
+let logfilename_of_port port =
+ let basename = Helm_registry.get "uwobo.log_basename" in
+ let extension = Helm_registry.get "uwobo.log_extension" in
+  basename ^ "_" ^ string_of_int port ^ 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 logger 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 keys =
     try
@@ -68,13 +88,16 @@ let act_on_keys keys_param styles logger per_key_action all_keys_action logmsg
   in
   match keys with
   | [] -> (* no key provided, act on all stylesheets *)
-      logger#log (sprintf "%s all stylesheets ..." logmsg);
-      (try all_keys_action () with e -> logger#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 *)
           logger#log (sprintf "%s stylesheet %s" logmsg key);
-          (try per_key_action key with e -> logger#log (Printexc.to_string e)))
+          (try per_key_action key with e -> logger#log (Printexc.to_string e));
+          logger#log (sprintf "Done! (stylesheet %s)" key))
         keys
 ;;
 
@@ -103,6 +126,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 *)
@@ -128,20 +178,87 @@ 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")
 ;;
 
-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 ;;
+
+  (* 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's check that the port is free *)
+ (try
+   ignore
+    (Http_client.http_get
+      ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ;
+   raise (Failure "Port already in use")
+  with
+   Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> ()
+ ) ;
+ 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 set up a new environment *)
+         let environment =
+          (* Here I am loosing the current value of port_env_var; *)
+          (* this should not matter                               *)
+          Unix.putenv "UWOBO__PORT" (string_of_int port) ;
+          Unix.environment ()
+         in
+         (* 4. 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" *)
+     (try
+       ignore
+         (Http_client.http_get
+           ("http://127.0.0.1:" ^ string_of_int port ^ "/help"))
+     with Unix.Unix_error (Unix.ECONNREFUSED, _, _) ->
+       raise (Failure "Connection refused"))
+  | _ -> failwith "Can't fork :-("
 ;;
 
   (* request handler action
@@ -167,6 +284,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 ^ "<br />" ^ 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 "<br />...<br />" else "<br />") ^
+                 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
@@ -174,35 +333,40 @@ 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"
-              (match media_type with None -> default_media_type | Some t -> t)
-              (match encoding with None -> default_encoding | Some e -> e)
+              (match media_type with None -> get_media_type props | Some t -> t)
+              (match encoding with None -> get_encoding props | Some e -> e)
           in
           syslogger#log `Debug
             (sprintf "sending output to client (Content-Type: %s)...."
@@ -213,7 +377,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: ("<h2>LibXSLT's messages:</h2>" ^
+              String.concat "<br />\n"
+                (List.map string_of_xslt_msg veillogger#msgs))
             outchan)
     | "/help" -> respond_html usage_string outchan
     | invalid_request ->
@@ -230,10 +397,8 @@ let callback
 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 ()
@@ -289,46 +454,52 @@ let main () =
                 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 <key, stylesheet> 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#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#reload (fun () -> styles#reloadAll) styles#keys
                   "reloading";
                 output_string res_pipe (logger#asHtml);
                 raise Restart_HTTP_daemon