(*
 * Copyright (C) 2003:
 *    Stefano Zacchiroli <zack@cs.unibo.it>
 *    for the HELM Team http://helm.cs.unibo.it/
 *
 *  This file is part of HELM, an Hypertextual, Electronic
 *  Library of Mathematics, developed at the Computer Science
 *  Department, University of Bologna, Italy.
 *
 *  HELM is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU General Public License
 *  as published by the Free Software Foundation; either version 2
 *  of the License, or (at your option) any later version.
 *
 *  HELM is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with HELM; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
 *  MA  02111-1307, USA.
 *
 *  For details, see the HELM World-Wide-Web page,
 *  http://helm.cs.unibo.it/
 *)

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 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_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 string_of_param_option (req: Http_types.request) name =
  try
    req#param name
  with
      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 all_keys logmsg
=
  let keys =
    try
      Pcre.split ~pat:"," keys_param
    with Http_types.Param_not_found _ -> []
  in
  match keys with
  | [] -> (* no key provided, act on all stylesheets *)
      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));
          logger#log (sprintf "Done! (stylesheet %s)" key))
        keys
;;

  (** parse parameters for '/apply' action *)
let parse_apply_params =
  let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
  let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
  let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
  List.fold_left
    (fun (old_params, old_properties) (name, value) ->
      match name with
      | name when is_global_param name ->
          let name = Pcre.replace ~pat:"^param\\." name in
          ((fun x -> (old_params x) @ [name, value]), old_properties)
      | name when is_local_param name ->
          let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
          let (key, name) = (pieces.(1), pieces.(2)) in
          ((function
            | x when x = key -> [name, value] @ (old_params x)
            | x -> old_params x),
           old_properties)
      | name when is_property name ->
          let name = Pcre.replace ~pat:"^prop\\." name in
          (old_params, ((name, value) :: old_properties))
      | _ -> (old_params, old_properties))
    ((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 *)
let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
(*   debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); *)
  output_string cmd_pipe (cmd ^ "\n");  (* send command to grandfather *)
  flush cmd_pipe;
  let res_pipe_fd = Unix.descr_of_in_channel res_pipe in
  let (read_fds, _, _) =  (* wait for an answer *)
    Unix.select [res_pipe_fd] [] [] 60.0
  in
  (match read_fds with
  | [fd] when fd = res_pipe_fd -> (* send answer to http client *)
      Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
      Http_daemon.send_header "Content-Type" "text/html" outchan;
      Http_daemon.send_CRLF outchan;
      (try
        while true do
          output_string outchan ((input_line res_pipe) ^ "\n")
        done
      with End_of_file -> flush outchan)
  | _ ->  (* no answer received from grandfather *)
      return_error "Timeout!" outchan)
