- added ragman process who cleans up old registrations

[helm.git] / helm / hbugs / broker / hbugs_broker.ml

diff --git a/helm/hbugs/broker/hbugs_broker.ml b/helm/hbugs/broker/hbugs_broker.ml
index ab3a3dfcfc92c88049aeae53b30d84ab21ce4dba..87a60bba7c093513e77bca8d4074b0573b7266d9 100644 (file)
--- a/helm/hbugs/broker/hbugs_broker.ml
+++ b/helm/hbugs/broker/hbugs_broker.ml
@@ -31,7 +31,7 @@ open Printf;;
 
 let debug = true ;;
 let debug_print s = if debug then prerr_endline s ;;
-(* Http_common.debug := true;; *)
+Http_common.debug := false;;
 
 let daemon_name = "H-Bugs Broker" ;;
 let default_port = 49081 ;;
@@ -66,14 +66,28 @@ let do_critical =
     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 (
@@ -92,7 +106,9 @@ let handle_msg outchan = function
     ))
   | List_tutors client_id -> do_critical (lazy (
       if clients#isAuthenticated client_id then begin
-        Hbugs_messages.respond_msg (Tutor_list (my_own_id, tutors#index)) outchan
+        Hbugs_messages.respond_msg
+          (Tutor_list (my_own_id, tutors#index))
+          outchan
       end else
         Hbugs_messages.respond_exc "forbidden" client_id outchan
     ))
@@ -148,6 +164,7 @@ let handle_msg outchan = function
     ))
 
   (* messages from tutors *)
+
   | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
       try
         tutors#register tutor_id tutor_url hint_type dsc;
@@ -206,6 +223,11 @@ let callback (req: Http_types.request) outchan =
       (* 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
@@ -216,10 +238,18 @@ let callback (req: Http_types.request) outchan =
         "uncaught_exception" (Printexc.to_string exc) outchan
 in
 
-(* TODO aggiungere lo spazzino che elimina i client/tutor/computation che non si
-fanno sentire da troppo tempo ... *)
-    (* start daemon *)
+  (* 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
+
+  (* start daemon *)
 printf "Listening on port %d ...\n" port;
 flush stdout;
+ignore (Thread.create ragman ());
 Http_daemon.start' ~port ~mode:`Thread callback