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 open Printf;;
  27
  28 let daemon_name = "Uri Set Queue";;
  29 let default_port = 48082;;
  30 let port_env_var = "URI_SET_QUEUE_PORT";;
  31
  32 type uri_queue = {
  33   mutable size: int;
  34   mutable overflowed: bool;
  35   uris: string Queue.t;
  36 }
  37   (** raised when a queue is accessed before being defined *)
  38 exception Queue_not_found of int;;
  39   (** global uri_queue, used by all children *)
  40 let uri_queue = { size = 0; overflowed = false; uris = Queue.create () };;
  41 let (get_queue, add_queue, remove_queue) =
  42   let uri_queues = Hashtbl.create 17 in
  43   ((fun pid -> (* get_queue *)
  44     try
  45       Hashtbl.find uri_queues pid
  46     with Not_found -> raise (Queue_not_found pid)),
  47   (fun pid size ->  (* add_queue *)
  48     Hashtbl.replace
  49       uri_queues
  50       pid
  51       { size = size; overflowed = false; uris = Queue.create () }),
  52   (fun pid -> (* remove_queue *)
  53     try
  54       Hashtbl.remove uri_queues pid
  55     with Not_found -> raise (Queue_not_found pid)))
  56 ;;
  57
  58 exception Found;;
  59 let queue_mem item queue =  (* mem function over queues *)
  60   try
  61     Queue.iter (fun e -> if item = e then raise Found) queue;
  62     false
  63   with Found -> true
  64 ;;
  65
  66 let port =
  67   try
  68     int_of_string (Sys.getenv port_env_var)
  69   with
  70   | Not_found -> default_port
  71   | Failure "int_of_string" ->
  72       prerr_endline "Warning: invalid port, reverting to default";
  73       default_port
  74 in
  75 let callback req outchan =
  76   try
  77     let res = new Http_response.response in
  78     res#addBasicHeaders;
  79     res#setContentType "text/xml";
  80     (match req#path with
  81
  82     | "/add_if_not_in" ->
  83         let (uri, pid) = (req#param "uri", int_of_string (req#param "PID")) in
  84         let queue = get_queue pid in
  85         let result =
  86           if not (queue_mem uri queue.uris) then begin (* uri not in *)
  87             if Queue.length queue.uris >= queue.size then begin (* overflow! *)
  88               queue.overflowed <- true;
  89               "not_added_because_already_too_many"
  90             end else begin  (* add the uri *)
  91               Queue.add uri queue.uris;
  92               "added"
  93             end
  94           end else (* url already in *)
  95             "already_in"
  96         in
  97         res#setContents (sprintf "<?xml version=\"1.0\"?><%s/>\n" result);
  98         Http_daemon.respond_with res outchan
  99
 100     | "/is_overflowed" ->
 101         let pid = int_of_string (req#param "PID") in
 102         let queue = get_queue pid in
 103         let result = string_of_bool (queue.overflowed) in
 104         res#setContents (sprintf "<?xml version=\"1.0\"?><%s/>\n" result);
 105         Http_daemon.respond_with res outchan
 106
 107     | "/set_uri_set_size" ->
 108         let (pid, size) =
 109           (int_of_string (req#param "PID"), int_of_string (req#param "size"))
 110         in
 111         (try
 112           let queue = get_queue pid in
 113           queue.size <- size;
 114         with Queue_not_found p ->
 115           assert (p = pid);
 116           add_queue pid size);
 117         res#setContents "<?xml version=\"1.0\">\n<done/>\n";
 118         Http_daemon.respond_with res outchan
 119
 120     | "/get_next" ->
 121         let pid = int_of_string (req#param "PID") in
 122         let queue = get_queue pid in
 123         let element = (* xml response's root element *)
 124           try
 125             let uri = Queue.take queue.uris in
 126             sprintf
 127               "<%suri value=\"%s\"/>"
 128               (if queue.overflowed then "marked_" else "")
 129               uri
 130           with Queue.Empty -> "<empty/>"
 131         in
 132         res#setContents ("<?xml version=\"1.0\">" ^ element ^ "\n");
 133         Http_daemon.respond_with res outchan
 134
 135     | "/reset_to_empty" ->
 136         let pid = int_of_string (req#param "PID") in
 137         remove_queue pid;
 138         res#setContents "<?xml version=\"1.0\">\n<done/>\n";
 139         Http_daemon.respond_with res outchan
 140
 141     | invalid_request ->
 142         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
 143   with
 144   | Http_request.Param_not_found attr_name ->
 145       Http_daemon.respond_error
 146         ~status:(`Client_error `Bad_request)
 147         ~body:(sprintf "Parameter '%s' is missing" attr_name)
 148         outchan
 149   | Failure "int_of_string" ->  (* error in converting some paramters *)
 150       Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan
 151   | Queue_not_found queue_name ->
 152       Http_daemon.respond_error
 153         ~status:(`Client_error `Bad_request)
 154         ~body:(sprintf "Queue '%d' is not defined" queue_name)
 155         outchan
 156 in
 157
 158 printf "%s started and listening on port %d\n" daemon_name port;
 159 flush stdout;
 160 Http_daemon.start' ~port ~fork:false callback;
 161 printf "%s is terminating, bye!\n" daemon_name
 162