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