helm/hbugs/broker/hbugs_broker.ml

   1 (*
   2  *  Copyright (C) 2003, HELM Team.
   3  *
   4  *  This file is part of HELM, an Hypertextual, Electronic
   5  *  Library of Mathematics, developed at the Computer Science
   6  *  Department, University of Bologna, Italy.
   7  *
   8  *  HELM is free software; you can redistribute it and/or
   9  *  modify it under the terms of the GNU General Public License
  10  *  as published by the Free Software Foundation; either version 2
  11  *  of the License, or (at your option) any later version.
  12  *
  13  *  HELM is distributed in the hope that it will be useful,
  14  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  *  GNU General Public License for more details.
  17  *
  18  *  You should have received a copy of the GNU General Public License
  19  *  along with HELM; if not, write to the Free Software
  20  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21  *  MA  02111-1307, USA.
  22  *
  23  *  For details, see the HELM World-Wide-Web page,
  24  *  http://cs.unibo.it/helm/.
  25  *)
  26
  27 open Hbugs_types;;
  28 open Printf;;
  29
  30 let debug = true ;;
  31 let debug_print s = if debug then prerr_endline s ;;
  32
  33 let daemon_name = "H-Bugs Broker" ;;
  34 let default_port = 49081 ;;
  35 let port_env_var = "HELM_HBUGS_BROKER_PORT" ;;
  36 let port =
  37   try
  38     int_of_string (Sys.getenv port_env_var)
  39   with
  40   | Not_found -> default_port
  41   | Failure "int_of_string" ->
  42       prerr_endline "Warning: invalid port, reverting to default";
  43       default_port
  44 ;;
  45
  46 exception Unexpected_msg of message;;
  47
  48 let xml_contype = ("Content-Type", "text/xml") ;;
  49 let return_xml_msg body outchan =
  50   Http_daemon.respond ~headers:[xml_contype] ~body outchan
  51 ;;
  52 let return_hbugs_msg msg = return_xml_msg (Hbugs_messages.string_of_msg msg);;
  53 let return_hbugs_exc name value = return_hbugs_msg (Exception (name, value));;
  54 let send_hbugs_req ~url msg =
  55   Hbugs_messages.msg_of_string
  56     (Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg msg) url)
  57 ;;
  58 let parse_musing_id = function
  59   | Musing_started (_, musing_id) -> musing_id
  60   | Musing_aborted (_, musing_id) -> musing_id
  61   | _ -> assert false
  62 ;;
  63
  64 let do_critical =
  65   let mutex = Mutex.create () in
  66   fun action ->
  67     try
  68       Mutex.lock mutex; let res = Lazy.force action in Mutex.unlock mutex; res
  69     with e -> Mutex.unlock mutex; raise e
  70 ;;
  71
  72 let clients = new Hbugs_broker_registry.clients in
  73 let tutors = new Hbugs_broker_registry.tutors in
  74 let musings = new Hbugs_broker_registry.musings in
  75 let my_own_id = Hbugs_id_generator.new_broker_id () in
  76
  77 let handle_msg outchan = function
  78
  79   (* messages from clients *)
  80   | Register_client (client_id, client_url) -> do_critical (lazy (
  81       debug_print "Register_client";
  82       try
  83         clients#register client_id client_url;
  84         return_hbugs_msg (Client_registered my_own_id) outchan
  85       with Hbugs_broker_registry.Client_already_in id ->
  86         return_hbugs_exc "already_registered" id outchan
  87     ))
  88   | Unregister_client client_id -> do_critical (lazy (
  89       debug_print "Unregister_client";
  90       if clients#isAuthenticated client_id then begin
  91         clients#unregister client_id;
  92         return_hbugs_msg (Client_unregistered my_own_id) outchan
  93       end else
  94         return_hbugs_exc "forbidden" client_id outchan
  95     ))
  96   | List_tutors client_id -> do_critical (lazy (
  97       debug_print "List_tutors";
  98       if clients#isAuthenticated client_id then begin
  99         return_hbugs_msg (Tutor_list (my_own_id, tutors#index)) outchan
 100       end else
 101         return_hbugs_exc "forbidden" client_id outchan
 102     ))
 103   | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
 104       debug_print "Subscribe";
 105       if clients#isAuthenticated client_id then begin
 106         if List.for_all tutors#exists tutor_ids then begin
 107           clients#subscribe client_id tutor_ids;
 108           return_hbugs_msg (Subscribed (my_own_id, tutor_ids)) outchan
 109         end else  (* required subscription to an unexistent tutor *)
 110           let tutor_id =
 111             List.find (fun id -> not (tutors#exists id)) tutor_ids
 112           in
 113           return_hbugs_exc "tutor_not_found" tutor_id outchan
 114       end else
 115         return_hbugs_exc "forbidden" client_id outchan
 116     ))
 117   | State_change (client_id, new_state) -> do_critical (lazy (
 118       debug_print "State_change";
 119       if clients#isAuthenticated client_id then begin
 120         let active_musings = musings#getByClientId client_id in
 121         let stop_answers =
 122           List.map  (* collect Abort_musing message's responses *)
 123             (fun id ->  (* musing id *)
 124               let tutor = snd (musings#getByMusingId id) in
 125               send_hbugs_req
 126                 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
 127             active_musings
 128         in
 129         List.iter musings#unregister active_musings;
 130         let started_musing_ids =
 131           List.map  (* register new musings and collect their ids *)
 132             (fun tutor_id ->
 133               let res =
 134                 send_hbugs_req
 135                   ~url:(tutors#getUrl tutor_id)
 136                   (Start_musing (my_own_id, new_state))
 137               in
 138               let musing_id = parse_musing_id res in
 139               musings#register musing_id client_id tutor_id;
 140               musing_id)
 141             (clients#getSubscription client_id)
 142         in
 143         let stopped_musing_ids = List.map parse_musing_id stop_answers in
 144         return_hbugs_msg
 145           (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
 146           outchan
 147       end else
 148         return_hbugs_exc "forbidden" client_id outchan
 149     ))
 150
 151   (* messages from tutors *)
 152   | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
 153       debug_print "Register_tutor";
 154       try
 155         tutors#register tutor_id tutor_url hint_type dsc;
 156         return_hbugs_msg (Tutor_registered my_own_id) outchan
 157       with Hbugs_broker_registry.Tutor_already_in id ->
 158         return_hbugs_exc "already_registered" id outchan
 159     ))
 160   | Unregister_tutor tutor_id -> do_critical (lazy (
 161       debug_print "Unregister_tutor";
 162       if tutors#isAuthenticated tutor_id then begin
 163         tutors#unregister tutor_id;
 164         return_hbugs_msg (Tutor_unregistered my_own_id) outchan
 165       end else
 166         return_hbugs_exc "forbidden" tutor_id outchan
 167     ))
 168   | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
 169       debug_print "Musing_completed";
 170       if tutors#isAuthenticated tutor_id then begin
 171         (match result with
 172         | Sorry -> ()
 173         | Eureka extras ->
 174             let res =
 175               let hint = (* TODO decidere la hint *) "hint!!!!" in
 176               let url =
 177                 clients#getUrl (fst (musings#getByMusingId musing_id))
 178               in
 179               send_hbugs_req ~url (Hint (my_own_id, hint))
 180             in
 181             ignore res  (* TODO mi interessa la risposta? *)
 182         );
 183         return_hbugs_msg (Thanks (my_own_id, musing_id)) outchan;
 184         musings#unregister musing_id
 185       end else
 186         return_hbugs_exc "forbidden" tutor_id outchan
 187     ))
 188
 189   | msg ->  (* unexpected message *)
 190       debug_print "Unknown message!";
 191       return_hbugs_msg
 192         (Exception ("Unexpected_msg", Hbugs_messages.string_of_msg msg))
 193         outchan
 194 in
 195
 196   (* thread action *)
 197 let callback (req: Http_types.request) outchan =
 198   try
 199     debug_print ("Connection from " ^ req#clientAddr);
 200     debug_print ("Received request: " ^ req#path);
 201     (match req#path with
 202       (* TODO write help message *)
 203     | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
 204     | "/act" -> handle_msg outchan (Hbugs_messages.msg_of_string req#body)
 205     | _ -> Http_daemon.respond_error ~code:400 outchan);
 206     debug_print "Done!\n"
 207   with
 208   | Http_types.Param_not_found attr_name ->
 209       return_hbugs_exc "missing_parameter" attr_name outchan
 210   | exc ->
 211       return_hbugs_exc "uncaught_exception" (Printexc.to_string exc) outchan
 212 in
 213
 214 (* TODO aggiungere lo spazzino che elimina i client/tutor/computation che non si
 215 fanno sentire da troppo tempo ... *)
 216     (* start daemon *)
 217 printf "Listening on port %d ...\n" port;
 218 flush stdout;
 219 Http_daemon.start' ~port ~mode:`Thread callback
 220