+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Hbugs_misc;;
-open Hbugs_types;;
-open Printf;;
-
-exception Client_already_in of client_id;;
-exception Client_not_found of client_id;;
-exception Musing_already_in of musing_id;;
-exception Musing_not_found of musing_id;;
-exception Tutor_already_in of tutor_id;;
-exception Tutor_not_found of tutor_id;;
-
-class type registry =
- object
- method dump: string
- method purge: unit
- end
-
-let expire_time = 1800. (* 30 minutes *)
-
-class clients =
- object (self)
-
- inherit ThreadSafe.threadSafe
-(*
- (* <DEBUGGING> *)
- method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
- method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
- method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
- (* </DEBUGGING> *)
-*)
-
- val timetable: (client_id, float) Hashtbl.t = Hashtbl.create 17
- val urls: (client_id, string) Hashtbl.t = Hashtbl.create 17
- val subscriptions: (client_id, tutor_id list) Hashtbl.t = Hashtbl.create 17
-
- (** INVARIANT: each client registered has an entry in 'urls' hash table
- _and_ in 'subscriptions hash table even if it hasn't yet invoked
- 'subscribe' method *)
-
- method register id url = self#doWriter (lazy (
- if Hashtbl.mem urls id then
- raise (Client_already_in id)
- else begin
- Hashtbl.add urls id url;
- Hashtbl.add subscriptions id [];
- Hashtbl.add timetable id (Unix.time ())
- end
- ))
- method private remove id =
- Hashtbl.remove urls id;
- Hashtbl.remove subscriptions id;
- Hashtbl.remove timetable id
- method unregister id = self#doWriter (lazy (
- if Hashtbl.mem urls id then
- self#remove id
- else
- raise (Client_not_found id)
- ))
- method isAuthenticated id = self#doReader (lazy (
- Hashtbl.mem urls id
- ))
- method subscribe client_id tutor_ids = self#doWriter (lazy (
- if Hashtbl.mem urls client_id then
- Hashtbl.replace subscriptions client_id tutor_ids
- else
- raise (Client_not_found client_id)
- ))
- method getUrl id = self#doReader (lazy (
- if Hashtbl.mem urls id then
- Hashtbl.find urls id
- else
- raise (Client_not_found id)
- ))
- method getSubscription id = self#doReader (lazy (
- if Hashtbl.mem urls id then
- Hashtbl.find subscriptions id
- else
- raise (Client_not_found id)
- ))
-
- method dump = self#doReader (lazy (
- "<clients>\n" ^
- (Hashtbl.fold
- (fun id url dump ->
- (dump ^
- (sprintf "<client id=\"%s\" url=\"%s\">\n" id url) ^
- "<subscriptions>\n" ^
- (String.concat "\n" (* id's subscriptions *)
- (List.map
- (fun tutor_id -> sprintf "<tutor id=\"%s\" />\n" tutor_id)
- (Hashtbl.find subscriptions id))) ^
- "</subscriptions>\n</client>\n"))
- urls "") ^
- "</clients>"
- ))
- method purge = self#doWriter (lazy (
- let now = Unix.time () in
- Hashtbl.iter
- (fun id birthday ->
- if now -. birthday > expire_time then
- self#remove id)
- timetable
- ))
-
- end
-
-class tutors =
- object (self)
-
- inherit ThreadSafe.threadSafe
-(*
- (* <DEBUGGING> *)
- method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
- method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
- method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
- (* </DEBUGGING> *)
-*)
-
- val timetable: (tutor_id, float) Hashtbl.t = Hashtbl.create 17
- val tbl: (tutor_id, string * hint_type * string) Hashtbl.t =
- Hashtbl.create 17
-
- method register id url hint_type dsc = self#doWriter (lazy (
- if Hashtbl.mem tbl id then
- raise (Tutor_already_in id)
- else begin
- Hashtbl.add tbl id (url, hint_type, dsc);
- Hashtbl.add timetable id (Unix.time ())
- end
- ))
- method private remove id =
- Hashtbl.remove tbl id;
- Hashtbl.remove timetable id
- method unregister id = self#doWriter (lazy (
- if Hashtbl.mem tbl id then
- self#remove id
- else
- raise (Tutor_not_found id)
- ))
- method isAuthenticated id = self#doReader (lazy (
- Hashtbl.mem tbl id
- ))
- method exists id = self#doReader (lazy (
- Hashtbl.mem tbl id
- ))
- method getTutor id = self#doReader (lazy (
- if Hashtbl.mem tbl id then
- Hashtbl.find tbl id
- else
- raise (Tutor_not_found id)
- ))
- method getUrl id =
- let (url, _, _) = self#getTutor id in
- url
- method getHintType id =
- let (_, hint_type, _) = self#getTutor id in
- hint_type
- method getDescription id =
- let (_, _, dsc) = self#getTutor id in
- dsc
- method index = self#doReader (lazy (
- Hashtbl.fold
- (fun id (url, hint_type, dsc) idx -> (id, dsc) :: idx) tbl []
- ))
-
- method dump = self#doReader (lazy (
- "<tutors>\n" ^
- (Hashtbl.fold
- (fun id (url, hint_type, dsc) dump ->
- dump ^
- (sprintf
-"<tutor id=\"%s\" url=\"%s\">\n<hint_type>%s</hint_type>\n<description>%s</description>\n</tutor>"
- id url hint_type dsc))
- tbl "") ^
- "</tutors>"
- ))
- method purge = self#doWriter (lazy (
- let now = Unix.time () in
- Hashtbl.iter
- (fun id birthday ->
- if now -. birthday > expire_time then
- self#remove id)
- timetable
- ))
-
- end
-
-class musings =
- object (self)
-
- inherit ThreadSafe.threadSafe
-(*
- (* <DEBUGGING> *)
- method private doCritical: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
- method private doWriter: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
- method private doReader: 'a. 'a lazy_t -> 'a = fun act -> Lazy.force act
- (* </DEBUGGING> *)
-*)
-
- val timetable: (musing_id, float) Hashtbl.t = Hashtbl.create 17
- val musings: (musing_id, client_id * tutor_id) Hashtbl.t = Hashtbl.create 17
- val clients: (client_id, musing_id list) Hashtbl.t = Hashtbl.create 17
- val tutors: (tutor_id, musing_id list) Hashtbl.t = Hashtbl.create 17
-
- (** INVARIANT: each registered musing <musing_id, client_id, tutor_id> has
- an entry in 'musings' table, an entry in 'clients' (i.e. one of the
- musings for client_id is musing_id) table, an entry in 'tutors' table
- (i.e. one of the musings for tutor_id is musing_id) and an entry in
- 'timetable' table *)
-
-
- method register musing_id client_id tutor_id = self#doWriter (lazy (
- if Hashtbl.mem musings musing_id then
- raise (Musing_already_in musing_id)
- else begin
- Hashtbl.add musings musing_id (client_id, tutor_id);
- (* now add this musing as the first one of musings list for client and
- tutor *)
- Hashtbl.replace clients client_id
- (musing_id ::
- (try Hashtbl.find clients client_id with Not_found -> []));
- Hashtbl.replace tutors tutor_id
- (musing_id ::
- (try Hashtbl.find tutors tutor_id with Not_found -> []));
- Hashtbl.add timetable musing_id (Unix.time ())
- end
- ))
- method private remove id =
- (* ASSUMPTION: this method is invoked under a 'writer' lock *)
- let (client_id, tutor_id) = self#getByMusingId' id in
- Hashtbl.remove musings id;
- (* now remove this musing from the list of musings for client and tutor
- *)
- Hashtbl.replace clients client_id
- (List.filter ((<>) id)
- (try Hashtbl.find clients client_id with Not_found -> []));
- Hashtbl.replace tutors tutor_id
- (List.filter ((<>) id)
- (try Hashtbl.find tutors tutor_id with Not_found -> []));
- Hashtbl.remove timetable id
- method unregister id = self#doWriter (lazy (
- if Hashtbl.mem musings id then
- self#remove id
- ))
- method private getByMusingId' id =
- (* ASSUMPTION: this method is invoked under a 'reader' lock *)
- try
- Hashtbl.find musings id
- with Not_found -> raise (Musing_not_found id)
- method getByMusingId id = self#doReader (lazy (
- self#getByMusingId' id
- ))
- method getByClientId id = self#doReader (lazy (
- try
- Hashtbl.find clients id
- with Not_found -> []
- ))
- method getByTutorId id = self#doReader (lazy (
- try
- Hashtbl.find tutors id
- with Not_found -> []
- ))
- method isActive id = self#doReader (lazy (
- Hashtbl.mem musings id
- ))
-
- method dump = self#doReader (lazy (
- "<musings>\n" ^
- (Hashtbl.fold
- (fun mid (cid, tid) dump ->
- dump ^
- (sprintf "<musing id=\"%s\" client=\"%s\" tutor=\"%s\" />\n"
- mid cid tid))
- musings "") ^
- "</musings>"
- ))
- method purge = self#doWriter (lazy (
- let now = Unix.time () in
- Hashtbl.iter
- (fun id birthday ->
- if now -. birthday > expire_time then
- self#remove id)
- timetable
- ))
-
- end
-
projects / helm.git / blobdiff