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