(*
 * 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 logfile = Some "uwobo.log";;  (* relative to execution dir *)
let logfile_perm = 0o640;;

  (* other settings *)
let daemon_name = "UWOBO OCaml";;
let default_port = 58080;;
let port_env_var = "UWOBO_PORT";;
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, reverting to default";
      default_port;;

  (** 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 outchan per_key_action all_keys_action logmsg
=
  let log = new Uwobo_logger.processingLogger () in
  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 *)
      log#log "reloading all stylesheets ...";
      (try all_keys_action () with e -> log#log (Printexc.to_string e))
  | keys ->
      List.iter
        (fun key -> (* act on a single stylesheet *)
          log#log (sprintf "%s stylesheet %s" logmsg key);
          (try per_key_action key with e -> log#log (Printexc.to_string e)))
        keys);
  output_string outchan log#asHtml;
  flush outchan
;;

  (** 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 *)
;;

  (** 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:200 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) =
  (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ")
;;

exception Restart_HTTP_daemon;;

  (* reuquest 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)
    | "/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 log = new Uwobo_logger.processingLogger () in
        log#log "Stylesheet list:";
        List.iter (fun s -> log#log s) styles#list;
        Http_daemon.respond ~body:log#asHtml outchan)
    | "/apply" ->
        let logger = new Uwobo_logger.processingLogger () 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 (params, props) = parse_apply_params req#params in
        syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
        let domImpl = Gdome.domImplementation () in
        let input = domImpl#createDocumentFromURI ~uri:xmluri () in
        syslogger#log `Debug "Applying stylesheet chain ...";
        (try
          let (write_result, media_type, encoding) = (* out_channel -> unit *)
            let res = Uwobo_engine.apply
              ~logger:syslogger ~styles ~keys ~input ~params ~props in
            res
          in
          let content_type = (* value of Content-Type HTTP response header *)
            sprintf "%s; charset=%s"
              (match media_type with None -> default_media_type | Some t -> t)
              (match encoding with None -> default_encoding | Some e -> e)
          in
          syslogger#log `Debug
            (sprintf "sending output to client (Content-Type: %s)...."
              content_type);
          Http_daemon.send_basic_headers ~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
            (sprintf "Stylesheet chain application failed: %s" errmsg)
            outchan)
    | "/help" -> Http_daemon.respond ~body:usage_string outchan
    | invalid_request ->
        Http_daemon.respond_error ~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
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 ...";
          (* 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
in

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