- 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

diff --git a/helm/hbugs/broker/hbugs_broker.ml b/helm/hbugs/broker/hbugs_broker.ml
index 66dce60f751ee084a06562d6b245ab6733d35f30..ab3a3dfcfc92c88049aeae53b30d84ab21ce4dba 100644 (file)
--- 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