;;

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 ")
;;

  (** 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 libxslt_logger =
  List.iter
    (function
      | (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
  @param syslogger Uwobo_logger.sysLogger instance used for logginf
  @param styles Uwobo_styles.styles instance which keeps the stylesheets list
  @param cmd_pipe output _channel_ used to _write_ update messages
  @param res_pipe input _channel_ used to _read_ grandparent results
  @param req http request instance
  @param outchan output channel connected to http client
  *)
let callback
  ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
  =
  try
    syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
    syslogger#log `Debug (sprintf "Received request: %s" req#path);
    (match req#path with
    | "/add" ->
        (let bindings = req#paramAll "bind" in
        if bindings = [] then
          return_error "No [key,stylesheet] binding provided" outchan
        else begin
          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
    | "/reload" ->
          let cmd = sprintf "reload %s" (req#param "keys") in
          short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
    | "/list" ->
        (let logger = new Uwobo_logger.processingLogger () in
        (match styles#list with
        | [] -> logger#log "No stylesheets loaded (yet)!"
        | l ->
            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 ("<html><body><ul>" ^ String.concat "" (List.map (fun s -> "<li>" ^ s ^ "</li>") profile_list) ^ "</ul></body></html>") outchan
    | "/createprofile" ->
	let serialized_param_value_list = serialize_param_list req#params in
	let cmd = sprintf "createprofile %s,%s,%s,%s,%s,%s,%s,%s" 
		    (string_of_param_option req "id")
		    (string_of_param_option req "orig")
		    (string_of_param_option req "origpassword")
		    (string_of_param_option req "readperm")
		    (string_of_param_option req "writeperm")
		    (string_of_param_option req "adminperm")
		    (string_of_param_option req "password")
		    serialized_param_value_list
	in
	  short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
    | "/removeprofile" -> 
	let cmd = sprintf "removeprofile %s,%s" 
		    (req#param "id")
		    (string_of_param_option req "password")
	in
	  short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
    | "/setparam" ->
	let cmd = sprintf "setprofileparam %s,%s,%s,%s" 
		    (string_of_param_option req "id")
		    (string_of_param_option req "password")
		    (req#param "key")
		    (string_of_param_option req "value")
	in
	  short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
    | "/setpassword" ->
	let cmd = sprintf "setpassword %s,%s,%s" 
		    (req#param "id")
		    (string_of_param_option req "oldpassword")
		    (string_of_param_option req "password")
	in
	  short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
    | "/setpermission" ->
	begin
	  match req#param "for" with
	      "read"
	    | "write"
	    | "admin" as forwhat ->
		let cmd = sprintf "setpermission %s,%s,%s,%s" 
			    (req#param "id")
			    (string_of_param_option req "password")
			    forwhat
			    (req#param "value")
		in
		  short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
	    | _ -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan
	end
    | "/getparams" ->
        let pid = req#param "id" in
	let password = try Some (req#param "password") with _ -> None in
	let res = Uwobo_profiles.get_params pid ?password () in
	respond_html
	 ("<html><body><ul>" ^
	  String.concat "" (List.map (fun (k,v) -> "<li><key>" ^ k ^ "</key> = <value>" ^ v  ^ "</value></li>") res) ^
	  "</ul></body></html>") outchan
    | "/setparams" ->
	let serialized_param_value_list = serialize_param_list req#params in
	let cmd = sprintf "setparams %s,%s,%s"
		    (req#param "id")
		    (string_of_param_option req "password")
		    serialized_param_value_list
	in
	  short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
    | "/getparam" ->
        let pid = req#param "id" in
	let password = try Some (req#param "password") with _ -> None in
        let key = req#param "key" in
	let value = Uwobo_profiles.get_param pid ?password ~key () in
	respond_html ("<html><body>" ^ value ^ "</body></html>") outchan
    | "/getpermission" ->
        let pid = req#param "id" in
	let password = try Some (req#param "password") with _ -> None in
        let forwhat =
	 match req#param "for" with
            "read" -> Some `Read
          | "write" -> Some `Write
          | "admin" -> Some `Admin
          | _ -> None
	in
	 begin
	  match forwhat with
	     Some forwhat ->
	      let value = Uwobo_profiles.get_permission pid ?password forwhat in
	      respond_html ("<html><body>" ^ (if value then "public" else "private") ^ "</body></html>") outchan
           | None -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan ;
         end
    | "/apply" ->
        let logger = new Uwobo_logger.processingLogger () in
        veillogger#clearMsgs;
	let profile = try Some (req#param "profile") with _ -> None in
	let password = try Some (req#param "password") with _ -> None in
        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 (user_params, props) = parse_apply_params req#params in
	let profile_params =
	 match profile with
	    None -> []
	  | Some profile -> Uwobo_profiles.get_params profile ?password () in
	let params =
	 (* user provided parameters override the profile parameters *)
         let is_global_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){1}$" ("." ^ x) in
         let is_local_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){2}$" ("." ^ x) in
	 let add key value params =
	  if List.mem_assoc key params then params else params @ [key,value]
	 in
          List.fold_left
            (fun old_params (name, value) ->
              match name with
              | name when is_global_param name ->
                 (fun x -> add name value (old_params x))
              | name when is_local_param name ->
                 let pieces = Pcre.extract ~pat:"^([^.]+)\\.(.*)" name in
                 let (key, name) = (pieces.(1), pieces.(2)) in
                  (function
                    | x when x = key -> add name value (old_params x)
                    | x -> old_params x)
              | _ -> assert false)
            user_params profile_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
        if debug then begin
          let tmp_xml, tmp_uri =
            let dir =
              Filename.dirname (Helm_registry.get "uwobo.log_basename")
            in
            dir ^ "/input.xml", dir ^ "/input.uri"
          in
          ignore (domImpl#saveDocumentToFile ~doc:input ~name:tmp_xml ());
          let oc = open_out tmp_uri in
          output_string oc xmluri;
          close_out oc
        end;
        syslogger#log `Debug "Applying stylesheet chain ...";
        (try
          let (write_result, media_type, encoding) = (* out_channel -> unit *)
            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 -> 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)...."
              content_type);
          Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
          Http_daemon.send_header "Content-Type" content_type outchan;
          Http_daemon.send_CRLF outchan;
          write_result outchan
        with Uwobo_failure errmsg ->
          return_error
            ("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 ->
        Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan);
    syslogger#log `Debug (sprintf "%s done!" req#path);
  with
  | Http_types.Param_not_found attr_name ->
      bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
  | exc ->
      return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
;;

  (* UWOBO's startup *)
let main () =
    (* (1) system logger *)
  let logger_outchan =
   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 ()
  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 "UWOBOmaster: killing pid %d" child);
          Unix.kill child Sys.sigterm;  (* kill child ... *)
          ignore (Unix.waitpid [] child);  (* ... and its zombie *)
        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 "UWOBOmaster: waiting for commands ...";
            let cmd = input_line cmd_pipe in
            debug_print (sprintf "UWOBOmaster: received %s command" cmd);
            (match cmd with  (* command from grandchild *)
            | "test" ->
                stop_http_daemon ();
                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 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] ->
                        logger#log (sprintf "adding binding <%s,%s>" key style);
                        veillogger#clearMsgs;
                        (try
                          veillogger#clearMsgs;
                          styles#add key style;
                          log_libxslt_msgs logger veillogger;
                        with e ->
                          logger#log (Printexc.to_string e))
                    | _ -> logger#log (sprintf "invalid binding %s" binding))
                  bindings;
                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
                  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
                  styles#reload (fun () -> styles#reloadAll) styles#keys
                  "reloading";
                output_string res_pipe (logger#asHtml);
                raise Restart_HTTP_daemon
	    | line when Pcre.pmatch ~rex:createprofile_cmd_RE line -> (* /createprofile *)
              stop_http_daemon ();
		begin
		  match (Pcre.split ~pat:"," (Pcre.replace ~rex:createprofile_cmd_RE line)) with
		      id::clone::clone_password::read_perm::write_perm::admin_perm::password::pv_list ->
			let bool_option_of_string_option =
			  function
			      Some "true" -> Some true
			    | Some _ -> Some false
			    | None -> None
			in
			let pid =
			  Uwobo_profiles.create
			    ?id:(string_option_of_string id)
			    ?clone:(string_option_of_string clone)
			    ?clone_password:(string_option_of_string clone_password)
			    ?read_perm:(bool_option_of_string_option (string_option_of_string read_perm))
			    ?write_perm:(bool_option_of_string_option (string_option_of_string write_perm))
			    ?admin_perm:(bool_option_of_string_option (string_option_of_string admin_perm))
			    ?password:(string_option_of_string password)
			    ()
			in
			let pv_list' = (deserialize_param_list pv_list) in
			  List.iter
			    (fun (key, value) ->
			       Uwobo_profiles.set_param
			       pid ?password:(string_option_of_string password) ~key ~value ())
			    pv_list' ;
			  save_configuration () ;
			  output_string res_pipe ("Profile " ^ pid ^ " created. Hi " ^ pid) ;
			  raise Restart_HTTP_daemon
		    | _ -> assert false
		end
	    | line when Pcre.pmatch ~rex:removeprofile_cmd_RE line -> (* /removeprofile *)
              stop_http_daemon ();
	      let pid, password =
		match Pcre.split ~pat:"," (Pcre.replace ~rex:removeprofile_cmd_RE line) with
		    [pid; password] -> pid, (string_option_of_string password)
		  | _ -> assert false
              in
		Uwobo_profiles.remove pid ?password () ;
		save_configuration () ;
		output_string res_pipe "Done" ;
		raise Restart_HTTP_daemon
	    | line when Pcre.pmatch ~rex:setparams_cmd_RE line -> (* /setparams *)
	      stop_http_daemon () ;
		let pid, password, pv_list =
		  match Pcre.split ~pat:"," (Pcre.replace ~rex:setparams_cmd_RE line) with
		      pid::password::pv_list ->
			pid, (string_option_of_string password), (deserialize_param_list pv_list)
		    | _ -> assert false
		in
		  List.iter
		    (fun (key, value) -> Uwobo_profiles.set_param pid ?password ~key ~value ())
		    pv_list ;
		  save_configuration () ;
		  output_string res_pipe "Done" ;
		  raise Restart_HTTP_daemon
	    | line when Pcre.pmatch ~rex:setprofileparam_cmd_RE line -> (* /setprofileparam *)
              stop_http_daemon ();
	      let pid, password, key, value =
		match Pcre.split ~pat:"," (Pcre.replace ~rex:setprofileparam_cmd_RE line) with
		    [pid; password; key; value] ->
		      pid, (string_option_of_string password), key, (string_option_of_string value)
		  | _ -> assert false
              in
		Uwobo_profiles.set_param pid ?password ~key ~value () ;
		save_configuration () ;
		output_string res_pipe "Done" ;
		raise Restart_HTTP_daemon
	    | line when Pcre.pmatch ~rex:setpassword_cmd_RE line -> (* /setpassword *)
              stop_http_daemon ();
	      let pid, old_password, password =
		match Pcre.split ~pat:"," (Pcre.replace ~rex:setpassword_cmd_RE line) with
		    [pid; old_password; password] ->
		      pid, (string_option_of_string old_password), (string_option_of_string password)
		  | _ -> assert false
              in
		Uwobo_profiles.set_password pid ?old_password password ;
		save_configuration () ;
		output_string res_pipe "Done" ;
		raise Restart_HTTP_daemon
	    | line when Pcre.pmatch ~rex:setpermission_cmd_RE line -> (* /setpermission *)
              stop_http_daemon ();
	      let permission_of_string =
		function
		    "read" -> `Read
		  | "write" -> `Write
		  | "admin" -> `Admin
		  | _ -> assert false
	      and bool_of_string s = "public" = s
	      in
	      let pid, password, forwhat, value =
		match Pcre.split ~pat:"," (Pcre.replace ~rex:setpermission_cmd_RE line) with
		    [pid; password; forwhat; value] ->
		      pid, (string_option_of_string password), (permission_of_string forwhat), (bool_of_string value)
		  | _ -> assert false
              in
		Uwobo_profiles.set_permission pid ?password forwhat value ;
		save_configuration () ;
		output_string res_pipe "Done" ;
		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
         | Sys.Break as exn -> raise exn
	 | e -> (* Should we return a 404 error here? Maybe... (how?) *)
	    output_string res_pipe (Printexc.to_string e);
            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 (sprintf "Starting HTTP daemon on port %d ..." port);
          (* next invocation doesn't return, process will keep on serving HTTP
          requests until it will get killed by father *)
        Http_daemon.start'~port ~mode:`Fork
          (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
    | _ (* < 0 *) ->  (* fork failed :-((( *)
        failwith "Can't fork :-("
  done
;;

  (* daemon initialization *)
try
  Sys.catch_break true;
  main ()
with Sys.Break -> ()  (* 'die_nice' registered with at_exit *)
;;