From d6f4e5a43fbd054835d2323e7d5351741bd2ad3b Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Fri, 10 Jan 2003 09:05:24 +0000 Subject: [PATCH] - moved functions for sending/receiving hbugs messages in common/ - added a debugging wrapper that prints all messages received by broker - test that 'subscribe' method receive at least one tutor_id --- helm/hbugs/broker/hbugs_broker.ml | 97 ++++++++++++++++--------------- 1 file changed, 50 insertions(+), 47 deletions(-) diff --git a/helm/hbugs/broker/hbugs_broker.ml b/helm/hbugs/broker/hbugs_broker.ml index 66dce60f7..ab3a3dfcf 100644 --- a/helm/hbugs/broker/hbugs_broker.ml +++ b/helm/hbugs/broker/hbugs_broker.ml @@ -31,6 +31,7 @@ open Printf;; let debug = true ;; let debug_print s = if debug then prerr_endline s ;; +(* Http_common.debug := true;; *) let daemon_name = "H-Bugs Broker" ;; let default_port = 49081 ;; @@ -44,18 +45,12 @@ let port = 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 @@ -79,52 +74,54 @@ let my_own_id = Hbugs_id_generator.new_broker_id () 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 @@ -133,7 +130,7 @@ let handle_msg outchan = function 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 @@ -143,32 +140,29 @@ let handle_msg outchan = function (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 -> () @@ -178,21 +172,29 @@ let handle_msg outchan = function 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 *) @@ -208,9 +210,10 @@ let callback (req: Http_types.request) 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 (* TODO aggiungere lo spazzino che elimina i client/tutor/computation che non si -- 2.39.2