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