3 * Stefano Zacchiroli <zack@cs.unibo.it>
4 * for the HELM Team http://helm.cs.unibo.it/
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.
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.
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.
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,
25 * For details, see the HELM World-Wide-Web page,
26 * http://helm.cs.unibo.it/
33 let debug_print s = if debug then prerr_endline s ;;
34 Http_common.debug := false;;
36 let daemon_name = "H-Bugs Broker" ;;
37 let default_port = 49081 ;;
38 let port_env_var = "HELM_HBUGS_BROKER_PORT" ;;
41 int_of_string (Sys.getenv port_env_var)
43 | Not_found -> default_port
44 | Failure "int_of_string" ->
45 prerr_endline "Warning: invalid port, reverting to default";
48 let usage_string = "HBugs Broker: usage string not yet written :-(";;
50 exception Unexpected_msg of message;;
52 let return_xml_msg body outchan =
53 Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan
55 let parse_musing_id = function
56 | Musing_started (_, musing_id) -> musing_id
57 | Musing_aborted (_, musing_id) -> musing_id
59 prerr_endline (sprintf "Assertion failed, received msg: %s"
60 (Hbugs_messages.string_of_msg msg));
65 let mutex = Mutex.create () in
68 (* debug_print "Acquiring lock ..."; *)
70 (* debug_print "Lock Acquired!"; *)
71 let res = Lazy.force action in
72 (* debug_print "Releaseing lock ..."; *)
74 (* debug_print "Lock released!"; *)
76 with e -> Mutex.unlock mutex; raise e
80 let clients = new Hbugs_broker_registry.clients in
81 let tutors = new Hbugs_broker_registry.tutors in
82 let musings = new Hbugs_broker_registry.musings in
84 [ (clients :> Hbugs_broker_registry.registry);
85 (tutors :> Hbugs_broker_registry.registry);
86 (musings :> Hbugs_broker_registry.registry) ]
89 let my_own_id = Hbugs_id_generator.new_broker_id () in
91 (* debugging: dump broker internal status, used by '/dump' method *)
92 let dump_registries () =
94 String.concat "\n" (List.map (fun o -> o#dump) registries)
97 let handle_msg outchan msg =
98 (* messages from clients *)
102 Hbugs_messages.respond_msg (Usage usage_string) outchan
103 | Register_client (client_id, client_url) -> do_critical (lazy (
105 clients#register client_id client_url;
106 Hbugs_messages.respond_msg (Client_registered my_own_id) outchan
107 with Hbugs_broker_registry.Client_already_in id ->
108 Hbugs_messages.respond_exc "already_registered" id outchan
110 | Unregister_client client_id -> do_critical (lazy (
111 if clients#isAuthenticated client_id then begin
112 clients#unregister client_id;
113 Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan
115 Hbugs_messages.respond_exc "forbidden" client_id outchan
117 | List_tutors client_id -> do_critical (lazy (
118 if clients#isAuthenticated client_id then begin
119 Hbugs_messages.respond_msg
120 (Tutor_list (my_own_id, tutors#index))
123 Hbugs_messages.respond_exc "forbidden" client_id outchan
125 | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
126 if clients#isAuthenticated client_id then begin
127 if List.length tutor_ids <> 0 then begin (* at least one tutor id *)
128 if List.for_all tutors#exists tutor_ids then begin
129 clients#subscribe client_id tutor_ids;
130 Hbugs_messages.respond_msg
131 (Subscribed (my_own_id, tutor_ids)) outchan
132 end else (* required subscription to at least one unexistent tutor *)
134 List.filter (fun id -> not (tutors#exists id)) tutor_ids
136 Hbugs_messages.respond_exc
137 "tutor_not_found" (String.concat " " missing_tutors) outchan
138 end else (* no tutor id specified *)
139 Hbugs_messages.respond_exc "no_tutor_specified" "" outchan
141 Hbugs_messages.respond_exc "forbidden" client_id outchan
143 | State_change (client_id, new_state) -> do_critical (lazy (
144 if clients#isAuthenticated client_id then begin
145 let active_musings = musings#getByClientId client_id in
146 prerr_endline (sprintf "ACTIVE MUSINGS: %s" (String.concat ", " active_musings));
147 if List.length active_musings = 0 then
148 prerr_endline ("No active musings for client " ^ client_id);
150 List.map (* collect Abort_musing message's responses *)
151 (fun id -> (* musing id *)
152 let tutor = snd (musings#getByMusingId id) in
153 Hbugs_messages.submit_req
154 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
157 List.iter musings#unregister active_musings;
158 let subscriptions = clients#getSubscription client_id in
159 if List.length subscriptions = 0 then
160 prerr_endline ("No subscriptions for client " ^ client_id);
161 let started_musing_ids =
162 List.map (* register new musings and collect their ids *)
165 Hbugs_messages.submit_req
166 ~url:(tutors#getUrl tutor_id)
167 (Start_musing (my_own_id, new_state))
169 let musing_id = parse_musing_id res in
170 musings#register musing_id client_id tutor_id;
174 let stopped_musing_ids = List.map parse_musing_id stop_answers in
175 Hbugs_messages.respond_msg
176 (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
179 Hbugs_messages.respond_exc "forbidden" client_id outchan
182 (* messages from tutors *)
184 | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
186 tutors#register tutor_id tutor_url hint_type dsc;
187 Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan
188 with Hbugs_broker_registry.Tutor_already_in id ->
189 Hbugs_messages.respond_exc "already_registered" id outchan
191 | Unregister_tutor tutor_id -> do_critical (lazy (
192 if tutors#isAuthenticated tutor_id then begin
193 tutors#unregister tutor_id;
194 Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan
196 Hbugs_messages.respond_exc "forbidden" tutor_id outchan
199 | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
200 if not (tutors#isAuthenticated tutor_id) then begin (* unauthorized *)
201 Hbugs_messages.respond_exc "forbidden" tutor_id outchan;
202 end else if not (musings#isActive musing_id) then begin (* too late *)
203 Hbugs_messages.respond_msg (Too_late (my_own_id, musing_id)) outchan;
204 end else begin (* all is ok: autorhized and on time *)
209 clients#getUrl (fst (musings#getByMusingId musing_id))
212 Hbugs_messages.submit_req ~url:client_url (Hint (my_own_id, hint))
215 | Wow _ -> () (* ok: client is happy with our hint *)
219 "Warning: unexpected msg from client: %s\nExpected was: Wow"
220 (Hbugs_messages.string_of_msg msg))));
221 Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan;
222 musings#unregister musing_id
226 | msg -> (* unexpected message *)
227 debug_print "Unknown message!";
228 Hbugs_messages.respond_exc
229 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
231 (* (* DEBUGGING wrapper around 'handle_msg' *)
232 let handle_msg outchan =
234 (fun msg -> (* filter handle_msg through a function which dumps input
236 debug_print (Hbugs_messages.string_of_msg msg);
237 handle_msg outchan msg)
244 let callback (req: Http_types.request) outchan =
246 debug_print ("Connection from " ^ req#clientAddr);
247 debug_print ("Received request: " ^ req#path);
249 (* TODO write help message *)
250 | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
252 let msg = Hbugs_messages.msg_of_string req#body in
253 handle_msg outchan msg
256 Http_daemon.respond ~body:(dump_registries ()) outchan
258 Http_daemon.respond_error ~code:400 outchan
259 | _ -> Http_daemon.respond_error ~code:400 outchan);
260 debug_print "Done!\n"
262 | Http_types.Param_not_found attr_name ->
263 Hbugs_messages.respond_exc "missing_parameter" attr_name outchan
265 Hbugs_messages.respond_exc
266 "uncaught_exception" (Printexc.to_string exc) outchan
269 (* thread who cleans up ancient client/tutor/musing registrations *)
271 let delay = 3600.0 in (* 1 hour delay *)
274 List.iter (fun o -> o#purge) registries
279 printf "Listening on port %d ...\n" port;
281 ignore (Thread.create ragman ());
282 Http_daemon.start' ~port ~mode:`Thread callback