helm/software/components/hbugs/broker.ml

   1 (*
   2  * Copyright (C) 2003:
   3  *    Stefano Zacchiroli <zack@cs.unibo.it>
   4  *    for the HELM Team http://helm.cs.unibo.it/
   5  *
   6  *  This file is part of HELM, an Hypertextual, Electronic
   7  *  Library of Mathematics, developed at the Computer Science
   8  *  Department, University of Bologna, Italy.
   9  *
  10  *  HELM is free software; you can redistribute it and/or
  11  *  modify it under the terms of the GNU General Public License
  12  *  as published by the Free Software Foundation; either version 2
  13  *  of the License, or (at your option) any later version.
  14  *
  15  *  HELM is distributed in the hope that it will be useful,
  16  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18  *  GNU General Public License for more details.
  19  *
  20  *  You should have received a copy of the GNU General Public License
  21  *  along with HELM; if not, write to the Free Software
  22  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  23  *  MA  02111-1307, USA.
  24  *
  25  *  For details, see the HELM World-Wide-Web page,
  26  *  http://helm.cs.unibo.it/
  27  *)
  28
  29 (* $Id$ *)
  30
  31 open Hbugs_types;;
  32 open Printf;;
  33
  34 let debug = true ;;
  35 let debug_print s = if debug then prerr_endline (Lazy.force s) ;;
  36
  37 let daemon_name = "H-Bugs Broker" ;;
  38 let default_port = 49081 ;;
  39 let port_env_var = "HELM_HBUGS_BROKER_PORT" ;;
  40 let port =
  41   try
  42     int_of_string (Sys.getenv port_env_var)
  43   with
  44   | Not_found -> default_port
  45   | Failure "int_of_string" ->
  46       prerr_endline "Warning: invalid port, reverting to default";
  47       default_port
  48 ;;
  49 let usage_string = "HBugs Broker: usage string not yet written :-(";;
  50
  51 exception Unexpected_msg of message;;
  52
  53 let return_xml_msg body outchan =
  54   Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan
  55 ;;
  56 let parse_musing_id = function
  57   | Musing_started (_, musing_id) ->
  58         prerr_endline ("#### Started musing ID: " ^ musing_id);
  59         musing_id
  60   | Musing_aborted (_, musing_id) -> musing_id
  61   | msg ->
  62       prerr_endline (sprintf "Assertion failed, received msg: %s"
  63         (Hbugs_messages.string_of_msg msg));
  64       assert false
  65 ;;
  66
  67 let do_critical =
  68   let mutex = Mutex.create () in
  69   fun action ->
  70     try
  71 (*       debug_print (lazy "Acquiring lock ..."); *)
  72       Mutex.lock mutex;
  73 (*       debug_print (lazy "Lock Acquired!"); *)
  74       let res = Lazy.force action in
  75 (*       debug_print (lazy "Releaseing lock ..."); *)
  76       Mutex.unlock mutex;
  77 (*       debug_print (lazy "Lock released!"); *)
  78       res
  79     with e -> Mutex.unlock mutex; raise e
  80 ;;
  81
  82   (* registries *)
  83 let clients = new Hbugs_broker_registry.clients in
  84 let tutors = new Hbugs_broker_registry.tutors in
  85 let musings = new Hbugs_broker_registry.musings in
  86 let registries =
  87   [ (clients :> Hbugs_broker_registry.registry);
  88     (tutors :> Hbugs_broker_registry.registry);
  89     (musings :> Hbugs_broker_registry.registry) ]
  90 in
  91
  92 let my_own_id = Hbugs_id_generator.new_broker_id () in
  93
  94   (* debugging: dump broker internal status, used by '/dump' method *)
  95 let dump_registries () =
  96   assert debug;
  97   String.concat "\n" (List.map (fun o -> o#dump) registries)
  98 in
  99
 100 let handle_msg outchan msg =
 101   (* messages from clients *)
 102   (match msg with
 103
 104   | Help ->
 105       Hbugs_messages.respond_msg (Usage usage_string) outchan
 106   | Register_client (client_id, client_url) -> do_critical (lazy (
 107       try
 108         clients#register client_id client_url;
 109         Hbugs_messages.respond_msg (Client_registered my_own_id) outchan
 110       with Hbugs_broker_registry.Client_already_in id ->
 111         Hbugs_messages.respond_exc "already_registered" id outchan
 112     ))
 113   | Unregister_client client_id -> do_critical (lazy (
 114       if clients#isAuthenticated client_id then begin
 115         clients#unregister client_id;
 116         Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan
 117       end else
 118         Hbugs_messages.respond_exc "forbidden" client_id outchan
 119     ))
 120   | List_tutors client_id -> do_critical (lazy (
 121       if clients#isAuthenticated client_id then begin
 122         Hbugs_messages.respond_msg
 123           (Tutor_list (my_own_id, tutors#index))
 124           outchan
 125       end else
 126         Hbugs_messages.respond_exc "forbidden" client_id outchan
 127     ))
 128   | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
 129       if clients#isAuthenticated client_id then begin
 130         if List.length tutor_ids <> 0 then begin  (* at least one tutor id *)
 131           if List.for_all tutors#exists tutor_ids then begin
 132             clients#subscribe client_id tutor_ids;
 133             Hbugs_messages.respond_msg
 134               (Subscribed (my_own_id, tutor_ids)) outchan
 135           end else  (* required subscription to at least one unexistent tutor *)
 136             let missing_tutors =
 137               List.filter (fun id -> not (tutors#exists id)) tutor_ids
 138             in
 139             Hbugs_messages.respond_exc
 140               "tutor_not_found" (String.concat " " missing_tutors) outchan
 141         end else  (* no tutor id specified *)
 142           Hbugs_messages.respond_exc "no_tutor_specified" "" outchan
 143       end else
 144         Hbugs_messages.respond_exc "forbidden" client_id outchan
 145     ))
 146   | State_change (client_id, new_state) -> do_critical (lazy (
 147       if clients#isAuthenticated client_id then begin
 148         let active_musings = musings#getByClientId client_id in
 149         prerr_endline (sprintf "ACTIVE MUSINGS: %s" (String.concat ", " active_musings));
 150         if List.length active_musings = 0 then
 151           prerr_endline ("No active musings for client " ^ client_id);
 152         prerr_endline "CSC: State change!!!" ;
 153         let stop_answers =
 154           List.map  (* collect Abort_musing message's responses *)
 155             (fun id ->  (* musing id *)
 156               let tutor = snd (musings#getByMusingId id) in
 157               Hbugs_messages.submit_req
 158                 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
 159             active_musings
 160         in
 161                                 let stopped_musing_ids = List.map parse_musing_id stop_answers in
 162         List.iter musings#unregister active_musings;
 163                                 (match new_state with
 164                                 | Some new_state ->     (* need to start new musings *)
 165                                         let subscriptions = clients#getSubscription client_id in
 166                                         if List.length subscriptions = 0 then
 167                                                 prerr_endline ("No subscriptions for client " ^ client_id);
 168                                         let started_musing_ids =
 169                                                 List.map  (* register new musings and collect their ids *)
 170                                                         (fun tutor_id ->
 171                                                                 let res =
 172                                                                         Hbugs_messages.submit_req
 173                                                                                 ~url:(tutors#getUrl tutor_id)
 174                                                                                 (Start_musing (my_own_id, new_state))
 175                                                                 in
 176                                                                 let musing_id = parse_musing_id res in
 177                                                                 musings#register musing_id client_id tutor_id;
 178                                                                 musing_id)
 179                                                         subscriptions
 180                                         in
 181                                         Hbugs_messages.respond_msg
 182                                                 (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
 183                                                 outchan
 184                                 | None ->       (* no need to start new musings *)
 185                                                 Hbugs_messages.respond_msg
 186                                                         (State_accepted (my_own_id, stopped_musing_ids, []))
 187                                                         outchan)
 188       end else
 189         Hbugs_messages.respond_exc "forbidden" client_id outchan
 190     ))
 191
 192   (* messages from tutors *)
 193
 194   | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
 195       try
 196         tutors#register tutor_id tutor_url hint_type dsc;
 197         Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan
 198       with Hbugs_broker_registry.Tutor_already_in id ->
 199         Hbugs_messages.respond_exc "already_registered" id outchan
 200     ))
 201   | Unregister_tutor tutor_id -> do_critical (lazy (
 202       if tutors#isAuthenticated tutor_id then begin
 203         tutors#unregister tutor_id;
 204         Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan
 205       end else
 206         Hbugs_messages.respond_exc "forbidden" tutor_id outchan
 207     ))
 208
 209   | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
 210       if not (tutors#isAuthenticated tutor_id) then begin (* unauthorized *)
 211         Hbugs_messages.respond_exc "forbidden" tutor_id outchan;
 212       end else if not (musings#isActive musing_id) then begin (* too late *)
 213         Hbugs_messages.respond_msg (Too_late (my_own_id, musing_id)) outchan;
 214       end else begin  (* all is ok: autorhized and on time *)
 215         (match result with
 216         | Sorry -> ()
 217         | Eureka hint ->
 218             let client_url =
 219               clients#getUrl (fst (musings#getByMusingId musing_id))
 220             in
 221             let res =
 222               Hbugs_messages.submit_req ~url:client_url (Hint (my_own_id, hint))
 223             in
 224             (match res with
 225             | Wow _ -> () (* ok: client is happy with our hint *)
 226             | unexpected_msg ->
 227                 prerr_endline
 228                   (sprintf
 229                     "Warning: unexpected msg from client: %s\nExpected was: Wow"
 230                     (Hbugs_messages.string_of_msg msg))));
 231         Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan;
 232         musings#unregister musing_id
 233       end
 234     ))
 235
 236   | msg ->  (* unexpected message *)
 237       debug_print (lazy "Unknown message!");
 238       Hbugs_messages.respond_exc
 239         "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
 240 in
 241 (*  (* DEBUGGING wrapper around 'handle_msg' *)
 242 let handle_msg outchan =
 243   if debug then
 244     (fun msg -> (* filter handle_msg through a function which dumps input
 245                 messages *)
 246       debug_print (lazy (Hbugs_messages.string_of_msg msg));
 247       handle_msg outchan msg)
 248   else
 249     handle_msg outchan
 250 in
 251 *)
 252
 253   (* thread action *)
 254 let callback (req: Http_types.request) outchan =
 255   try
 256     debug_print (lazy ("Connection from " ^ req#clientAddr));
 257     debug_print (lazy ("Received request: " ^ req#path));
 258     (match req#path with
 259       (* TODO write help message *)
 260     | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
 261     | "/act" ->
 262         let msg = Hbugs_messages.msg_of_string req#body in
 263         handle_msg outchan msg
 264     | "/dump" ->
 265         if debug then
 266           Http_daemon.respond ~body:(dump_registries ()) outchan
 267         else
 268           Http_daemon.respond_error ~code:400 outchan
 269     | _ -> Http_daemon.respond_error ~code:400 outchan);
 270     debug_print (lazy "Done!\n")
 271   with
 272   | Http_types.Param_not_found attr_name ->
 273       Hbugs_messages.respond_exc "missing_parameter" attr_name outchan
 274   | exc ->
 275       Hbugs_messages.respond_exc
 276         "uncaught_exception" (Printexc.to_string exc) outchan
 277 in
 278
 279   (* thread who cleans up ancient client/tutor/musing registrations *)
 280 let ragman () =
 281   let delay = 3600.0 in (* 1 hour delay *)
 282   while true do
 283     Thread.delay delay;
 284     List.iter (fun o -> o#purge) registries
 285   done
 286 in
 287
 288   (* start daemon *)
 289 printf "Listening on port %d ...\n" port;
 290 flush stdout;
 291 ignore (Thread.create ragman ());
 292 Http_daemon.start' ~port ~mode:`Thread callback
 293