+++ /dev/null
-(* 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 daemon_name = "Uri Set Queue";;
-let default_port = 48082;;
-let port_env_var = "URI_SET_QUEUE_PORT";;
-
-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 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
- 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#setContents (sprintf "<?xml version=\"1.0\"?>\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#setContents (sprintf "<?xml version=\"1.0\"?>\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#setContents "<?xml version=\"1.0\"?>\n<done/>\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 -> "<empty/>"
- in
- res#setContents ("<?xml version=\"1.0\"?>\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#setContents "<?xml version=\"1.0\"?>\n<done/>\n";
- if debug then res#serialize stderr;
- Http_daemon.respond_with res outchan
-
- | invalid_request ->
- debug_print ("Invalid request received");
- Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
- prerr_endline "Request done!\n"
- 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
-
projects / helm.git / blobdiff