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