]> matita.cs.unibo.it Git - helm.git/blob - helm/ocaml/hbugs/broker.ml
New argument (the identifier) to generalize.
[helm.git] / helm / ocaml / hbugs / broker.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_types;;
30 open Printf;;
31
32 let debug = true ;;
33 let debug_print s = if debug then prerr_endline s ;;
34
35 let daemon_name = "H-Bugs Broker" ;;
36 let default_port = 49081 ;;
37 let port_env_var = "HELM_HBUGS_BROKER_PORT" ;;
38 let port =
39   try
40     int_of_string (Sys.getenv port_env_var)
41   with
42   | Not_found -> default_port
43   | Failure "int_of_string" ->
44       prerr_endline "Warning: invalid port, reverting to default";
45       default_port
46 ;;
47 let usage_string = "HBugs Broker: usage string not yet written :-(";;
48
49 exception Unexpected_msg of message;;
50
51 let return_xml_msg body outchan =
52   Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan
53 ;;
54 let parse_musing_id = function
55   | Musing_started (_, musing_id) ->
56         prerr_endline ("#### Started musing ID: " ^ musing_id);
57         musing_id
58   | Musing_aborted (_, musing_id) -> musing_id
59   | msg ->
60       prerr_endline (sprintf "Assertion failed, received msg: %s"
61         (Hbugs_messages.string_of_msg msg));
62       assert false
63 ;;
64
65 let do_critical =
66   let mutex = Mutex.create () in
67   fun action ->
68     try
69 (*       debug_print "Acquiring lock ..."; *)
70       Mutex.lock mutex;
71 (*       debug_print "Lock Acquired!"; *)
72       let res = Lazy.force action in
73 (*       debug_print "Releaseing lock ..."; *)
74       Mutex.unlock mutex;
75 (*       debug_print "Lock released!"; *)
76       res
77     with e -> Mutex.unlock mutex; raise e
78 ;;
79
80   (* registries *)
81 let clients = new Hbugs_broker_registry.clients in
82 let tutors = new Hbugs_broker_registry.tutors in
83 let musings = new Hbugs_broker_registry.musings in
84 let registries =
85   [ (clients :> Hbugs_broker_registry.registry);
86     (tutors :> Hbugs_broker_registry.registry);
87     (musings :> Hbugs_broker_registry.registry) ]
88 in
89
90 let my_own_id = Hbugs_id_generator.new_broker_id () in
91
92   (* debugging: dump broker internal status, used by '/dump' method *)
93 let dump_registries () =
94   assert debug;
95   String.concat "\n" (List.map (fun o -> o#dump) registries)
96 in
97
98 let handle_msg outchan msg =
99   (* messages from clients *)
100   (match msg with
101
102   | Help ->
103       Hbugs_messages.respond_msg (Usage usage_string) outchan
104   | Register_client (client_id, client_url) -> do_critical (lazy (
105       try
106         clients#register client_id client_url;
107         Hbugs_messages.respond_msg (Client_registered my_own_id) outchan
108       with Hbugs_broker_registry.Client_already_in id ->
109         Hbugs_messages.respond_exc "already_registered" id outchan
110     ))
111   | Unregister_client client_id -> do_critical (lazy (
112       if clients#isAuthenticated client_id then begin
113         clients#unregister client_id;
114         Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan
115       end else
116         Hbugs_messages.respond_exc "forbidden" client_id outchan
117     ))
118   | List_tutors client_id -> do_critical (lazy (
119       if clients#isAuthenticated client_id then begin
120         Hbugs_messages.respond_msg
121           (Tutor_list (my_own_id, tutors#index))
122           outchan
123       end else
124         Hbugs_messages.respond_exc "forbidden" client_id outchan
125     ))
126   | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
127       if clients#isAuthenticated client_id then begin
128         if List.length tutor_ids <> 0 then begin  (* at least one tutor id *)
129           if List.for_all tutors#exists tutor_ids then begin
130             clients#subscribe client_id tutor_ids;
131             Hbugs_messages.respond_msg
132               (Subscribed (my_own_id, tutor_ids)) outchan
133           end else  (* required subscription to at least one unexistent tutor *)
134             let missing_tutors =
135               List.filter (fun id -> not (tutors#exists id)) tutor_ids
136             in
137             Hbugs_messages.respond_exc
138               "tutor_not_found" (String.concat " " missing_tutors) outchan
139         end else  (* no tutor id specified *)
140           Hbugs_messages.respond_exc "no_tutor_specified" "" outchan
141       end else
142         Hbugs_messages.respond_exc "forbidden" client_id outchan
143     ))
144   | State_change (client_id, new_state) -> do_critical (lazy (
145       if clients#isAuthenticated client_id then begin
146         let active_musings = musings#getByClientId client_id in
147         prerr_endline (sprintf "ACTIVE MUSINGS: %s" (String.concat ", " active_musings));
148         if List.length active_musings = 0 then
149           prerr_endline ("No active musings for client " ^ client_id);
150         prerr_endline "CSC: State change!!!" ;
151         let stop_answers =
152           List.map  (* collect Abort_musing message's responses *)
153             (fun id ->  (* musing id *)
154               let tutor = snd (musings#getByMusingId id) in
155               Hbugs_messages.submit_req
156                 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
157             active_musings
158         in
159                                 let stopped_musing_ids = List.map parse_musing_id stop_answers in
160         List.iter musings#unregister active_musings;
161                                 (match new_state with
162                                 | Some new_state ->     (* need to start new musings *)
163                                         let subscriptions = clients#getSubscription client_id in
164                                         if List.length subscriptions = 0 then
165                                                 prerr_endline ("No subscriptions for client " ^ client_id);
166                                         let started_musing_ids =
167                                                 List.map  (* register new musings and collect their ids *)
168                                                         (fun tutor_id ->
169                                                                 let res =
170                                                                         Hbugs_messages.submit_req
171                                                                                 ~url:(tutors#getUrl tutor_id)
172                                                                                 (Start_musing (my_own_id, new_state))
173                                                                 in
174                                                                 let musing_id = parse_musing_id res in
175                                                                 musings#register musing_id client_id tutor_id;
176                                                                 musing_id)
177                                                         subscriptions
178                                         in
179                                         Hbugs_messages.respond_msg
180                                                 (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
181                                                 outchan
182                                 | None ->       (* no need to start new musings *)
183                                                 Hbugs_messages.respond_msg
184                                                         (State_accepted (my_own_id, stopped_musing_ids, []))
185                                                         outchan)
186       end else
187         Hbugs_messages.respond_exc "forbidden" client_id outchan
188     ))
189
190   (* messages from tutors *)
191
192   | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
193       try
194         tutors#register tutor_id tutor_url hint_type dsc;
195         Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan
196       with Hbugs_broker_registry.Tutor_already_in id ->
197         Hbugs_messages.respond_exc "already_registered" id outchan
198     ))
199   | Unregister_tutor tutor_id -> do_critical (lazy (
200       if tutors#isAuthenticated tutor_id then begin
201         tutors#unregister tutor_id;
202         Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan
203       end else
204         Hbugs_messages.respond_exc "forbidden" tutor_id outchan
205     ))
206
207   | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
208       if not (tutors#isAuthenticated tutor_id) then begin (* unauthorized *)
209         Hbugs_messages.respond_exc "forbidden" tutor_id outchan;
210       end else if not (musings#isActive musing_id) then begin (* too late *)
211         Hbugs_messages.respond_msg (Too_late (my_own_id, musing_id)) outchan;
212       end else begin  (* all is ok: autorhized and on time *)
213         (match result with
214         | Sorry -> ()
215         | Eureka hint ->
216             let client_url =
217               clients#getUrl (fst (musings#getByMusingId musing_id))
218             in
219             let res =
220               Hbugs_messages.submit_req ~url:client_url (Hint (my_own_id, hint))
221             in
222             (match res with
223             | Wow _ -> () (* ok: client is happy with our hint *)
224             | unexpected_msg ->
225                 prerr_endline
226                   (sprintf
227                     "Warning: unexpected msg from client: %s\nExpected was: Wow"
228                     (Hbugs_messages.string_of_msg msg))));
229         Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan;
230         musings#unregister musing_id
231       end
232     ))
233
234   | msg ->  (* unexpected message *)
235       debug_print "Unknown message!";
236       Hbugs_messages.respond_exc
237         "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
238 in
239 (*  (* DEBUGGING wrapper around 'handle_msg' *)
240 let handle_msg outchan =
241   if debug then
242     (fun msg -> (* filter handle_msg through a function which dumps input
243                 messages *)
244       debug_print (Hbugs_messages.string_of_msg msg);
245       handle_msg outchan msg)
246   else
247     handle_msg outchan
248 in
249 *)
250
251   (* thread action *)
252 let callback (req: Http_types.request) outchan =
253   try
254     debug_print ("Connection from " ^ req#clientAddr);
255     debug_print ("Received request: " ^ req#path);
256     (match req#path with
257       (* TODO write help message *)
258     | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
259     | "/act" ->
260         let msg = Hbugs_messages.msg_of_string req#body in
261         handle_msg outchan msg
262     | "/dump" ->
263         if debug then
264           Http_daemon.respond ~body:(dump_registries ()) outchan
265         else
266           Http_daemon.respond_error ~code:400 outchan
267     | _ -> Http_daemon.respond_error ~code:400 outchan);
268     debug_print "Done!\n"
269   with
270   | Http_types.Param_not_found attr_name ->
271       Hbugs_messages.respond_exc "missing_parameter" attr_name outchan
272   | exc ->
273       Hbugs_messages.respond_exc
274         "uncaught_exception" (Printexc.to_string exc) outchan
275 in
276
277   (* thread who cleans up ancient client/tutor/musing registrations *)
278 let ragman () =
279   let delay = 3600.0 in (* 1 hour delay *)
280   while true do
281     Thread.delay delay;
282     List.iter (fun o -> o#purge) registries
283   done
284 in
285
286   (* start daemon *)
287 printf "Listening on port %d ...\n" port;
288 flush stdout;
289 ignore (Thread.create ragman ());
290 Http_daemon.start' ~port ~mode:`Thread callback
291