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   | msg ->
  59       prerr_endline (sprintf "Assertion failed, received msg: %s"
  60         (Hbugs_messages.string_of_msg msg));
  61       assert false
  62 ;;
  63
  64 let do_critical =
  65   let mutex = Mutex.create () in
  66   fun action ->
  67     try
  68 (*       debug_print "Acquiring lock ..."; *)
  69       Mutex.lock mutex;
  70 (*       debug_print "Lock Acquired!"; *)
  71       let res = Lazy.force action in
  72 (*       debug_print "Releaseing lock ..."; *)
  73       Mutex.unlock mutex;
  74 (*       debug_print "Lock released!"; *)
  75       res
  76     with e -> Mutex.unlock mutex; raise e
  77 ;;
  78
  79   (* registries *)
  80 let clients = new Hbugs_broker_registry.clients in
  81 let tutors = new Hbugs_broker_registry.tutors in
  82 let musings = new Hbugs_broker_registry.musings in
  83 let registries =
  84   [ (clients :> Hbugs_broker_registry.registry);
  85     (tutors :> Hbugs_broker_registry.registry);
  86     (musings :> Hbugs_broker_registry.registry) ]
  87 in
  88
  89 let my_own_id = Hbugs_id_generator.new_broker_id () in
  90
  91   (* debugging: dump broker internal status, used by '/dump' method *)
  92 let dump_registries () =
  93   assert debug;
  94   String.concat "\n" (List.map (fun o -> o#dump) registries)
  95 in
  96
  97 let handle_msg outchan msg =
  98   (* messages from clients *)
  99   (match msg with
 100
 101   | Help ->
 102       Hbugs_messages.respond_msg (Usage usage_string) outchan
 103   | Register_client (client_id, client_url) -> do_critical (lazy (
 104       try
 105         clients#register client_id client_url;
 106         Hbugs_messages.respond_msg (Client_registered my_own_id) outchan
 107       with Hbugs_broker_registry.Client_already_in id ->
 108         Hbugs_messages.respond_exc "already_registered" id outchan
 109     ))
 110   | Unregister_client client_id -> do_critical (lazy (
 111       if clients#isAuthenticated client_id then begin
 112         clients#unregister client_id;
 113         Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan
 114       end else
 115         Hbugs_messages.respond_exc "forbidden" client_id outchan
 116     ))
 117   | List_tutors client_id -> do_critical (lazy (
 118       if clients#isAuthenticated client_id then begin
 119         Hbugs_messages.respond_msg
 120           (Tutor_list (my_own_id, tutors#index))
 121           outchan
 122       end else
 123         Hbugs_messages.respond_exc "forbidden" client_id outchan
 124     ))
 125   | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
 126       if clients#isAuthenticated client_id then begin
 127         if List.length tutor_ids <> 0 then begin  (* at least one tutor id *)
 128           if List.for_all tutors#exists tutor_ids then begin
 129             clients#subscribe client_id tutor_ids;
 130             Hbugs_messages.respond_msg
 131               (Subscribed (my_own_id, tutor_ids)) outchan
 132           end else  (* required subscription to at least one unexistent tutor *)
 133             let missing_tutors =
 134               List.filter (fun id -> not (tutors#exists id)) tutor_ids
 135             in
 136             Hbugs_messages.respond_exc
 137               "tutor_not_found" (String.concat " " missing_tutors) outchan
 138         end else  (* no tutor id specified *)
 139           Hbugs_messages.respond_exc "no_tutor_specified" "" outchan
 140       end else
 141         Hbugs_messages.respond_exc "forbidden" client_id outchan
 142     ))
 143   | State_change (client_id, new_state) -> do_critical (lazy (
 144       if clients#isAuthenticated client_id then begin
 145         let active_musings = musings#getByClientId client_id in
 146         prerr_endline (sprintf "ACTIVE MUSINGS: %s" (String.concat ", " active_musings));
 147         if List.length active_musings = 0 then
 148           prerr_endline ("No active musings for client " ^ client_id);
 149         let stop_answers =
 150           List.map  (* collect Abort_musing message's responses *)
 151             (fun id ->  (* musing id *)
 152               let tutor = snd (musings#getByMusingId id) in
 153               Hbugs_messages.submit_req
 154                 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
 155             active_musings
 156         in
 157         List.iter musings#unregister active_musings;
 158         let subscriptions = clients#getSubscription client_id in
 159         if List.length subscriptions = 0 then
 160           prerr_endline ("No subscriptions for client " ^ client_id);
 161         let started_musing_ids =
 162           List.map  (* register new musings and collect their ids *)
 163             (fun tutor_id ->
 164               let res =
 165                 Hbugs_messages.submit_req
 166                   ~url:(tutors#getUrl tutor_id)
 167                   (Start_musing (my_own_id, new_state))
 168               in
 169               let musing_id = parse_musing_id res in
 170               musings#register musing_id client_id tutor_id;
 171               musing_id)
 172             subscriptions
 173         in
 174         let stopped_musing_ids = List.map parse_musing_id stop_answers in
 175         Hbugs_messages.respond_msg
 176           (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
 177           outchan
 178       end else
 179         Hbugs_messages.respond_exc "forbidden" client_id outchan
 180     ))
 181
 182   (* messages from tutors *)
 183
 184   | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
 185       try
 186         tutors#register tutor_id tutor_url hint_type dsc;
 187         Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan
 188       with Hbugs_broker_registry.Tutor_already_in id ->
 189         Hbugs_messages.respond_exc "already_registered" id outchan
 190     ))
 191   | Unregister_tutor tutor_id -> do_critical (lazy (
 192       if tutors#isAuthenticated tutor_id then begin
 193         tutors#unregister tutor_id;
 194         Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan
 195       end else
 196         Hbugs_messages.respond_exc "forbidden" tutor_id outchan
 197     ))
 198
 199   | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
 200       if not (tutors#isAuthenticated tutor_id) then begin (* unauthorized *)
 201         Hbugs_messages.respond_exc "forbidden" tutor_id outchan;
 202       end else if not (musings#isActive musing_id) then begin (* too late *)
 203         Hbugs_messages.respond_msg (Too_late (my_own_id, musing_id)) outchan;
 204       end else begin  (* all is ok: autorhized and on time *)
 205         (match result with
 206         | Sorry -> ()
 207         | Eureka hint ->
 208             let client_url =
 209               clients#getUrl (fst (musings#getByMusingId musing_id))
 210             in
 211             let res =
 212               Hbugs_messages.submit_req ~url:client_url (Hint (my_own_id, hint))
 213             in
 214             (match res with
 215             | Wow _ -> () (* ok: client is happy with our hint *)
 216             | unexpected_msg ->
 217                 prerr_endline
 218                   (sprintf
 219                     "Warning: unexpected msg from client: %s\nExpected was: Wow"
 220                     (Hbugs_messages.string_of_msg msg))));
 221         Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan;
 222         musings#unregister musing_id
 223       end
 224     ))
 225
 226   | msg ->  (* unexpected message *)
 227       debug_print "Unknown message!";
 228       Hbugs_messages.respond_exc
 229         "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
 230 in
 231 (*  (* DEBUGGING wrapper around 'handle_msg' *)
 232 let handle_msg outchan =
 233   if debug then
 234     (fun msg -> (* filter handle_msg through a function which dumps input
 235                 messages *)
 236       debug_print (Hbugs_messages.string_of_msg msg);
 237       handle_msg outchan msg)
 238   else
 239     handle_msg outchan
 240 in
 241 *)
 242
 243   (* thread action *)
 244 let callback (req: Http_types.request) outchan =
 245   try
 246     debug_print ("Connection from " ^ req#clientAddr);
 247     debug_print ("Received request: " ^ req#path);
 248     (match req#path with
 249       (* TODO write help message *)
 250     | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
 251     | "/act" ->
 252         let msg = Hbugs_messages.msg_of_string req#body in
 253         handle_msg outchan msg
 254     | "/dump" ->
 255         if debug then
 256           Http_daemon.respond ~body:(dump_registries ()) outchan
 257         else
 258           Http_daemon.respond_error ~code:400 outchan
 259     | _ -> Http_daemon.respond_error ~code:400 outchan);
 260     debug_print "Done!\n"
 261   with
 262   | Http_types.Param_not_found attr_name ->
 263       Hbugs_messages.respond_exc "missing_parameter" attr_name outchan
 264   | exc ->
 265       Hbugs_messages.respond_exc
 266         "uncaught_exception" (Printexc.to_string exc) outchan
 267 in
 268
 269   (* thread who cleans up ancient client/tutor/musing registrations *)
 270 let ragman () =
 271   let delay = 3600.0 in (* 1 hour delay *)
 272   while true do
 273     Thread.delay delay;
 274     List.iter (fun o -> o#purge) registries
 275   done
 276 in
 277
 278   (* start daemon *)
 279 printf "Listening on port %d ...\n" port;
 280 flush stdout;
 281 ignore (Thread.create ragman ());
 282 Http_daemon.start' ~port ~mode:`Thread callback
 283