+ return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
+in
+
+ (* UWOBO's startup *)
+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
+ in
+ let syslogger =
+ new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
+ in
+ syslogger#enable;
+ (* (2) stylesheets list *)
+ let styles = new Uwobo_styles.styles in
+ (* (3) clean up actions *)
+ let last_process = ref true in
+ let http_child = ref None in
+ let die_nice () = (** at_exit callback *)
+ if !last_process then begin
+ (match !http_child with
+ | None -> ()
+ | Some pid -> Unix.kill pid Sys.sigterm);
+ syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
+ syslogger#disable;
+ close_out logger_outchan
+ end
+ in
+ at_exit die_nice;
+ ignore (Sys.signal Sys.sigterm
+ (Sys.Signal_handle (fun _ -> raise Sys.Break)));
+ syslogger#log `Notice
+ (sprintf "%s started and listening on port %d" daemon_name port);
+ syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
+ Unix.putenv "http_proxy" ""; (* reset http_proxy to avoid libxslt problems *)
+ while true do
+ let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
+ let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
+ match Unix.fork () with
+ | 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);
+ 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;
+ let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
+ let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
+ (try
+ while true do
+ (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
+ child process has been killed *)
+ debug_print "Grandparent: waiting for commands ...";
+ let cmd = input_line cmd_pipe in
+ debug_print (sprintf "Grandparent: 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";
+ flush res_pipe;
+ raise Restart_HTTP_daemon
+ | 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
+ 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);
+ (try
+ styles#add key style;
+ with e ->
+ log#log (Printexc.to_string e))
+ | _ -> log#log (sprintf "invalid binding %s" binding))
+ bindings;
+ output_string res_pipe log#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
+ act_on_keys
+ arg styles res_pipe
+ styles#remove (fun () -> styles#removeAll)
+ "removing";
+ 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
+ act_on_keys
+ arg styles res_pipe
+ styles#reload (fun () -> styles#reloadAll)
+ "reloading";
+ raise Restart_HTTP_daemon
+ | cmd -> (* invalid interprocess command received *)
+ syslogger#log `Warning
+ (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
+ done
+ with Restart_HTTP_daemon ->
+ close_in cmd_pipe; (* these calls close also fds *)
+ close_out res_pipe;)
+ | 0 -> (* (5) child: serve http requests *)
+ Unix.close cmd_pipe_exit;
+ Unix.close res_pipe_entrance;
+ 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 ...";
+ Http_daemon.start'~port ~mode:`Fork
+ (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
+ | _ (* < 0 *) -> (* fork failed :-((( *)
+ failwith "Can't fork :-("
+ done