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