X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=inline;f=helm%2Fuwobo%2Fuwobo.ml;h=d8341aeb6d924b3fd77cd979f75c492cd3cd1e33;hb=0afd42c06451194ce1849abf57bf56fe7ec6ae88;hp=a88f9484fc4b4bf1647a5b03b086efbe6d1ade03;hpb=d6cb4446b6c5653dcdfb555959e388ef1c4c6411;p=helm.git
diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml
index a88f9484f..d8341aeb6 100644
--- a/helm/uwobo/uwobo.ml
+++ b/helm/uwobo/uwobo.ml
@@ -35,34 +35,67 @@ let debug_level = `Notice ;;
let debug_print s = if debug then prerr_endline s ;;
Http_common.debug := false ;;
+let configuration_file = "/projects/helm/etc/uwobo.conf.xml";;
+
+ (* First of all we load the configuration *)
+let _ =
+ Helm_registry.load_from configuration_file
+;;
+
+let save_configuration () =
+ if not (Helm_registry.has "uwobo.cloned") then
+ Helm_registry.save_to configuration_file
+;;
+
(* other settings *)
let daemon_name = "UWOBO OCaml" ;;
-let default_log_file = "uwobo.log" ;; (* relative to execution dir *)
-let default_port = 58080 ;;
-let port_env_var = "UWOBO_PORT" ;;
let default_media_type = "text/html" ;;
let default_encoding = "utf8" ;;
-let logfile =
- Some (try Sys.getenv "UWOBO_LOG_FILE" with Not_found -> default_log_file)
+
+let get_media_type props =
+ try
+ List.assoc "media-type" props
+ with
+ Not_found -> default_media_type
;;
-let logfile_perm = 0o640 ;;
-let port =
+
+let get_encoding props =
+ try
+ List.assoc "encoding" props
+ with
+ Not_found -> default_encoding
+;;
+
+let string_of_param_option (req: Http_types.request) name =
try
- int_of_string (Sys.getenv port_env_var)
+ req#param name
with
- | Not_found -> default_port
- | Failure "int_of_string" ->
- prerr_endline "Warning: invalid port, reverting to default";
- default_port
+ Http_types.Param_not_found _ -> "#"
+
+let string_option_of_string =
+ function
+ "#" -> None
+ | s -> Some s
+
+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
@@ -71,13 +104,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
;;
@@ -106,6 +142,56 @@ let parse_apply_params =
((fun _ -> []), []) (* no parameters, no properties *)
;;
+let serialize_param_list =
+ let is_global_param = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" in
+ let is_local_param = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" in
+ function params ->
+ let param_value_list =
+ List.filter
+ (fun (param, _) -> (is_global_param param) || (is_local_param param))
+ params
+ in
+ (String.concat
+ ","
+ (List.map
+ (fun (param, value) -> (Pcre.replace ~pat:"^param\\." param) ^ "=" ^ value)
+ param_value_list))
+
+let deserialize_param_list =
+ List.map
+ (fun pv ->
+ match Pcre.split ~pat:"=" pv with
+ [key] -> (key, None)
+ | [key; value] -> (key, Some value)
+ | _ -> assert false)
+
+(** 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 *)
@@ -119,7 +205,7 @@ let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
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_basic_headers ~code:(`Code 200) outchan;
Http_daemon.send_header "Content-Type" "text/html" outchan;
Http_daemon.send_CRLF outchan;
(try
@@ -131,20 +217,92 @@ 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,
+ createprofile_cmd_RE, removeprofile_cmd_RE, setprofileparam_cmd_RE,
+ setparams_cmd_RE, setpassword_cmd_RE, setpermission_cmd_RE) =
+ (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ",
+ Pcre.regexp "^kill", Pcre.regexp "^createprofile ", Pcre.regexp "^removeprofile ",
+ Pcre.regexp "^setprofileparam ",
+ Pcre.regexp "^setparams ", Pcre.regexp "^setpassword ", Pcre.regexp "^setpermission ")
;;
-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_user_agent.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.putenv "uwobo__cloned" "1" ;
+ 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_user_agent.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
@@ -170,6 +328,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 ^ "
" ^ 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 "
...
" else "
") ^
+ 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
@@ -177,50 +377,176 @@ 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)
+ | "/listprofiles" ->
+ let profile_list = Uwobo_profiles.list () in
+ respond_html ("