helm/hbugs/broker/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 open Hbugs_misc;;
  30 open Hbugs_types;;
  31 open Printf;;
  32
  33 exception Client_already_in of client_id;;
  34 exception Client_not_found of client_id;;
  35 exception Musing_already_in of musing_id;;
  36 exception Musing_not_found of musing_id;;
  37 exception Tutor_already_in of tutor_id;;
  38 exception Tutor_not_found of tutor_id;;
  39
  40 class type registry =
  41   object
  42     method dump: string
  43     method purge: unit
  44   end
  45
  46 let expire_time = 1800. (* 30 minutes *)
  47
  48 class clients =
  49   object (self)
  50
  51     inherit ThreadSafe.threadSafe
  52
  53     val timetable: (client_id, float) Hashtbl.t = Hashtbl.create 17
  54     val urls: (client_id, string) Hashtbl.t = Hashtbl.create 17
  55     val subscriptions: (client_id, tutor_id list) Hashtbl.t = Hashtbl.create 17
  56
  57       (** INVARIANT: each client registered has an entry in 'urls' hash table
  58       _and_ in 'subscriptions hash table even if it hasn't yet invoked
  59       'subscribe' method *)
  60
  61     method register id url = self#doWriter (lazy (
  62       if Hashtbl.mem urls id then
  63         raise (Client_already_in id)
  64       else begin
  65         Hashtbl.add urls id url;
  66         Hashtbl.add subscriptions id [];
  67         Hashtbl.add timetable id (Unix.time ())
  68       end
  69     ))
  70     method private remove id =
  71       Hashtbl.remove urls id;
  72       Hashtbl.remove subscriptions id;
  73       Hashtbl.remove timetable id
  74     method unregister id = self#doWriter (lazy (
  75       if Hashtbl.mem urls id then
  76         self#remove id
  77       else
  78         raise (Client_not_found id)
  79     ))
  80     method isAuthenticated id = self#doReader (lazy (
  81       Hashtbl.mem urls id
  82     ))
  83     method subscribe client_id tutor_ids = self#doWriter (lazy (
  84       if Hashtbl.mem urls client_id then
  85         Hashtbl.replace subscriptions client_id tutor_ids
  86       else
  87         raise (Client_not_found client_id)
  88     ))
  89     method getUrl id = self#doReader (lazy (
  90       if Hashtbl.mem urls id then
  91         Hashtbl.find urls id
  92       else
  93         raise (Client_not_found id)
  94     ))
  95     method getSubscription id = self#doReader (lazy (
  96       if Hashtbl.mem urls id then
  97         Hashtbl.find subscriptions id
  98       else
  99         raise (Client_not_found id)
 100     ))
 101
 102     method dump = self#doReader (lazy (
 103       "<clients>\n" ^
 104       (Hashtbl.fold
 105         (fun id url dump ->
 106           (dump ^
 107           (sprintf "<client id=\"%s\" url=\"%s\">\n" id url) ^
 108           "<subscriptions>\n" ^
 109           (String.concat "\n" (* id's subscriptions *)
 110             (List.map
 111               (fun tutor_id -> sprintf "<tutor id=\"%s\" />\n" tutor_id)
 112               (Hashtbl.find subscriptions id))) ^
 113           "</subscriptions>\n</client>\n"))
 114         urls "") ^
 115       "</clients>"
 116     ))
 117     method purge = self#doWriter (lazy (
 118       let now = Unix.time () in
 119       Hashtbl.iter
 120         (fun id birthday ->
 121           if now -. birthday > expire_time then
 122             self#remove id)
 123         timetable
 124     ))
 125
 126   end
 127
 128 class tutors =
 129   object (self)
 130
 131     inherit ThreadSafe.threadSafe
 132
 133     val timetable: (tutor_id, float) Hashtbl.t = Hashtbl.create 17
 134     val tbl: (tutor_id, string * hint_type * string) Hashtbl.t =
 135       Hashtbl.create 17
 136
 137     method register id url hint_type dsc = self#doWriter (lazy (
 138       if Hashtbl.mem tbl id then
 139         raise (Tutor_already_in id)
 140       else begin
 141         Hashtbl.add tbl id (url, hint_type, dsc);
 142         Hashtbl.add timetable id (Unix.time ())
 143       end
 144     ))
 145     method private remove id =
 146       Hashtbl.remove tbl id;
 147       Hashtbl.remove timetable id
 148     method unregister id = self#doWriter (lazy (
 149       if Hashtbl.mem tbl id then
 150         self#remove id
 151       else
 152         raise (Tutor_not_found id)
 153     ))
 154     method isAuthenticated id = self#doReader (lazy (
 155       Hashtbl.mem tbl id
 156     ))
 157     method exists id = self#doReader (lazy (
 158       Hashtbl.mem tbl id
 159     ))
 160     method getTutor id = self#doReader (lazy (
 161       if Hashtbl.mem tbl id then
 162         Hashtbl.find tbl id
 163       else
 164         raise (Tutor_not_found id)
 165     ))
 166     method getUrl id =
 167       let (url, _, _) = self#getTutor id in
 168       url
 169     method getHintType id =
 170       let (_, hint_type, _) = self#getTutor id in
 171       hint_type
 172     method getDescription id =
 173       let (_, _, dsc) = self#getTutor id in
 174       dsc
 175     method index = self#doReader (lazy (
 176       Hashtbl.fold
 177         (fun id (url, hint_type, dsc) idx -> (id, dsc) :: idx) tbl []
 178     ))
 179
 180     method dump = self#doReader (lazy (
 181       "<tutors>\n" ^
 182       (Hashtbl.fold
 183         (fun id (url, hint_type, dsc) dump ->
 184           dump ^
 185           (sprintf
 186 "<tutor id=\"%s\" url=\"%s\">\n<hint_type>%s</hint_type>\n<description>%s</description>\n</tutor>"
 187             id url hint_type dsc))
 188         tbl "") ^
 189       "</tutors>"
 190     ))
 191     method purge = self#doWriter (lazy (
 192       let now = Unix.time () in
 193       Hashtbl.iter
 194         (fun id birthday ->
 195           if now -. birthday > expire_time then
 196             self#remove id)
 197         timetable
 198     ))
 199
 200   end
 201
 202 class musings =
 203   object (self)
 204
 205     inherit ThreadSafe.threadSafe
 206
 207     val timetable: (musing_id, float) Hashtbl.t = Hashtbl.create 17
 208     val musings: (musing_id, client_id * tutor_id) Hashtbl.t = Hashtbl.create 17
 209     val clients: (client_id, musing_id) Hashtbl.t = Hashtbl.create 17
 210     val tutors: (tutor_id, musing_id) Hashtbl.t = Hashtbl.create 17
 211
 212       (** INVARIANT: each registered musing <musing_id, client_id, tutor_id> has
 213       an entry in 'musings' table, an entry in 'clients' table and an entry in
 214       'tutors' table *)
 215
 216     method register musing_id client_id tutor_id = self#doWriter (lazy (
 217       if Hashtbl.mem musings musing_id then
 218         raise (Musing_already_in musing_id)
 219       else begin
 220         Hashtbl.add musings musing_id (client_id, tutor_id);
 221         Hashtbl.add clients client_id musing_id;
 222         Hashtbl.add tutors tutor_id musing_id;
 223         Hashtbl.add timetable musing_id (Unix.time ())
 224       end
 225     ))
 226     method private remove id =
 227       Hashtbl.remove musings id;
 228       hashtbl_remove_all clients id;
 229       hashtbl_remove_all tutors id;
 230       Hashtbl.remove timetable id
 231     method unregister id = self#doWriter (lazy (
 232       if Hashtbl.mem musings id then
 233         self#remove id
 234     ))
 235     method getByMusingId id = self#doReader (lazy (
 236       try
 237         Hashtbl.find musings id
 238       with Not_found -> raise (Musing_not_found id)
 239     ))
 240     method getByClientId id = self#doReader (lazy (
 241       Hashtbl.find_all clients id
 242     ))
 243     method getByTutorId id = self#doReader (lazy (
 244       Hashtbl.find_all tutors id
 245     ))
 246
 247     method dump = self#doReader (lazy (
 248       "<musings>\n" ^
 249       (Hashtbl.fold
 250         (fun mid (cid, tid) dump ->
 251           dump ^
 252           (sprintf "<musing id=\"%s\" client=\"%s\" tutor=\"%s\" />\n"
 253             mid cid tid))
 254         musings "") ^
 255       "</musings>"
 256     ))
 257     method purge = self#doWriter (lazy (
 258       let now = Unix.time () in
 259       Hashtbl.iter
 260         (fun id birthday ->
 261           if now -. birthday > expire_time then
 262             self#remove id)
 263         timetable
 264     ))
 265
 266   end
 267