(* other settings *)
let daemon_name = "UWOBO OCaml" ;;
-let default_log_file = "uwobo.log" ;; (* relative to execution dir *)
+let default_log_base_file = "log/uwobo" ;; (* relative to execution dir *)
+let log_extension = ".log" ;;
let default_port = 58080 ;;
let port_env_var = "UWOBO_PORT" ;;
+let log_env_var = "UWOBO_LOG_FILE" ;; (* The extension _pid.log will be added *)
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 logfile_perm = 0o640 ;;
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
+ prerr_endline "Warning: invalid port number" ;
+ exit (-1)
;;
+let logfilename_of_port port =
+ let basename =
+ try
+ Sys.getenv log_env_var
+ with
+ Not_found -> default_log_base_file
+ in
+ basename ^ "_" ^ string_of_int port ^ log_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
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")
;;
(** raised by child processes when HTTP daemon process have to be restarted *)
(* 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 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 ->
+ 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 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 :-("
+;;
+
(* request handler action
@param syslogger Uwobo_logger.sysLogger instance used for logginf
@param styles Uwobo_styles.styles instance which keeps the stylesheets list
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
let main () =
(* (1) system logger *)
let logger_outchan =
- match logfile with
- | None ->
- debug_print "Logging to standard error";
- stderr
- | Some f ->
- debug_print (sprintf "Logging to file %s" 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 ()
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)
projects / helm.git / blobdiff