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 ;;
35 let daemon_name = "H-Bugs Broker" ;;
36 let default_port = 49081 ;;
37 let port_env_var = "HELM_HBUGS_BROKER_PORT" ;;
40 int_of_string (Sys.getenv port_env_var)
42 | Not_found -> default_port
43 | Failure "int_of_string" ->
44 prerr_endline "Warning: invalid port, reverting to default";
48 exception Unexpected_msg of message;;
50 let xml_contype = ("Content-Type", "text/xml") ;;
51 let return_xml_msg body outchan =
52 Http_daemon.respond ~headers:[xml_contype] ~body outchan
54 let return_hbugs_msg msg = return_xml_msg (Hbugs_messages.string_of_msg msg);;
55 let return_hbugs_exc name value = return_hbugs_msg (Exception (name, value));;
56 let send_hbugs_req ~url msg =
57 Hbugs_messages.msg_of_string
58 (Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg msg) url)
60 let parse_musing_id = function
61 | Musing_started (_, musing_id) -> musing_id
62 | Musing_aborted (_, musing_id) -> musing_id
67 let mutex = Mutex.create () in
70 Mutex.lock mutex; let res = Lazy.force action in Mutex.unlock mutex; res
71 with e -> Mutex.unlock mutex; raise e
74 let clients = new Hbugs_broker_registry.clients in
75 let tutors = new Hbugs_broker_registry.tutors in
76 let musings = new Hbugs_broker_registry.musings in
77 let my_own_id = Hbugs_id_generator.new_broker_id () in
79 let handle_msg outchan = function
81 (* messages from clients *)
82 | Register_client (client_id, client_url) -> do_critical (lazy (
83 debug_print "Register_client";
85 clients#register client_id client_url;
86 return_hbugs_msg (Client_registered my_own_id) outchan
87 with Hbugs_broker_registry.Client_already_in id ->
88 return_hbugs_exc "already_registered" id outchan
90 | Unregister_client client_id -> do_critical (lazy (
91 debug_print "Unregister_client";
92 if clients#isAuthenticated client_id then begin
93 clients#unregister client_id;
94 return_hbugs_msg (Client_unregistered my_own_id) outchan
96 return_hbugs_exc "forbidden" client_id outchan
98 | List_tutors client_id -> do_critical (lazy (
99 debug_print "List_tutors";
100 if clients#isAuthenticated client_id then begin
101 return_hbugs_msg (Tutor_list (my_own_id, tutors#index)) outchan
103 return_hbugs_exc "forbidden" client_id outchan
105 | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
106 debug_print "Subscribe";
107 if clients#isAuthenticated client_id then begin
108 if List.for_all tutors#exists tutor_ids then begin
109 clients#subscribe client_id tutor_ids;
110 return_hbugs_msg (Subscribed (my_own_id, tutor_ids)) outchan
111 end else (* required subscription to an unexistent tutor *)
113 List.find (fun id -> not (tutors#exists id)) tutor_ids
115 return_hbugs_exc "tutor_not_found" tutor_id outchan
117 return_hbugs_exc "forbidden" client_id outchan
119 | State_change (client_id, new_state) -> do_critical (lazy (
120 debug_print "State_change";
121 if clients#isAuthenticated client_id then begin
122 let active_musings = musings#getByClientId client_id in
124 List.map (* collect Abort_musing message's responses *)
125 (fun id -> (* musing id *)
126 let tutor = snd (musings#getByMusingId id) in
128 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
131 List.iter musings#unregister active_musings;
132 let started_musing_ids =
133 List.map (* register new musings and collect their ids *)
137 ~url:(tutors#getUrl tutor_id)
138 (Start_musing (my_own_id, new_state))
140 let musing_id = parse_musing_id res in
141 musings#register musing_id client_id tutor_id;
143 (clients#getSubscription client_id)
145 let stopped_musing_ids = List.map parse_musing_id stop_answers in
147 (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
150 return_hbugs_exc "forbidden" client_id outchan
153 (* messages from tutors *)
154 | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
155 debug_print "Register_tutor";
157 tutors#register tutor_id tutor_url hint_type dsc;
158 return_hbugs_msg (Tutor_registered my_own_id) outchan
159 with Hbugs_broker_registry.Tutor_already_in id ->
160 return_hbugs_exc "already_registered" id outchan
162 | Unregister_tutor tutor_id -> do_critical (lazy (
163 debug_print "Unregister_tutor";
164 if tutors#isAuthenticated tutor_id then begin
165 tutors#unregister tutor_id;
166 return_hbugs_msg (Tutor_unregistered my_own_id) outchan
168 return_hbugs_exc "forbidden" tutor_id outchan
170 | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
171 debug_print "Musing_completed";
172 if tutors#isAuthenticated tutor_id then begin
177 let hint = (* TODO decidere la hint *) "hint!!!!" in
179 clients#getUrl (fst (musings#getByMusingId musing_id))
181 send_hbugs_req ~url (Hint (my_own_id, hint))
183 ignore res (* TODO mi interessa la risposta? *)
185 return_hbugs_msg (Thanks (my_own_id, musing_id)) outchan;
186 musings#unregister musing_id
188 return_hbugs_exc "forbidden" tutor_id outchan
191 | msg -> (* unexpected message *)
192 debug_print "Unknown message!";
194 (Exception ("Unexpected_msg", Hbugs_messages.string_of_msg msg))
199 let callback (req: Http_types.request) outchan =
201 debug_print ("Connection from " ^ req#clientAddr);
202 debug_print ("Received request: " ^ req#path);
204 (* TODO write help message *)
205 | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
206 | "/act" -> handle_msg outchan (Hbugs_messages.msg_of_string req#body)
207 | _ -> Http_daemon.respond_error ~code:400 outchan);
208 debug_print "Done!\n"
210 | Http_types.Param_not_found attr_name ->
211 return_hbugs_exc "missing_parameter" attr_name outchan
213 return_hbugs_exc "uncaught_exception" (Printexc.to_string exc) outchan
216 (* TODO aggiungere lo spazzino che elimina i client/tutor/computation che non si
217 fanno sentire da troppo tempo ... *)
219 printf "Listening on port %d ...\n" port;
221 Http_daemon.start' ~port ~mode:`Thread callback