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
  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
  48 exception Unexpected_msg of message;;
  49
  50 let xml_contype = ("Content-Type", "text/xml") ;;
  51 let return_xml_msg body outchan =
  52   Http_daemon.respond ~headers:[xml_contype] ~body outchan
  53 ;;
  54 let return_hbugs_msg msg = return_xml_msg (Hbugs_messages.string_of_msg msg);;
  55 let return_hbugs_exc name value = return_hbugs_msg (Exception (name, value));;
  56 let send_hbugs_req ~url msg =
  57   Hbugs_messages.msg_of_string
  58     (Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg msg) url)
  59 ;;
  60 let parse_musing_id = function
  61   | Musing_started (_, musing_id) -> musing_id
  62   | Musing_aborted (_, musing_id) -> musing_id
  63   | _ -> assert false
  64 ;;
  65
  66 let do_critical =
  67   let mutex = Mutex.create () in
  68   fun action ->
  69     try
  70       Mutex.lock mutex; let res = Lazy.force action in Mutex.unlock mutex; res
  71     with e -> Mutex.unlock mutex; raise e
  72 ;;
  73
  74 let clients = new Hbugs_broker_registry.clients in
  75 let tutors = new Hbugs_broker_registry.tutors in
  76 let musings = new Hbugs_broker_registry.musings in
  77 let my_own_id = Hbugs_id_generator.new_broker_id () in
  78
  79 let handle_msg outchan = function
  80
  81   (* messages from clients *)
  82   | Register_client (client_id, client_url) -> do_critical (lazy (
  83       debug_print "Register_client";
  84       try
  85         clients#register client_id client_url;
  86         return_hbugs_msg (Client_registered my_own_id) outchan
  87       with Hbugs_broker_registry.Client_already_in id ->
  88         return_hbugs_exc "already_registered" id outchan
  89     ))
  90   | Unregister_client client_id -> do_critical (lazy (
  91       debug_print "Unregister_client";
  92       if clients#isAuthenticated client_id then begin
  93         clients#unregister client_id;
  94         return_hbugs_msg (Client_unregistered my_own_id) outchan
  95       end else
  96         return_hbugs_exc "forbidden" client_id outchan
  97     ))
  98   | List_tutors client_id -> do_critical (lazy (
  99       debug_print "List_tutors";
 100       if clients#isAuthenticated client_id then begin
 101         return_hbugs_msg (Tutor_list (my_own_id, tutors#index)) outchan
 102       end else
 103         return_hbugs_exc "forbidden" client_id outchan
 104     ))
 105   | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
 106       debug_print "Subscribe";
 107       if clients#isAuthenticated client_id then begin
 108         if List.for_all tutors#exists tutor_ids then begin
 109           clients#subscribe client_id tutor_ids;
 110           return_hbugs_msg (Subscribed (my_own_id, tutor_ids)) outchan
 111         end else  (* required subscription to an unexistent tutor *)
 112           let tutor_id =
 113             List.find (fun id -> not (tutors#exists id)) tutor_ids
 114           in
 115           return_hbugs_exc "tutor_not_found" tutor_id outchan
 116       end else
 117         return_hbugs_exc "forbidden" client_id outchan
 118     ))
 119   | State_change (client_id, new_state) -> do_critical (lazy (
 120       debug_print "State_change";
 121       if clients#isAuthenticated client_id then begin
 122         let active_musings = musings#getByClientId client_id in
 123         let stop_answers =
 124           List.map  (* collect Abort_musing message's responses *)
 125             (fun id ->  (* musing id *)
 126               let tutor = snd (musings#getByMusingId id) in
 127               send_hbugs_req
 128                 ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
 129             active_musings
 130         in
 131         List.iter musings#unregister active_musings;
 132         let started_musing_ids =
 133           List.map  (* register new musings and collect their ids *)
 134             (fun tutor_id ->
 135               let res =
 136                 send_hbugs_req
 137                   ~url:(tutors#getUrl tutor_id)
 138                   (Start_musing (my_own_id, new_state))
 139               in
 140               let musing_id = parse_musing_id res in
 141               musings#register musing_id client_id tutor_id;
 142               musing_id)
 143             (clients#getSubscription client_id)
 144         in
 145         let stopped_musing_ids = List.map parse_musing_id stop_answers in
 146         return_hbugs_msg
 147           (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
 148           outchan
 149       end else
 150         return_hbugs_exc "forbidden" client_id outchan
 151     ))
 152
 153   (* messages from tutors *)
 154   | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
 155       debug_print "Register_tutor";
 156       try
 157         tutors#register tutor_id tutor_url hint_type dsc;
 158         return_hbugs_msg (Tutor_registered my_own_id) outchan
 159       with Hbugs_broker_registry.Tutor_already_in id ->
 160         return_hbugs_exc "already_registered" id outchan
 161     ))
 162   | Unregister_tutor tutor_id -> do_critical (lazy (
 163       debug_print "Unregister_tutor";
 164       if tutors#isAuthenticated tutor_id then begin
 165         tutors#unregister tutor_id;
 166         return_hbugs_msg (Tutor_unregistered my_own_id) outchan
 167       end else
 168         return_hbugs_exc "forbidden" tutor_id outchan
 169     ))
 170   | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
 171       debug_print "Musing_completed";
 172       if tutors#isAuthenticated tutor_id then begin
 173         (match result with
 174         | Sorry -> ()
 175         | Eureka extras ->
 176             let res =
 177               let hint = (* TODO decidere la hint *) "hint!!!!" in
 178               let url =
 179                 clients#getUrl (fst (musings#getByMusingId musing_id))
 180               in
 181               send_hbugs_req ~url (Hint (my_own_id, hint))
 182             in
 183             ignore res  (* TODO mi interessa la risposta? *)
 184         );
 185         return_hbugs_msg (Thanks (my_own_id, musing_id)) outchan;
 186         musings#unregister musing_id
 187       end else
 188         return_hbugs_exc "forbidden" tutor_id outchan
 189     ))
 190
 191   | msg ->  (* unexpected message *)
 192       debug_print "Unknown message!";
 193       return_hbugs_msg
 194         (Exception ("Unexpected_msg", Hbugs_messages.string_of_msg msg))
 195         outchan
 196 in
 197
 198   (* thread action *)
 199 let callback (req: Http_types.request) outchan =
 200   try
 201     debug_print ("Connection from " ^ req#clientAddr);
 202     debug_print ("Received request: " ^ req#path);
 203     (match req#path with
 204       (* TODO write help message *)
 205     | "/help" -> return_xml_msg "<help> not yet written </help>" outchan
 206     | "/act" -> handle_msg outchan (Hbugs_messages.msg_of_string req#body)
 207     | _ -> Http_daemon.respond_error ~code:400 outchan);
 208     debug_print "Done!\n"
 209   with
 210   | Http_types.Param_not_found attr_name ->
 211       return_hbugs_exc "missing_parameter" attr_name outchan
 212   | exc ->
 213       return_hbugs_exc "uncaught_exception" (Printexc.to_string exc) outchan
 214 in
 215
 216 (* TODO aggiungere lo spazzino che elimina i client/tutor/computation che non si
 217 fanno sentire da troppo tempo ... *)
 218     (* start daemon *)
 219 printf "Listening on port %d ...\n" port;
 220 flush stdout;
 221 Http_daemon.start' ~port ~mode:`Thread callback
 222