- better specialization of some error messages

- added some informational messages
- use hint received from tutor instead of a fooish one
- control over answer from gTopLevel when sending hint
- commented out debugging wrapper which print all received messages

diff --git a/helm/hbugs/broker/hbugs_broker.ml b/helm/hbugs/broker/hbugs_broker.ml
index 87a60bba7c093513e77bca8d4074b0573b7266d9..495fbf161084402f533e59faa3c9f88b702558a0 100644 (file)
--- a/helm/hbugs/broker/hbugs_broker.ml
+++ b/helm/hbugs/broker/hbugs_broker.ml
@@ -55,14 +55,24 @@ let return_xml_msg body outchan =
 let parse_musing_id = function
   | Musing_started (_, musing_id) -> musing_id
   | Musing_aborted (_, musing_id) -> musing_id
-  | _ -> assert false
+  | msg ->
+      prerr_endline (sprintf "Assertion failed, received msg: %s"
+        (Hbugs_messages.string_of_msg msg));
+      assert false
 ;;
 
 let do_critical =
   let mutex = Mutex.create () in
   fun action ->
     try
-      Mutex.lock mutex; let res = Lazy.force action in Mutex.unlock mutex; res
+(*       debug_print "Acquiring lock ..."; *)
+      Mutex.lock mutex;
+(*       debug_print "Lock Acquired!"; *)
+      let res = Lazy.force action in
+(*       debug_print "Releaseing lock ..."; *)
+      Mutex.unlock mutex;
+(*       debug_print "Lock released!"; *)
+      res
     with e -> Mutex.unlock mutex; raise e
 ;;
 
@@ -84,9 +94,9 @@ let dump_registries () =
   String.concat "\n" (List.map (fun o -> o#dump) registries)
 in
 
-let handle_msg outchan = function
-
+let handle_msg outchan msg =
   (* messages from clients *)
+  (match msg with
 
   | Help ->
       Hbugs_messages.respond_msg (Usage usage_string) outchan
@@ -133,6 +143,9 @@ let handle_msg outchan = function
   | State_change (client_id, new_state) -> do_critical (lazy (
       if clients#isAuthenticated client_id then begin
         let active_musings = musings#getByClientId client_id in
+        prerr_endline (sprintf "ACTIVE MUSINGS: %s" (String.concat ", " active_musings));
+        if List.length active_musings = 0 then
+          prerr_endline ("No active musings for client " ^ client_id);
         let stop_answers =
           List.map  (* collect Abort_musing message's responses *)
             (fun id ->  (* musing id *)
@@ -142,6 +155,9 @@ let handle_msg outchan = function
             active_musings
         in
         List.iter musings#unregister active_musings;
+        let subscriptions = clients#getSubscription client_id in
+        if List.length subscriptions = 0 then
+          prerr_endline ("No subscriptions for client " ^ client_id);
         let started_musing_ids =
           List.map  (* register new musings and collect their ids *)
             (fun tutor_id ->
@@ -153,7 +169,7 @@ let handle_msg outchan = function
               let musing_id = parse_musing_id res in
               musings#register musing_id client_id tutor_id;
               musing_id)
-            (clients#getSubscription client_id)
+            subscriptions
         in
         let stopped_musing_ids = List.map parse_musing_id stop_answers in
         Hbugs_messages.respond_msg
@@ -179,32 +195,41 @@ let handle_msg outchan = function
       end else
         Hbugs_messages.respond_exc "forbidden" tutor_id outchan
     ))
+
   | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
-      if tutors#isAuthenticated tutor_id then begin
+      if not (tutors#isAuthenticated tutor_id) then begin (* unauthorized *)
+        Hbugs_messages.respond_exc "forbidden" tutor_id outchan;
+      end else if not (musings#isActive musing_id) then begin (* too late *)
+        Hbugs_messages.respond_msg (Too_late (my_own_id, musing_id)) outchan;
+      end else begin  (* all is ok: autorhized and on time *)
         (match result with
         | Sorry -> ()
-        | Eureka extras ->
+        | Eureka hint ->
+            let client_url =
+              clients#getUrl (fst (musings#getByMusingId musing_id))
+            in
             let res =
-              let hint = (* TODO decidere la hint *) "hint!!!!" in
-              let url =
-                clients#getUrl (fst (musings#getByMusingId musing_id))
-              in
-              Hbugs_messages.submit_req ~url (Hint (my_own_id, hint))
+              Hbugs_messages.submit_req ~url:client_url (Hint (my_own_id, hint))
             in
-            ignore res  (* TODO mi interessa la risposta? *)
-        );
+            (match res with
+            | Wow _ -> () (* ok: client is happy with our hint *)
+            | unexpected_msg ->
+                prerr_endline
+                  (sprintf
+                    "Warning: unexpected msg from client: %s\nExpected was: Wow"
+                    (Hbugs_messages.string_of_msg msg))));
         Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan;
         musings#unregister musing_id
-      end else
-        Hbugs_messages.respond_exc "forbidden" tutor_id outchan
+      end
     ))
 
   | msg ->  (* unexpected message *)
       debug_print "Unknown message!";
       Hbugs_messages.respond_exc
-        "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan
+        "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
 in
-let handle_msg outchan =  (* debugging wrapper around 'handle_msg' *)
+(*  (* DEBUGGING wrapper around 'handle_msg' *)
+let handle_msg outchan =
   if debug then
     (fun msg -> (* filter handle_msg through a function which dumps input
                 messages *)
@@ -213,6 +238,7 @@ let handle_msg outchan =  (* debugging wrapper around 'handle_msg' *)
   else
     handle_msg outchan
 in
+*)
 
   (* thread action *)
 let callback (req: Http_types.request) outchan =
@@ -222,7 +248,9 @@ let callback (req: Http_types.request) outchan =
     (match req#path with
       (* 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)
+    | "/act" ->
+        let msg = Hbugs_messages.msg_of_string req#body in
+        handle_msg outchan msg
     | "/dump" ->
         if debug then
           Http_daemon.respond ~body:(dump_registries ()) outchan