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