helm/hbugs/broker/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 open Hbugs_types;;
  30 open Printf;;
  31
  32 let debug = true ;;
  33 let debug_print s = if debug then prerr_endline s ;;
  34 Http_common.debug := false;;
  35
  36 let daemon_name = "H-Bugs Broker" ;;
  37 let default_port = 49081 ;;
  38 let port_env_var = "HELM_HBUGS_BROKER_PORT" ;;
  39 let port =
  40   try
  41     int_of_string (Sys.getenv port_env_var)
  42   with
  43   | Not_found -> default_port
  44   | Failure "int_of_string" ->
  45       prerr_endline "Warning: invalid port, reverting to default";
  46       default_port
  47 ;;
  48 let usage_string = "HBugs Broker: usage string not yet written :-(";;
  49
  50 exception Unexpected_msg of message;;
  51
  52 let return_xml_msg body outchan =
  53   Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan
  54 ;;
  55 let parse_musing_id = function
  56   | Musing_started (_, musing_id) -> musing_id
  57   | Musing_aborted (_, musing_id) -> musing_id
  58   | _ -> assert false
  59 ;;
  60
  61 let do_critical =
  62   let mutex = Mutex.create () in
  63   fun action ->
  64     try
  65       Mutex.lock mutex; let res = Lazy.force action in Mutex.unlock mutex; res
  66     with e -> Mutex.unlock mutex; raise e
  67 ;;
  68
  69   (* registries *)
  70 let clients = new Hbugs_broker_registry.clients in
  71 let tutors = new Hbugs_broker_registry.tutors in
  72 let musings = new Hbugs_broker_registry.musings in
  73 let registries =
  74   [ (clients :> Hbugs_broker_registry.registry);
  75     (tutors :> Hbugs_broker_registry.registry);
  76     (musings :> Hbugs_broker_registry.registry) ]
  77 in
  78
  79 let my_own_id = Hbugs_id_generator.new_broker_id () in
  80
  81   (* debugging: dump broker internal status, used by '/dump' method *)
  82 let dump_registries () =
  83   assert debug;
  84   String.concat "\n" (List.map (fun o -> o#dump) registries)
  85 in
  86
  87 let handle_msg outchan = function
  88
  89   (* messages from clients *)
  90
  91   | Help ->
  92       Hbugs_messages.respond_msg (Usage usage_string) outchan
  93   | Register_client (client_id, client_url) -> do_critical (lazy (
  94       try
  95         clients#register client_id client_url;
  96         Hbugs_messages.respond_msg (Client_registered my_own_id) outchan
  97       with Hbugs_broker_registry.Client_already_in id ->
  98         Hbugs_messages.respond_exc "already_registered" id outchan
  99     ))
 100   | Unregister_client client_id -> do_critical (lazy (
 101       if clients#isAuthenticated client_id then begin
 102         clients#unregister client_id;
 103         Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan
 104       end else
 105         Hbugs_messages.respond_exc "forbidden" client_id outchan
 106     ))
 107   | List_tutors client_id -> do_critical (lazy (
 108       if clients#isAuthenticated client_id then begin
 109         Hbugs_messages.respond_msg
 110           (Tutor_list (my_own_id, tutors#index))
 111           outchan
 112       end else
 113         Hbugs_messages.respond_exc "forbidden" client_id outchan
 114     ))
 115   | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
 116       if clients#isAuthenticated client_id then begin
 117         if List.length tutor_ids <> 0 then begin  (* at least one tutor id *)
 118           if List.for_all tutors#exists tutor_ids then begin
 119             clients#subscribe client_id tutor_ids;
 120             Hbugs_messages.respond_msg
 121               (Subscribed (my_own_id, tutor_ids)) outchan
 122           end else  (* required subscription to at least one unexistent tutor *)
 123             let missing_tutors =
 124               List.filter (fun id -> not (tutors#exists id)) tutor_ids
 125             in
 126             Hbugs_messages.respond_exc
 127               "tutor_not_found" (String.concat " " missing_tutors) outchan
 128         end else  (* no tutor id specified *)
 129           Hbugs_messages.respond_exc "no_tutor_specified" "" outchan
 130       end else
 131         Hbugs_messages.respond_exc "forbidden" client_id outchan
 132     ))
 133   | State_change (client_id, new_state) -> do_critical (lazy (
 134       if clients#isAuthenticated client_id then begin
 135         let active_musings = musings#getByClientId client_id in
 136         let stop_answers =
 137           List.map  (* collect Abort_musing message's responses *)
 138             (fun id ->  (* musing id *)
 139               let tutor = snd (musings#getByMusingId id) in
 140               Hbugs_messages.submit_req
 141                 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
 142             active_musings
 143         in
 144         List.iter musings#unregister active_musings;
 145         let started_musing_ids =
 146           List.map  (* register new musings and collect their ids *)
 147             (fun tutor_id ->
 148               let res =
 149                 Hbugs_messages.submit_req
 150                   ~url:(tutors#getUrl tutor_id)
 151                   (Start_musing (my_own_id, new_state))
 152               in
 153               let musing_id = parse_musing_id res in
 154               musings#register musing_id client_id tutor_id;
 155               musing_id)
 156             (clients#getSubscription client_id)
 157         in
 158         let stopped_musing_ids = List.map parse_musing_id stop_answers in
 159         Hbugs_messages.respond_msg
 160           (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
 161           outchan
 162       end else
 163         Hbugs_messages.respond_exc "forbidden" client_id outchan
 164     ))
 165
 166   (* messages from tutors *)
 167
 168   | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
 169       try
 170         tutors#register tutor_id tutor_url hint_type dsc;
 171         Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan
 172       with Hbugs_broker_registry.Tutor_already_in id ->
 173         Hbugs_messages.respond_exc "already_registered" id outchan
 174     ))
 175   | Unregister_tutor tutor_id -> do_critical (lazy (
 176       if tutors#isAuthenticated tutor_id then begin
 177         tutors#unregister tutor_id;
 178         Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan
 179       end else
 180         Hbugs_messages.respond_exc "forbidden" tutor_id outchan
 181     ))
 182   | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
 183       if tutors#isAuthenticated tutor_id then begin
 184         (match result with
 185         | Sorry -> ()
 186         | Eureka extras ->
 187             let res =
 188               let hint = (* TODO decidere la hint *) "hint!!!!" in
 189               let url =
 190                 clients#getUrl (fst (musings#getByMusingId musing_id))
 191               in
 192               Hbugs_messages.submit_req ~url (Hint (my_own_id, hint))
 193             in
 194             ignore res  (* TODO mi interessa la risposta? *)
 195         );
 196         Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan;
 197         musings#unregister musing_id
 198       end else
 199         Hbugs_messages.respond_exc "forbidden" tutor_id outchan
 200     ))
 201
 202   | msg ->  (* unexpected message *)
 203       debug_print "Unknown message!";
 204       Hbugs_messages.respond_exc
 205         "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan
 206 in
 207 let handle_msg outchan =  (* debugging wrapper around 'handle_msg' *)
 208   if debug then
 209     (fun msg -> (* filter handle_msg through a function which dumps input
 210                 messages *)
 211       debug_print (Hbugs_messages.string_of_msg msg);
 212       handle_msg outchan msg)
 213   else
 214     handle_msg outchan
 215 in
 216
 217   (* thread action *)
 218 let callback (req: Http_types.request) outchan =
 219   try
 220     debug_print ("Connection from " ^ req#clientAddr);
 221     debug_print ("Received request: " ^ req#path);
 222     (match req#path with
 223       (* TODO write help message *)
 224     | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
 225     | "/act" -> handle_msg outchan (Hbugs_messages.msg_of_string req#body)
 226     | "/dump" ->
 227         if debug then
 228           Http_daemon.respond ~body:(dump_registries ()) outchan
 229         else
 230           Http_daemon.respond_error ~code:400 outchan
 231     | _ -> Http_daemon.respond_error ~code:400 outchan);
 232     debug_print "Done!\n"
 233   with
 234   | Http_types.Param_not_found attr_name ->
 235       Hbugs_messages.respond_exc "missing_parameter" attr_name outchan
 236   | exc ->
 237       Hbugs_messages.respond_exc
 238         "uncaught_exception" (Printexc.to_string exc) outchan
 239 in
 240
 241   (* thread who cleans up ancient client/tutor/musing registrations *)
 242 let ragman () =
 243   let delay = 3600.0 in (* 1 hour delay *)
 244   while true do
 245     Thread.delay delay;
 246     List.iter (fun o -> o#purge) registries
 247   done
 248 in
 249
 250   (* start daemon *)
 251 printf "Listening on port %d ...\n" port;
 252 flush stdout;
 253 ignore (Thread.create ragman ());
 254 Http_daemon.start' ~port ~mode:`Thread callback
 255