(* 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/.
*)
let debug = true;;
let debug_print s = if debug then prerr_endline s;;
Http_common.debug := debug;;
open Printf;;
let configuration_file = "/projects/helm/etc/uriSetQueue.conf.xml";;
let daemon_name = "Uri Set Queue";;
module OrderedUri: Set.OrderedType with type t = string =
struct
type t = string
let compare = compare
end
module UriSet = Set.Make (OrderedUri)
type uri_queue = {
mutable size: int;
mutable overflowed: bool;
uris: string Queue.t;
mutable olduris: UriSet.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 (); olduris = UriSet.empty
};;
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 (); olduris = UriSet.empty }),
(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 callback (req: Http_types.request) 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
debug_print (sprintf "Adding uri '%s' to queue '%d'" uri pid);
let queue = get_queue pid in
let result =
if (Queue.length queue.uris) + (UriSet.cardinal queue.olduris) >=
queue.size
then
begin (* overflow! *)
queue.overflowed <- true;
debug_print "Answer: not_added_because_already_too_many";
"not_added_because_already_too_many"
end else begin (* there's room for another uri *)
if (queue_mem uri queue.uris) || (UriSet.mem uri queue.olduris)
then
begin (* url already in *)
debug_print "Answer: already_in";
"already_in"
end else begin (* uri not in *)
Queue.add uri queue.uris;
debug_print "Answer: added";
"added"
end
end
in
res#setBody (sprintf "\n<%s/>\n" result);
if debug then res#serialize stderr;
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
debug_print (sprintf "%d queue is_overflowed = %s" pid result);
res#setBody (sprintf "\n<%s/>\n" result);
if debug then res#serialize stderr;
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
debug_print (sprintf "Setting size '%d' for queue '%d'" size pid);
(try
let queue = get_queue pid in
queue.size <- size;
with Queue_not_found p ->
assert (p = pid);
add_queue pid size);
res#setBody "\n\n";
if debug then res#serialize stderr;
Http_daemon.respond_with res outchan
| "/get_next" ->
let pid = int_of_string (req#param "PID") in
debug_print (sprintf "Getting next uri from queue '%d'" pid);
let queue = get_queue pid in
let element = (* xml response's root element *)
try
let uri = Queue.take queue.uris in
queue.olduris <- UriSet.add uri queue.olduris;
sprintf
"<%suri value=\"%s\"/>"
(if queue.overflowed then "marked_" else "")
uri
with Queue.Empty -> ""
in
res#setBody ("\n" ^ element ^ "\n");
if debug then res#serialize stderr;
Http_daemon.respond_with res outchan
| "/reset_to_empty" ->
let pid = int_of_string (req#param "PID") in
remove_queue pid;
debug_print (sprintf "Resetting queue '%d'" pid);
res#setBody "\n\n";
if debug then res#serialize stderr;
Http_daemon.respond_with res outchan
| invalid_request ->
debug_print ("Invalid request received");
Http_daemon.respond_error
~code:(`Status (`Client_error `Bad_request)) outchan);
prerr_endline "Request done!\n"
with
| Http_types.Param_not_found attr_name ->
Http_daemon.respond_error ~code:(`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
~code:(`Status (`Client_error `Bad_request)) outchan
| Queue_not_found queue_name ->
Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
~body:(sprintf "Queue '%d' is not defined" queue_name)
outchan
in
Helm_registry.load_from configuration_file;
let port = Helm_registry.get_int "uri_set_queue.port" in
printf "%s started and listening on port %d\n" daemon_name port;
flush stdout;
Http_daemon.start' ~port ~mode:`Thread callback;
printf "%s is terminating, bye!\n" daemon_name