X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2Fhbugs%2Fbroker%2Fhbugs_broker.ml;fp=helm%2Fhbugs%2Fbroker%2Fhbugs_broker.ml;h=0000000000000000000000000000000000000000;hp=66dce60f751ee084a06562d6b245ab6733d35f30;hb=869549224eef6278a48c16ae27dd786376082b38;hpb=89262281b6e83bd2321150f81f1a0583645eb0c8 diff --git a/helm/hbugs/broker/hbugs_broker.ml b/helm/hbugs/broker/hbugs_broker.ml deleted file mode 100644 index 66dce60f7..000000000 --- a/helm/hbugs/broker/hbugs_broker.ml +++ /dev/null @@ -1,222 +0,0 @@ -(* - * Copyright (C) 2003: - * Stefano Zacchiroli - * for the HELM Team http://helm.cs.unibo.it/ - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -open Hbugs_types;; -open Printf;; - -let debug = true ;; -let debug_print s = if debug then prerr_endline s ;; - -let daemon_name = "H-Bugs Broker" ;; -let default_port = 49081 ;; -let port_env_var = "HELM_HBUGS_BROKER_PORT" ;; -let port = - try - int_of_string (Sys.getenv port_env_var) - with - | Not_found -> default_port - | Failure "int_of_string" -> - prerr_endline "Warning: invalid port, reverting to default"; - default_port -;; - -exception Unexpected_msg of message;; - -let xml_contype = ("Content-Type", "text/xml") ;; -let return_xml_msg body outchan = - Http_daemon.respond ~headers:[xml_contype] ~body outchan -;; -let return_hbugs_msg msg = return_xml_msg (Hbugs_messages.string_of_msg msg);; -let return_hbugs_exc name value = return_hbugs_msg (Exception (name, value));; -let send_hbugs_req ~url msg = - Hbugs_messages.msg_of_string - (Hbugs_misc.http_post ~body:(Hbugs_messages.string_of_msg msg) url) -;; -let parse_musing_id = function - | Musing_started (_, musing_id) -> musing_id - | Musing_aborted (_, musing_id) -> musing_id - | _ -> assert false -;; - -let do_critical = - let mutex = Mutex.create () in - fun action -> - try - Mutex.lock mutex; let res = Lazy.force action in Mutex.unlock mutex; res - with e -> Mutex.unlock mutex; raise e -;; - -let clients = new Hbugs_broker_registry.clients in -let tutors = new Hbugs_broker_registry.tutors in -let musings = new Hbugs_broker_registry.musings in -let my_own_id = Hbugs_id_generator.new_broker_id () in - -let handle_msg outchan = function - - (* messages from clients *) - | Register_client (client_id, client_url) -> do_critical (lazy ( - debug_print "Register_client"; - try - clients#register client_id client_url; - return_hbugs_msg (Client_registered my_own_id) outchan - with Hbugs_broker_registry.Client_already_in id -> - return_hbugs_exc "already_registered" id outchan - )) - | Unregister_client client_id -> do_critical (lazy ( - debug_print "Unregister_client"; - if clients#isAuthenticated client_id then begin - clients#unregister client_id; - return_hbugs_msg (Client_unregistered my_own_id) outchan - end else - return_hbugs_exc "forbidden" client_id outchan - )) - | List_tutors client_id -> do_critical (lazy ( - debug_print "List_tutors"; - if clients#isAuthenticated client_id then begin - return_hbugs_msg (Tutor_list (my_own_id, tutors#index)) outchan - end else - return_hbugs_exc "forbidden" client_id outchan - )) - | Subscribe (client_id, tutor_ids) -> do_critical (lazy ( - debug_print "Subscribe"; - if clients#isAuthenticated client_id then begin - if List.for_all tutors#exists tutor_ids then begin - clients#subscribe client_id tutor_ids; - return_hbugs_msg (Subscribed (my_own_id, tutor_ids)) outchan - end else (* required subscription to an unexistent tutor *) - let tutor_id = - List.find (fun id -> not (tutors#exists id)) tutor_ids - in - return_hbugs_exc "tutor_not_found" tutor_id outchan - end else - return_hbugs_exc "forbidden" client_id outchan - )) - | State_change (client_id, new_state) -> do_critical (lazy ( - debug_print "State_change"; - if clients#isAuthenticated client_id then begin - let active_musings = musings#getByClientId client_id in - let stop_answers = - List.map (* collect Abort_musing message's responses *) - (fun id -> (* musing id *) - let tutor = snd (musings#getByMusingId id) in - send_hbugs_req - ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id))) - active_musings - in - List.iter musings#unregister active_musings; - let started_musing_ids = - List.map (* register new musings and collect their ids *) - (fun tutor_id -> - let res = - send_hbugs_req - ~url:(tutors#getUrl tutor_id) - (Start_musing (my_own_id, new_state)) - in - let musing_id = parse_musing_id res in - musings#register musing_id client_id tutor_id; - musing_id) - (clients#getSubscription client_id) - in - let stopped_musing_ids = List.map parse_musing_id stop_answers in - return_hbugs_msg - (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids)) - outchan - end else - return_hbugs_exc "forbidden" client_id outchan - )) - - (* messages from tutors *) - | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy ( - debug_print "Register_tutor"; - try - tutors#register tutor_id tutor_url hint_type dsc; - return_hbugs_msg (Tutor_registered my_own_id) outchan - with Hbugs_broker_registry.Tutor_already_in id -> - return_hbugs_exc "already_registered" id outchan - )) - | Unregister_tutor tutor_id -> do_critical (lazy ( - debug_print "Unregister_tutor"; - if tutors#isAuthenticated tutor_id then begin - tutors#unregister tutor_id; - return_hbugs_msg (Tutor_unregistered my_own_id) outchan - end else - return_hbugs_exc "forbidden" tutor_id outchan - )) - | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy ( - debug_print "Musing_completed"; - if tutors#isAuthenticated tutor_id then begin - (match result with - | Sorry -> () - | Eureka extras -> - let res = - let hint = (* TODO decidere la hint *) "hint!!!!" in - let url = - clients#getUrl (fst (musings#getByMusingId musing_id)) - in - send_hbugs_req ~url (Hint (my_own_id, hint)) - in - ignore res (* TODO mi interessa la risposta? *) - ); - return_hbugs_msg (Thanks (my_own_id, musing_id)) outchan; - musings#unregister musing_id - end else - return_hbugs_exc "forbidden" tutor_id outchan - )) - - | msg -> (* unexpected message *) - debug_print "Unknown message!"; - return_hbugs_msg - (Exception ("Unexpected_msg", Hbugs_messages.string_of_msg msg)) - outchan -in - - (* thread action *) -let callback (req: Http_types.request) outchan = - try - debug_print ("Connection from " ^ req#clientAddr); - debug_print ("Received request: " ^ req#path); - (match req#path with - (* TODO write help message *) - | "/help" -> return_xml_msg " not yet written " outchan - | "/act" -> handle_msg outchan (Hbugs_messages.msg_of_string req#body) - | _ -> Http_daemon.respond_error ~code:400 outchan); - debug_print "Done!\n" - with - | Http_types.Param_not_found attr_name -> - return_hbugs_exc "missing_parameter" attr_name outchan - | exc -> - return_hbugs_exc "uncaught_exception" (Printexc.to_string exc) outchan -in - -(* TODO aggiungere lo spazzino che elimina i client/tutor/computation che non si -fanno sentire da troppo tempo ... *) - (* start daemon *) -printf "Listening on port %d ...\n" port; -flush stdout; -Http_daemon.start' ~port ~mode:`Thread callback -