]> matita.cs.unibo.it Git - helm.git/blob - helm/software/components/hbugs/hbugs_broker_registry.ml
fast and sound registry lists
[helm.git] / helm / software / components / hbugs / hbugs_broker_registry.ml
1 (*
2  * Copyright (C) 2003:
3  *    Stefano Zacchiroli <zack@cs.unibo.it>
4  *    for the HELM Team http://helm.cs.unibo.it/
5  *
6  *  This file is part of HELM, an Hypertextual, Electronic
7  *  Library of Mathematics, developed at the Computer Science
8  *  Department, University of Bologna, Italy.
9  *
10  *  HELM is free software; you can redistribute it and/or
11  *  modify it under the terms of the GNU General Public License
12  *  as published by the Free Software Foundation; either version 2
13  *  of the License, or (at your option) any later version.
14  *
15  *  HELM is distributed in the hope that it will be useful,
16  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
17  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18  *  GNU General Public License for more details.
19  *
20  *  You should have received a copy of the GNU General Public License
21  *  along with HELM; if not, write to the Free Software
22  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
23  *  MA  02111-1307, USA.
24  *
25  *  For details, see the HELM World-Wide-Web page,
26  *  http://helm.cs.unibo.it/
27  *)
28
29 (* $Id$ *)
30
31 open Hbugs_misc;;
32 open Hbugs_types;;
33 open Printf;;
34
35 exception Client_already_in of client_id;;
36 exception Client_not_found of client_id;;
37 exception Musing_already_in of musing_id;;
38 exception Musing_not_found of musing_id;;
39 exception Tutor_already_in of tutor_id;;
40 exception Tutor_not_found of tutor_id;;
41
42 class type registry =
43   object
44     method dump: string
45     method purge: unit
46   end
47
48 let expire_time = 1800. (* 30 minutes *)
49
50 class clients =
51   object (self)
52
53     inherit ThreadSafe.threadSafe
54 (*
55     (* <DEBUGGING> *)
56     method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
57     method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
58     method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
59     (* </DEBUGGING> *)
60 *)
61
62     val timetable: (client_id, float) Hashtbl.t = Hashtbl.create 17
63     val urls: (client_id, string) Hashtbl.t = Hashtbl.create 17
64     val subscriptions: (client_id, tutor_id list) Hashtbl.t = Hashtbl.create 17
65
66       (** INVARIANT: each client registered has an entry in 'urls' hash table
67       _and_ in 'subscriptions hash table even if it hasn't yet invoked
68       'subscribe' method *)
69
70     method register id url = self#doWriter (lazy (
71       if Hashtbl.mem urls id then
72         raise (Client_already_in id)
73       else begin
74         Hashtbl.add urls id url;
75         Hashtbl.add subscriptions id [];
76         Hashtbl.add timetable id (Unix.time ())
77       end
78     ))
79     method private remove id =
80       Hashtbl.remove urls id;
81       Hashtbl.remove subscriptions id;
82       Hashtbl.remove timetable id
83     method unregister id = self#doWriter (lazy (
84       if Hashtbl.mem urls id then
85         self#remove id
86       else
87         raise (Client_not_found id)
88     ))
89     method isAuthenticated id = self#doReader (lazy (
90       Hashtbl.mem urls id
91     ))
92     method subscribe client_id tutor_ids = self#doWriter (lazy (
93       if Hashtbl.mem urls client_id then
94         Hashtbl.replace subscriptions client_id tutor_ids
95       else
96         raise (Client_not_found client_id)
97     ))
98     method getUrl id = self#doReader (lazy (
99       if Hashtbl.mem urls id then
100         Hashtbl.find urls id
101       else
102         raise (Client_not_found id)
103     ))
104     method getSubscription id = self#doReader (lazy (
105       if Hashtbl.mem urls id then
106         Hashtbl.find subscriptions id
107       else
108         raise (Client_not_found id)
109     ))
110
111     method dump = self#doReader (lazy (
112       "<clients>\n" ^
113       (Hashtbl.fold
114         (fun id url dump ->
115           (dump ^
116           (sprintf "<client id=\"%s\" url=\"%s\">\n" id url) ^
117           "<subscriptions>\n" ^
118           (String.concat "\n" (* id's subscriptions *)
119             (List.map
120               (fun tutor_id -> sprintf "<tutor id=\"%s\" />\n" tutor_id)
121               (Hashtbl.find subscriptions id))) ^
122           "</subscriptions>\n</client>\n"))
123         urls "") ^
124       "</clients>"
125     ))
126     method purge = self#doWriter (lazy (
127       let now = Unix.time () in
128       Hashtbl.iter
129         (fun id birthday ->
130           if now -. birthday > expire_time then
131             self#remove id)
132         timetable
133     ))
134
135   end
136
137 class tutors =
138   object (self)
139
140     inherit ThreadSafe.threadSafe
141 (*
142     (* <DEBUGGING> *)
143     method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
144     method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
145     method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
146     (* </DEBUGGING> *)
147 *)
148
149     val timetable: (tutor_id, float) Hashtbl.t = Hashtbl.create 17
150     val tbl: (tutor_id, string * hint_type * string) Hashtbl.t =
151       Hashtbl.create 17
152
153     method register id url hint_type dsc = self#doWriter (lazy (
154       if Hashtbl.mem tbl id then
155         raise (Tutor_already_in id)
156       else begin
157         Hashtbl.add tbl id (url, hint_type, dsc);
158         Hashtbl.add timetable id (Unix.time ())
159       end
160     ))
161     method private remove id =
162       Hashtbl.remove tbl id;
163       Hashtbl.remove timetable id
164     method unregister id = self#doWriter (lazy (
165       if Hashtbl.mem tbl id then
166         self#remove id
167       else
168         raise (Tutor_not_found id)
169     ))
170     method isAuthenticated id = self#doReader (lazy (
171       Hashtbl.mem tbl id
172     ))
173     method exists id = self#doReader (lazy (
174       Hashtbl.mem tbl id
175     ))
176     method getTutor id = self#doReader (lazy (
177       if Hashtbl.mem tbl id then
178         Hashtbl.find tbl id
179       else
180         raise (Tutor_not_found id)
181     ))
182     method getUrl id =
183       let (url, _, _) = self#getTutor id in
184       url
185     method getHintType id =
186       let (_, hint_type, _) = self#getTutor id in
187       hint_type
188     method getDescription id =
189       let (_, _, dsc) = self#getTutor id in
190       dsc
191     method index = self#doReader (lazy (
192       Hashtbl.fold
193         (fun id (url, hint_type, dsc) idx -> (id, dsc) :: idx) tbl []
194     ))
195
196     method dump = self#doReader (lazy (
197       "<tutors>\n" ^
198       (Hashtbl.fold
199         (fun id (url, hint_type, dsc) dump ->
200           dump ^
201           (sprintf
202 "<tutor id=\"%s\" url=\"%s\">\n<hint_type>%s</hint_type>\n<description>%s</description>\n</tutor>"
203             id url hint_type dsc))
204         tbl "") ^
205       "</tutors>"
206     ))
207     method purge = self#doWriter (lazy (
208       let now = Unix.time () in
209       Hashtbl.iter
210         (fun id birthday ->
211           if now -. birthday > expire_time then
212             self#remove id)
213         timetable
214     ))
215
216   end
217
218 class musings =
219   object (self)
220
221     inherit ThreadSafe.threadSafe
222 (*
223     (* <DEBUGGING> *)
224     method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
225     method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
226     method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
227     (* </DEBUGGING> *)
228 *)
229
230     val timetable: (musing_id, float) Hashtbl.t = Hashtbl.create 17
231     val musings: (musing_id, client_id * tutor_id) Hashtbl.t = Hashtbl.create 17
232     val clients: (client_id, musing_id list) Hashtbl.t = Hashtbl.create 17
233     val tutors: (tutor_id, musing_id list) Hashtbl.t = Hashtbl.create 17
234
235       (** INVARIANT: each registered musing <musing_id, client_id, tutor_id> has
236       an entry in 'musings' table, an entry in 'clients' (i.e. one of the
237       musings for client_id is musing_id) table, an entry in 'tutors' table
238       (i.e. one of the musings for tutor_id is musing_id) and an entry in
239       'timetable' table *)
240
241
242     method register musing_id client_id tutor_id = self#doWriter (lazy (
243       if Hashtbl.mem musings musing_id then
244         raise (Musing_already_in musing_id)
245       else begin
246         Hashtbl.add musings musing_id (client_id, tutor_id);
247           (* now add this musing as the first one of musings list for client and
248           tutor *)
249         Hashtbl.replace clients client_id
250           (musing_id ::
251             (try Hashtbl.find clients client_id with Not_found -> []));
252         Hashtbl.replace tutors tutor_id
253           (musing_id ::
254             (try Hashtbl.find tutors tutor_id with Not_found -> []));
255         Hashtbl.add timetable musing_id (Unix.time ())
256       end
257     ))
258     method private remove id =
259         (* ASSUMPTION: this method is invoked under a 'writer' lock *)
260       let (client_id, tutor_id) = self#getByMusingId' id in
261       Hashtbl.remove musings id;
262         (* now remove this musing from the list of musings for client and tutor
263         *)
264       Hashtbl.replace clients client_id
265         (List.filter ((<>) id)
266           (try Hashtbl.find clients client_id with Not_found -> []));
267       Hashtbl.replace tutors tutor_id
268         (List.filter ((<>) id)
269           (try Hashtbl.find tutors tutor_id with Not_found -> []));
270       Hashtbl.remove timetable id
271     method unregister id = self#doWriter (lazy (
272       if Hashtbl.mem musings id then
273         self#remove id
274     ))
275     method private getByMusingId' id =
276       (* ASSUMPTION: this method is invoked under a 'reader' lock *)
277       try
278         Hashtbl.find musings id
279       with Not_found -> raise (Musing_not_found id)
280     method getByMusingId id = self#doReader (lazy (
281       self#getByMusingId' id
282     ))
283     method getByClientId id = self#doReader (lazy (
284       try
285         Hashtbl.find clients id
286       with Not_found -> []
287     ))
288     method getByTutorId id = self#doReader (lazy (
289       try
290         Hashtbl.find tutors id
291       with Not_found -> []
292     ))
293     method isActive id = self#doReader (lazy (
294       Hashtbl.mem musings id
295     ))
296
297     method dump = self#doReader (lazy (
298       "<musings>\n" ^
299       (Hashtbl.fold
300         (fun mid (cid, tid) dump ->
301           dump ^
302           (sprintf "<musing id=\"%s\" client=\"%s\" tutor=\"%s\" />\n"
303             mid cid tid))
304         musings "") ^
305       "</musings>"
306     ))
307     method purge = self#doWriter (lazy (
308       let now = Unix.time () in
309       Hashtbl.iter
310         (fun id birthday ->
311           if now -. birthday > expire_time then
312             self#remove id)
313         timetable
314     ))
315
316   end
317