]> matita.cs.unibo.it Git - helm.git/blob - helm/graphs/tools/uriSetQueue.ml
correct name entry {Sacerdoti Coen} in bibtex
[helm.git] / 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