X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhbugs%2Fbroker%2Fhbugs_broker.ml;h=2ff8b98349dbf11853fbff1b676b706195b7c0df;hb=1c7fb836e2af4f2f3d18afd0396701f2094265ff;hp=3a9fb9383a474cfe330266a24354d42443afa272;hpb=3c1a6c534877f7b7266809e4d92de02c7f1ee9d4;p=helm.git

diff --git a/helm/hbugs/broker/hbugs_broker.ml b/helm/hbugs/broker/hbugs_broker.ml
index 3a9fb9383..2ff8b9834 100644
--- a/helm/hbugs/broker/hbugs_broker.ml
+++ b/helm/hbugs/broker/hbugs_broker.ml
@@ -1,5 +1,7 @@
 (*
- *  Copyright (C) 2003, HELM Team.
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
  *
  *  This file is part of HELM, an Hypertextual, Electronic
  *  Library of Mathematics, developed at the Computer Science
@@ -21,7 +23,7 @@
  *  MA  02111-1307, USA.
  *
  *  For details, see the HELM World-Wide-Web page,
- *  http://cs.unibo.it/helm/.
+ *  http://helm.cs.unibo.it/
  *)
 
 open Hbugs_types;;
@@ -29,6 +31,7 @@ open Printf;;
 
 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 ;;
@@ -42,156 +45,209 @@ 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
+  | Musing_started (_, musing_id) ->
+	prerr_endline ("#### Started musing ID: " ^ 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
 ;;
 
+  (* 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
 
-let handle_msg outchan = function
+  (* 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 msg =
   (* messages from clients *)
+  (match msg with
+
+  | 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
+        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);
+        prerr_endline "CSC: State change!!!" ;
         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
+				let stopped_musing_ids = List.map parse_musing_id stop_answers in
         List.iter musings#unregister active_musings;
-        let started_musing_ids =
-          List.map  (* register new musings and collect their ids *)
-            (fun tutor_id ->
-              let res =
-                send_hbugs_req
-                  ~url:(tutors#getUrl tutor_id)
-                  (Start_musing (my_own_id, new_state))
-              in
-              let musing_id = parse_musing_id res in
-              musings#register musing_id client_id tutor_id;
-              musing_id)
-            (clients#getSubscription client_id)
-        in
-        let stopped_musing_ids = List.map parse_musing_id stop_answers in
-        return_hbugs_msg
-          (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
-          outchan
+				(match new_state with
+				| Some new_state ->	(* need to start new 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 ->
+								let res =
+									Hbugs_messages.submit_req
+										~url:(tutors#getUrl tutor_id)
+										(Start_musing (my_own_id, new_state))
+								in
+								let musing_id = parse_musing_id res in
+								musings#register musing_id client_id tutor_id;
+								musing_id)
+							subscriptions
+					in
+					Hbugs_messages.respond_msg
+						(State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
+						outchan
+				| None ->	(* no need to start new musings *)
+						Hbugs_messages.respond_msg
+							(State_accepted (my_own_id, stopped_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
+      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
-              send_hbugs_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? *)
-        );
-        return_hbugs_msg (Thanks (my_own_id, musing_id)) outchan;
+            (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
-        return_hbugs_exc "forbidden" tutor_id outchan
+      end
     ))
 
   | 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
+(*  (* DEBUGGING wrapper around 'handle_msg' *)
+let handle_msg outchan =
+  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 *)
 let callback (req: Http_types.request) outchan =
@@ -201,20 +257,36 @@ 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
+        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