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 := true;; *)
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
62 let mutex = Mutex.create () in
65 Mutex.lock mutex; let res = Lazy.force action in Mutex.unlock mutex; res
66 with e -> Mutex.unlock mutex; raise e
69 let clients = new Hbugs_broker_registry.clients in
70 let tutors = new Hbugs_broker_registry.tutors in
71 let musings = new Hbugs_broker_registry.musings in
72 let my_own_id = Hbugs_id_generator.new_broker_id () in
74 let handle_msg outchan = function
76 (* messages from clients *)
78 Hbugs_messages.respond_msg (Usage usage_string) outchan
79 | Register_client (client_id, client_url) -> do_critical (lazy (
81 clients#register client_id client_url;
82 Hbugs_messages.respond_msg (Client_registered my_own_id) outchan
83 with Hbugs_broker_registry.Client_already_in id ->
84 Hbugs_messages.respond_exc "already_registered" id outchan
86 | Unregister_client client_id -> do_critical (lazy (
87 if clients#isAuthenticated client_id then begin
88 clients#unregister client_id;
89 Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan
91 Hbugs_messages.respond_exc "forbidden" client_id outchan
93 | List_tutors client_id -> do_critical (lazy (
94 if clients#isAuthenticated client_id then begin
95 Hbugs_messages.respond_msg (Tutor_list (my_own_id, tutors#index)) outchan
97 Hbugs_messages.respond_exc "forbidden" client_id outchan
99 | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
100 if clients#isAuthenticated client_id then begin
101 if List.length tutor_ids <> 0 then begin (* at least one tutor id *)
102 if List.for_all tutors#exists tutor_ids then begin
103 clients#subscribe client_id tutor_ids;
104 Hbugs_messages.respond_msg
105 (Subscribed (my_own_id, tutor_ids)) outchan
106 end else (* required subscription to at least one unexistent tutor *)
108 List.filter (fun id -> not (tutors#exists id)) tutor_ids
110 Hbugs_messages.respond_exc
111 "tutor_not_found" (String.concat " " missing_tutors) outchan
112 end else (* no tutor id specified *)
113 Hbugs_messages.respond_exc "no_tutor_specified" "" outchan
115 Hbugs_messages.respond_exc "forbidden" client_id outchan
117 | State_change (client_id, new_state) -> do_critical (lazy (
118 if clients#isAuthenticated client_id then begin
119 let active_musings = musings#getByClientId client_id in
121 List.map (* collect Abort_musing message's responses *)
122 (fun id -> (* musing id *)
123 let tutor = snd (musings#getByMusingId id) in
124 Hbugs_messages.submit_req
125 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
128 List.iter musings#unregister active_musings;
129 let started_musing_ids =
130 List.map (* register new musings and collect their ids *)
133 Hbugs_messages.submit_req
134 ~url:(tutors#getUrl tutor_id)
135 (Start_musing (my_own_id, new_state))
137 let musing_id = parse_musing_id res in
138 musings#register musing_id client_id tutor_id;
140 (clients#getSubscription client_id)
142 let stopped_musing_ids = List.map parse_musing_id stop_answers in
143 Hbugs_messages.respond_msg
144 (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
147 Hbugs_messages.respond_exc "forbidden" client_id outchan
150 (* messages from tutors *)
151 | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
153 tutors#register tutor_id tutor_url hint_type dsc;
154 Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan
155 with Hbugs_broker_registry.Tutor_already_in id ->
156 Hbugs_messages.respond_exc "already_registered" id outchan
158 | Unregister_tutor tutor_id -> do_critical (lazy (
159 if tutors#isAuthenticated tutor_id then begin
160 tutors#unregister tutor_id;
161 Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan
163 Hbugs_messages.respond_exc "forbidden" tutor_id outchan
165 | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
166 if tutors#isAuthenticated tutor_id then begin
171 let hint = (* TODO decidere la hint *) "hint!!!!" in
173 clients#getUrl (fst (musings#getByMusingId musing_id))
175 Hbugs_messages.submit_req ~url (Hint (my_own_id, hint))
177 ignore res (* TODO mi interessa la risposta? *)
179 Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan;
180 musings#unregister musing_id
182 Hbugs_messages.respond_exc "forbidden" tutor_id outchan
185 | msg -> (* unexpected message *)
186 debug_print "Unknown message!";
187 Hbugs_messages.respond_exc
188 "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan
190 let handle_msg outchan = (* debugging wrapper around 'handle_msg' *)
192 (fun msg -> (* filter handle_msg through a function which dumps input
194 debug_print (Hbugs_messages.string_of_msg msg);
195 handle_msg outchan msg)
201 let callback (req: Http_types.request) outchan =
203 debug_print ("Connection from " ^ req#clientAddr);
204 debug_print ("Received request: " ^ req#path);
206 (* TODO write help message *)
207 | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
208 | "/act" -> handle_msg outchan (Hbugs_messages.msg_of_string req#body)
209 | _ -> Http_daemon.respond_error ~code:400 outchan);
210 debug_print "Done!\n"
212 | Http_types.Param_not_found attr_name ->
213 Hbugs_messages.respond_exc "missing_parameter" attr_name outchan
215 Hbugs_messages.respond_exc
216 "uncaught_exception" (Printexc.to_string exc) outchan
219 (* TODO aggiungere lo spazzino che elimina i client/tutor/computation che non si
220 fanno sentire da troppo tempo ... *)
222 printf "Listening on port %d ...\n" port;
224 Http_daemon.start' ~port ~mode:`Thread callback