X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=inline;f=helm%2Fuwobo%2Fuwobo.ml;h=1a5b44f620264f3c862bc09f3759b25c68dd311c;hb=b17f04ca2d984e6a26e4dad9d35b881f64566951;hp=450449ec41d2d27db3054ed9cd0f7ba653d7a796;hpb=4356ee2e1a539506c28d90bc171cfffe8e1998b4;p=helm.git
diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml
index 450449ec4..1a5b44f62 100644
--- a/helm/uwobo/uwobo.ml
+++ b/helm/uwobo/uwobo.ml
@@ -35,32 +35,57 @@ 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_base_file = "log/uwobo_" ;; (* relative to execution dir *)
-let default_log_extension = ".log" ;;
-let default_port = 58080 ;;
-let port_env_var = "UWOBO_PORT" ;;
-let log_env_var = "UWOBO_LOG_FILE" ;;
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 number" ;
- exit (-1)
+
+let get_media_type props =
+ try
+ List.assoc "media-type" props
+ with
+ Not_found -> default_media_type
;;
-let logfilename_of_port ~use_log_env_var port =
- (try
- if use_log_env_var then Sys.getenv log_env_var else raise Not_found
+
+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
+ req#param name
with
- Not_found ->
- default_log_base_file ^ (string_of_int port) ^ default_log_extension)
+ 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 true port;;
+
+let logfile = logfilename_of_port port;;
let logfile_perm = 0o640 ;;
let respond_html body outchan =
@@ -117,7 +142,30 @@ let parse_apply_params =
((fun _ -> []), []) (* no parameters, no properties *)
;;
- (** Parse libxslt's message modes for error and debugging messages. Default is
+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
@@ -157,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
@@ -169,9 +217,13 @@ 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, kill_cmd_RE) =
+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 "^kill", Pcre.regexp "^createprofile ", Pcre.regexp "^removeprofile ",
+ Pcre.regexp "^setprofileparam ",
+ Pcre.regexp "^setparams ", Pcre.regexp "^setpassword ", Pcre.regexp "^setpermission ")
;;
(** raised by child processes when HTTP daemon process have to be restarted *)
@@ -199,49 +251,58 @@ let veillogger = new Uwobo_common.libXsltLogger ;;
(* 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 environment =
- (* Here I am loosing the current value of port_env_var; *)
- (* this should not matter *)
- Unix.putenv port_env_var (string_of_int port) ;
- Unix.environment ()
- in
- (* Let's check that the port is free *)
- (try
- ignore
- (Http_client.Convenience.http_head_message
- ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ;
- raise (Failure "Port already in use")
- with
- Failure "Connection refused" -> ()
- ) ;
- match Unix.fork () with
- 0 ->
- (* 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 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" *)
- ignore
- (Http_client.Convenience.http_head_message
- ("http://127.0.0.1:" ^ string_of_int port ^ "/help"))
- | _ -> failwith "Can't fork :-("
+ (* 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
@@ -276,38 +337,38 @@ let callback
| "/newsession" ->
let logger = new Uwobo_logger.processingLogger () in
let port = int_of_string (req#param "port") in
- let logfile = logfilename_of_port false 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 ->
+ 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"
+ | _ -> 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
@@ -323,21 +384,151 @@ let callback
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 ("