let debug = true ;;
let debug_print s = if debug then prerr_endline s ;;
+Http_common.debug := false;;
let daemon_name = "H-Bugs Broker" ;;
let default_port = 49081 ;;
prerr_endline "Warning: invalid port, reverting to default";
default_port
;;
+let usage_string = "HBugs Broker: usage string not yet written :-(";;
exception Unexpected_msg of message;;
-let xml_contype = ("Content-Type", "text/xml") ;;
let return_xml_msg body outchan =
- Http_daemon.respond ~headers:[xml_contype] ~body outchan
-;;
-let return_hbugs_msg msg = return_xml_msg (Hbugs_messages.string_of_msg msg);;
-let return_hbugs_exc name value = return_hbugs_msg (Exception (name, value));;
-let send_hbugs_req ~url msg =
- Hbugs_messages.msg_of_string
- (Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg msg) url)
+ Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan
;;
let parse_musing_id = function
| Musing_started (_, musing_id) -> musing_id
with e -> Mutex.unlock mutex; raise e
;;
+ (* registries *)
let clients = new Hbugs_broker_registry.clients in
let tutors = new Hbugs_broker_registry.tutors in
let musings = new Hbugs_broker_registry.musings in
+let registries =
+ [ (clients :> Hbugs_broker_registry.registry);
+ (tutors :> Hbugs_broker_registry.registry);
+ (musings :> Hbugs_broker_registry.registry) ]
+in
+
let my_own_id = Hbugs_id_generator.new_broker_id () in
+ (* debugging: dump broker internal status, used by '/dump' method *)
+let dump_registries () =
+ assert debug;
+ String.concat "\n" (List.map (fun o -> o#dump) registries)
+in
+
let handle_msg outchan = function
(* messages from clients *)
+
+ | Help ->
+ Hbugs_messages.respond_msg (Usage usage_string) outchan
| Register_client (client_id, client_url) -> do_critical (lazy (
- debug_print "Register_client";
try
clients#register client_id client_url;
- return_hbugs_msg (Client_registered my_own_id) outchan
+ Hbugs_messages.respond_msg (Client_registered my_own_id) outchan
with Hbugs_broker_registry.Client_already_in id ->
- return_hbugs_exc "already_registered" id outchan
+ Hbugs_messages.respond_exc "already_registered" id outchan
))
| Unregister_client client_id -> do_critical (lazy (
- debug_print "Unregister_client";
if clients#isAuthenticated client_id then begin
clients#unregister client_id;
- return_hbugs_msg (Client_unregistered my_own_id) outchan
+ Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan
end else
- return_hbugs_exc "forbidden" client_id outchan
+ Hbugs_messages.respond_exc "forbidden" client_id outchan
))
| List_tutors client_id -> do_critical (lazy (
- debug_print "List_tutors";
if clients#isAuthenticated client_id then begin
- return_hbugs_msg (Tutor_list (my_own_id, tutors#index)) outchan
+ Hbugs_messages.respond_msg
+ (Tutor_list (my_own_id, tutors#index))
+ outchan
end else
- return_hbugs_exc "forbidden" client_id outchan
+ Hbugs_messages.respond_exc "forbidden" client_id outchan
))
| Subscribe (client_id, tutor_ids) -> do_critical (lazy (
- debug_print "Subscribe";
if clients#isAuthenticated client_id then begin
- if List.for_all tutors#exists tutor_ids then begin
- clients#subscribe client_id tutor_ids;
- return_hbugs_msg (Subscribed (my_own_id, tutor_ids)) outchan
- end else (* required subscription to an unexistent tutor *)
- let tutor_id =
- List.find (fun id -> not (tutors#exists id)) tutor_ids
- in
- return_hbugs_exc "tutor_not_found" tutor_id outchan
+ if List.length tutor_ids <> 0 then begin (* at least one tutor id *)
+ if List.for_all tutors#exists tutor_ids then begin
+ clients#subscribe client_id tutor_ids;
+ Hbugs_messages.respond_msg
+ (Subscribed (my_own_id, tutor_ids)) outchan
+ end else (* required subscription to at least one unexistent tutor *)
+ let missing_tutors =
+ List.filter (fun id -> not (tutors#exists id)) tutor_ids
+ in
+ Hbugs_messages.respond_exc
+ "tutor_not_found" (String.concat " " missing_tutors) outchan
+ end else (* no tutor id specified *)
+ Hbugs_messages.respond_exc "no_tutor_specified" "" outchan
end else
- return_hbugs_exc "forbidden" client_id outchan
+ Hbugs_messages.respond_exc "forbidden" client_id outchan
))
| State_change (client_id, new_state) -> do_critical (lazy (
- debug_print "State_change";
if clients#isAuthenticated client_id then begin
let active_musings = musings#getByClientId client_id in
let stop_answers =
List.map (* collect Abort_musing message's responses *)
(fun id -> (* musing id *)
let tutor = snd (musings#getByMusingId id) in
- send_hbugs_req
+ Hbugs_messages.submit_req
~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
active_musings
in
List.map (* register new musings and collect their ids *)
(fun tutor_id ->
let res =
- send_hbugs_req
+ Hbugs_messages.submit_req
~url:(tutors#getUrl tutor_id)
(Start_musing (my_own_id, new_state))
in
(clients#getSubscription client_id)
in
let stopped_musing_ids = List.map parse_musing_id stop_answers in
- return_hbugs_msg
+ Hbugs_messages.respond_msg
(State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
outchan
end else
- return_hbugs_exc "forbidden" client_id outchan
+ Hbugs_messages.respond_exc "forbidden" client_id outchan
))
(* messages from tutors *)
+
| Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
- debug_print "Register_tutor";
try
tutors#register tutor_id tutor_url hint_type dsc;
- return_hbugs_msg (Tutor_registered my_own_id) outchan
+ Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan
with Hbugs_broker_registry.Tutor_already_in id ->
- return_hbugs_exc "already_registered" id outchan
+ Hbugs_messages.respond_exc "already_registered" id outchan
))
| Unregister_tutor tutor_id -> do_critical (lazy (
- debug_print "Unregister_tutor";
if tutors#isAuthenticated tutor_id then begin
tutors#unregister tutor_id;
- return_hbugs_msg (Tutor_unregistered my_own_id) outchan
+ Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan
end else
- return_hbugs_exc "forbidden" tutor_id outchan
+ Hbugs_messages.respond_exc "forbidden" tutor_id outchan
))
| Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
- debug_print "Musing_completed";
if tutors#isAuthenticated tutor_id then begin
(match result with
| Sorry -> ()
let url =
clients#getUrl (fst (musings#getByMusingId musing_id))
in
- send_hbugs_req ~url (Hint (my_own_id, hint))
+ Hbugs_messages.submit_req ~url (Hint (my_own_id, hint))
in
ignore res (* TODO mi interessa la risposta? *)
);
- return_hbugs_msg (Thanks (my_own_id, musing_id)) outchan;
+ Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan;
musings#unregister musing_id
end else
- return_hbugs_exc "forbidden" tutor_id outchan
+ Hbugs_messages.respond_exc "forbidden" tutor_id outchan
))
| msg -> (* unexpected message *)
debug_print "Unknown message!";
- return_hbugs_msg
- (Exception ("Unexpected_msg", Hbugs_messages.string_of_msg msg))
- outchan
+ Hbugs_messages.respond_exc
+ "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan
+in
+let handle_msg outchan = (* debugging wrapper around 'handle_msg' *)
+ if debug then
+ (fun msg -> (* filter handle_msg through a function which dumps input
+ messages *)
+ debug_print (Hbugs_messages.string_of_msg msg);
+ handle_msg outchan msg)
+ else
+ handle_msg outchan
in
(* thread action *)
(* TODO write help message *)
| "/help" -> return_xml_msg "<help> not yet written </help>" outchan
| "/act" -> handle_msg outchan (Hbugs_messages.msg_of_string req#body)
+ | "/dump" ->
+ if debug then
+ Http_daemon.respond ~body:(dump_registries ()) outchan
+ else
+ Http_daemon.respond_error ~code:400 outchan
| _ -> Http_daemon.respond_error ~code:400 outchan);
debug_print "Done!\n"
with
| Http_types.Param_not_found attr_name ->
- return_hbugs_exc "missing_parameter" attr_name outchan
+ Hbugs_messages.respond_exc "missing_parameter" attr_name outchan
| exc ->
- return_hbugs_exc "uncaught_exception" (Printexc.to_string exc) outchan
+ Hbugs_messages.respond_exc
+ "uncaught_exception" (Printexc.to_string exc) outchan
+in
+
+ (* thread who cleans up ancient client/tutor/musing registrations *)
+let ragman () =
+ let delay = 3600.0 in (* 1 hour delay *)
+ while true do
+ Thread.delay delay;
+ List.iter (fun o -> o#purge) registries
+ done
in
-(* TODO aggiungere lo spazzino che elimina i client/tutor/computation che non si
-fanno sentire da troppo tempo ... *)
- (* start daemon *)
+ (* start daemon *)
printf "Listening on port %d ...\n" port;
flush stdout;
+ignore (Thread.create ragman ());
Http_daemon.start' ~port ~mode:`Thread callback