helm/graphs/tools/uriSetQueue.ml

   1 (* Copyright (C) 2002, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 let debug = true;;
  27 let debug_print s = if debug then prerr_endline s;;
  28 Http_common.debug := debug;;
  29
  30 open Printf;;
  31
  32 let configuration_file = "/projects/helm/etc/uriSetQueue.conf.xml";;
  33 let daemon_name = "Uri Set Queue";;
  34
  35 module OrderedUri: Set.OrderedType with type t = string =
  36   struct
  37     type t = string
  38     let compare = compare
  39   end
  40 module UriSet = Set.Make (OrderedUri)
  41 type uri_queue = {
  42   mutable size: int;
  43   mutable overflowed: bool;
  44   uris: string Queue.t;
  45   mutable olduris: UriSet.t;
  46 }
  47   (** raised when a queue is accessed before being defined *)
  48 exception Queue_not_found of int;;
  49   (** global uri_queue, used by all children *)
  50 let uri_queue = {
  51   size = 0; overflowed = false; uris = Queue.create (); olduris = UriSet.empty
  52 };;
  53 let (get_queue, add_queue, remove_queue) =
  54   let uri_queues = Hashtbl.create 17 in
  55   ((fun pid -> (* get_queue *)
  56     try
  57       Hashtbl.find uri_queues pid
  58     with Not_found -> raise (Queue_not_found pid)),
  59   (fun pid size ->  (* add_queue *)
  60     Hashtbl.replace
  61       uri_queues
  62       pid
  63       { size = size; overflowed = false;
  64         uris = Queue.create (); olduris = UriSet.empty }),
  65   (fun pid -> (* remove_queue *)
  66     try
  67       Hashtbl.remove uri_queues pid
  68     with Not_found -> raise (Queue_not_found pid)))
  69 ;;
  70
  71 exception Found;;
  72 let queue_mem item queue =  (* mem function over queues *)
  73   try
  74     Queue.iter (fun e -> if item = e then raise Found) queue;
  75     false
  76   with Found -> true
  77 ;;
  78
  79 let callback (req: Http_types.request) outchan =
  80   try
  81     let res = new Http_response.response () in
  82     res#addBasicHeaders;
  83     res#setContentType "text/xml";
  84     (match req#path with
  85
  86     | "/add_if_not_in" ->
  87         let (uri, pid) = (req#param "uri", int_of_string (req#param "PID")) in
  88         debug_print (sprintf "Adding uri '%s' to queue '%d'" uri pid);
  89         let queue = get_queue pid in
  90         let result =
  91           if (Queue.length queue.uris) + (UriSet.cardinal queue.olduris) >=
  92              queue.size
  93           then
  94             begin (* overflow! *)
  95               queue.overflowed <- true;
  96               debug_print "Answer: not_added_because_already_too_many";
  97               "not_added_because_already_too_many"
  98             end else begin  (* there's room for another uri *)
  99               if (queue_mem uri queue.uris) || (UriSet.mem uri queue.olduris)
 100               then
 101                 begin (* url already in *)
 102                   debug_print "Answer: already_in";
 103                   "already_in"
 104                 end else begin (* uri not in *)
 105                   Queue.add uri queue.uris;
 106                   debug_print "Answer: added";
 107                   "added"
 108                 end
 109             end
 110         in
 111         res#setBody (sprintf "<?xml version=\"1.0\"?>\n<%s/>\n" result);
 112         if debug then res#serialize stderr;
 113         Http_daemon.respond_with res outchan
 114
 115     | "/is_overflowed" ->
 116         let pid = int_of_string (req#param "PID") in
 117         let queue = get_queue pid in
 118         let result = string_of_bool (queue.overflowed) in
 119         debug_print (sprintf "%d queue is_overflowed = %s" pid result);
 120         res#setBody (sprintf "<?xml version=\"1.0\"?>\n<%s/>\n" result);
 121         if debug then res#serialize stderr;
 122         Http_daemon.respond_with res outchan
 123
 124     | "/set_uri_set_size" ->
 125         let (pid, size) =
 126           (int_of_string (req#param "PID"), int_of_string (req#param "size"))
 127         in
 128         debug_print (sprintf "Setting size '%d' for queue '%d'" size pid);
 129         (try
 130           let queue = get_queue pid in
 131           queue.size <- size;
 132         with Queue_not_found p ->
 133           assert (p = pid);
 134           add_queue pid size);
 135         res#setBody "<?xml version=\"1.0\"?>\n<done/>\n";
 136         if debug then res#serialize stderr;
 137         Http_daemon.respond_with res outchan
 138
 139     | "/get_next" ->
 140         let pid = int_of_string (req#param "PID") in
 141         debug_print (sprintf "Getting next uri from queue '%d'" pid);
 142         let queue = get_queue pid in
 143         let element = (* xml response's root element *)
 144           try
 145             let uri = Queue.take queue.uris in
 146             queue.olduris <- UriSet.add uri queue.olduris;
 147             sprintf
 148               "<%suri value=\"%s\"/>"
 149               (if queue.overflowed then "marked_" else "")
 150               uri
 151           with Queue.Empty -> "<empty/>"
 152         in
 153         res#setBody ("<?xml version=\"1.0\"?>\n" ^ element ^ "\n");
 154         if debug then res#serialize stderr;
 155         Http_daemon.respond_with res outchan
 156
 157     | "/reset_to_empty" ->
 158         let pid = int_of_string (req#param "PID") in
 159         remove_queue pid;
 160         debug_print (sprintf "Resetting queue '%d'" pid);
 161         res#setBody "<?xml version=\"1.0\"?>\n<done/>\n";
 162         if debug then res#serialize stderr;
 163         Http_daemon.respond_with res outchan
 164
 165     | invalid_request ->
 166         debug_print ("Invalid request received");
 167         Http_daemon.respond_error
 168           ~code:(`Status (`Client_error `Bad_request)) outchan);
 169         prerr_endline "Request done!\n"
 170   with
 171   | Http_types.Param_not_found attr_name ->
 172       Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
 173         ~body:(sprintf "Parameter '%s' is missing" attr_name)
 174         outchan
 175   | Failure "int_of_string" ->  (* error in converting some paramters *)
 176       Http_daemon.respond_error
 177         ~code:(`Status (`Client_error `Bad_request)) outchan
 178   | Queue_not_found queue_name ->
 179       Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
 180         ~body:(sprintf "Queue '%d' is not defined" queue_name)
 181         outchan
 182 in
 183
 184 Helm_registry.load_from configuration_file;
 185 let port = Helm_registry.get_int "uri_set_queue.port" in
 186 printf "%s started and listening on port %d\n" daemon_name port;
 187 flush stdout;
 188 Http_daemon.start' ~port ~mode:`Thread callback;
 189 printf "%s is terminating, bye!\n" daemon_name
 190