(* Copyright (C) 2002, HELM Team.
 * 
 * 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://cs.unibo.it/helm/.
 *)

open Printf;;

let daemon_name = "Uri Set Queue";;
let default_port = 48082;;
let port_env_var = "URI_SET_QUEUE_PORT";;

type uri_queue = {
  mutable size: int;
  mutable overflowed: bool;
  uris: string Queue.t;
}
  (** raised when a queue is accessed before being defined *)
exception Queue_not_found of int;;
  (** global uri_queue, used by all children *)
let uri_queue = { size = 0; overflowed = false; uris = Queue.create () };;
let (get_queue, add_queue, remove_queue) =
  let uri_queues = Hashtbl.create 17 in
  ((fun pid -> (* get_queue *)
    try
      Hashtbl.find uri_queues pid
    with Not_found -> raise (Queue_not_found pid)),
  (fun pid size ->  (* add_queue *)
    Hashtbl.replace
      uri_queues
      pid
      { size = size; overflowed = false; uris = Queue.create () }),
  (fun pid -> (* remove_queue *)
    try
      Hashtbl.remove uri_queues pid
    with Not_found -> raise (Queue_not_found pid)))
;;

exception Found;;
let queue_mem item queue =  (* mem function over queues *)
  try
    Queue.iter (fun e -> if item = e then raise Found) queue;
    false
  with Found -> true
;;

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
in
let callback req outchan =
  try
    let res = new Http_response.response in
    res#addBasicHeaders;
    res#setContentType "text/xml";
    (match req#path with

    | "/add_if_not_in" ->
        let (uri, pid) = (req#param "uri", int_of_string (req#param "PID")) in
        let queue = get_queue pid in
        let result =
          if not (queue_mem uri queue.uris) then begin (* uri not in *)
            if Queue.length queue.uris >= queue.size then begin (* overflow! *)
              queue.overflowed <- true;
              "not_added_because_already_too_many"
            end else begin  (* add the uri *)
              Queue.add uri queue.uris;
              "added"
            end
          end else (* url already in *)
            "already_in"
        in
        res#setContents (sprintf "<?xml version=\"1.0\"?><%s/>\n" result);
        Http_daemon.respond_with res outchan

    | "/is_overflowed" ->
        let pid = int_of_string (req#param "PID") in
        let queue = get_queue pid in
        let result = string_of_bool (queue.overflowed) in
        res#setContents (sprintf "<?xml version=\"1.0\"?><%s/>\n" result);
        Http_daemon.respond_with res outchan

    | "/set_uri_set_size" ->
        let (pid, size) =
          (int_of_string (req#param "PID"), int_of_string (req#param "size"))
        in
        (try
          let queue = get_queue pid in
          queue.size <- size;
        with Queue_not_found p ->
          assert (p = pid);
          add_queue pid size);
        res#setContents "<?xml version=\"1.0\">\n<done/>\n";
        Http_daemon.respond_with res outchan

    | "/get_next" ->
        let pid = int_of_string (req#param "PID") in
        let queue = get_queue pid in
        let element = (* xml response's root element *)
          try
            let uri = Queue.take queue.uris in
            sprintf
              "<%suri value=\"%s\"/>"
              (if queue.overflowed then "marked_" else "")
              uri
          with Queue.Empty -> "<empty/>"
        in
        res#setContents ("<?xml version=\"1.0\">" ^ element ^ "\n");
        Http_daemon.respond_with res outchan

    | "/reset_to_empty" ->
        let pid = int_of_string (req#param "PID") in
        remove_queue pid;
        res#setContents "<?xml version=\"1.0\">\n<done/>\n";
        Http_daemon.respond_with res outchan

    | invalid_request ->
        Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
  with
  | Http_request.Param_not_found attr_name ->
      Http_daemon.respond_error
        ~status:(`Client_error `Bad_request)
        ~body:(sprintf "Parameter '%s' is missing" attr_name)
        outchan
  | Failure "int_of_string" ->  (* error in converting some paramters *)
      Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan
  | Queue_not_found queue_name ->
      Http_daemon.respond_error
        ~status:(`Client_error `Bad_request)
        ~body:(sprintf "Queue '%d' is not defined" queue_name)
        outchan
in

printf "%s started and listening on port %d\n" daemon_name port;
flush stdout;
Http_daemon.start' ~port ~fork:false callback;
printf "%s is terminating, bye!\n" daemon_name