2 * Copyright (C) 2003, HELM Team.
4 * This file is part of HELM, an Hypertextual, Electronic
5 * Library of Mathematics, developed at the Computer Science
6 * Department, University of Bologna, Italy.
8 * HELM is free software; you can redistribute it and/or
9 * modify it under the terms of the GNU General Public License
10 * as published by the Free Software Foundation; either version 2
11 * of the License, or (at your option) any later version.
13 * HELM is distributed in the hope that it will be useful,
14 * but WITHOUT ANY WARRANTY; without even the implied warranty of
15 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 * GNU General Public License for more details.
18 * You should have received a copy of the GNU General Public License
19 * along with HELM; if not, write to the Free Software
20 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
23 * For details, see the HELM World-Wide-Web page,
24 * http://cs.unibo.it/helm/.
31 let debug_print s = if debug then prerr_endline s ;;
33 let daemon_name = "H-Bugs Broker" ;;
34 let default_port = 49081 ;;
35 let port_env_var = "HELM_HBUGS_BROKER_PORT" ;;
38 int_of_string (Sys.getenv port_env_var)
40 | Not_found -> default_port
41 | Failure "int_of_string" ->
42 prerr_endline "Warning: invalid port, reverting to default";
46 exception Unexpected_msg of message;;
48 let xml_contype = ("Content-Type", "text/xml") ;;
49 let return_xml_msg body outchan =
50 Http_daemon.respond ~headers:[xml_contype] ~body outchan
52 let return_hbugs_msg msg = return_xml_msg (Hbugs_messages.string_of_msg msg);;
53 let return_hbugs_exc name value = return_hbugs_msg (Exception (name, value));;
54 let send_hbugs_req ~url msg =
55 Hbugs_messages.msg_of_string
56 (Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg msg) url)
58 let parse_musing_id = function
59 | Musing_started (_, musing_id) -> musing_id
60 | Musing_aborted (_, musing_id) -> musing_id
65 let mutex = Mutex.create () in
68 Mutex.lock mutex; let res = Lazy.force action in Mutex.unlock mutex; res
69 with e -> Mutex.unlock mutex; raise e
72 let clients = new Hbugs_broker_registry.clients in
73 let tutors = new Hbugs_broker_registry.tutors in
74 let musings = new Hbugs_broker_registry.musings in
75 let my_own_id = Hbugs_id_generator.new_broker_id () in
77 let handle_msg outchan = function
79 (* messages from clients *)
80 | Register_client (client_id, client_url) -> do_critical (lazy (
81 debug_print "Register_client";
83 clients#register client_id client_url;
84 return_hbugs_msg (Client_registered my_own_id) outchan
85 with Hbugs_broker_registry.Client_already_in id ->
86 return_hbugs_exc "already_registered" id outchan
88 | Unregister_client client_id -> do_critical (lazy (
89 debug_print "Unregister_client";
90 if clients#isAuthenticated client_id then begin
91 clients#unregister client_id;
92 return_hbugs_msg (Client_unregistered my_own_id) outchan
94 return_hbugs_exc "forbidden" client_id outchan
96 | List_tutors client_id -> do_critical (lazy (
97 debug_print "List_tutors";
98 if clients#isAuthenticated client_id then begin
99 return_hbugs_msg (Tutor_list (my_own_id, tutors#index)) outchan
101 return_hbugs_exc "forbidden" client_id outchan
103 | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
104 debug_print "Subscribe";
105 if clients#isAuthenticated client_id then begin
106 if List.for_all tutors#exists tutor_ids then begin
107 clients#subscribe client_id tutor_ids;
108 return_hbugs_msg (Subscribed (my_own_id, tutor_ids)) outchan
109 end else (* required subscription to an unexistent tutor *)
111 List.find (fun id -> not (tutors#exists id)) tutor_ids
113 return_hbugs_exc "tutor_not_found" tutor_id outchan
115 return_hbugs_exc "forbidden" client_id outchan
117 | State_change (client_id, new_state) -> do_critical (lazy (
118 debug_print "State_change";
119 if clients#isAuthenticated client_id then begin
120 let active_musings = musings#getByClientId client_id in
122 List.map (* collect Abort_musing message's responses *)
123 (fun id -> (* musing id *)
124 let tutor = snd (musings#getByMusingId id) in
126 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
129 List.iter musings#unregister active_musings;
130 let started_musing_ids =
131 List.map (* register new musings and collect their ids *)
135 ~url:(tutors#getUrl tutor_id)
136 (Start_musing (my_own_id, new_state))
138 let musing_id = parse_musing_id res in
139 musings#register musing_id client_id tutor_id;
141 (clients#getSubscription client_id)
143 let stopped_musing_ids = List.map parse_musing_id stop_answers in
145 (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
148 return_hbugs_exc "forbidden" client_id outchan
151 (* messages from tutors *)
152 | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
153 debug_print "Register_tutor";
155 tutors#register tutor_id tutor_url hint_type dsc;
156 return_hbugs_msg (Tutor_registered my_own_id) outchan
157 with Hbugs_broker_registry.Tutor_already_in id ->
158 return_hbugs_exc "already_registered" id outchan
160 | Unregister_tutor tutor_id -> do_critical (lazy (
161 debug_print "Unregister_tutor";
162 if tutors#isAuthenticated tutor_id then begin
163 tutors#unregister tutor_id;
164 return_hbugs_msg (Tutor_unregistered my_own_id) outchan
166 return_hbugs_exc "forbidden" tutor_id outchan
168 | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
169 debug_print "Musing_completed";
170 if tutors#isAuthenticated tutor_id then begin
175 let hint = (* TODO decidere la hint *) "hint!!!!" in
177 clients#getUrl (fst (musings#getByMusingId musing_id))
179 send_hbugs_req ~url (Hint (my_own_id, hint))
181 ignore res (* TODO mi interessa la risposta? *)
183 return_hbugs_msg (Thanks (my_own_id, musing_id)) outchan;
184 musings#unregister musing_id
186 return_hbugs_exc "forbidden" tutor_id outchan
189 | msg -> (* unexpected message *)
190 debug_print "Unknown message!";
192 (Exception ("Unexpected_msg", Hbugs_messages.string_of_msg msg))
197 let callback (req: Http_types.request) outchan =
199 debug_print ("Connection from " ^ req#clientAddr);
200 debug_print ("Received request: " ^ req#path);
202 (* TODO write help message *)
203 | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
204 | "/act" -> handle_msg outchan (Hbugs_messages.msg_of_string req#body)
205 | _ -> Http_daemon.respond_error ~code:400 outchan);
206 debug_print "Done!\n"
208 | Http_types.Param_not_found attr_name ->
209 return_hbugs_exc "missing_parameter" attr_name outchan
211 return_hbugs_exc "uncaught_exception" (Printexc.to_string exc) outchan
214 (* TODO aggiungere lo spazzino che elimina i client/tutor/computation che non si
215 fanno sentire da troppo tempo ... *)
217 printf "Listening on port %d ...\n" port;
219 Http_daemon.start' ~port ~mode:`Thread callback