+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * 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 ;;
-Http_common.debug := false;;
-
-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
-;;
-let usage_string = "HBugs Broker: usage string not yet written :-(";;
-
-exception Unexpected_msg of message;;
-
-let return_xml_msg body outchan =
- Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan
-;;
-let parse_musing_id = function
- | Musing_started (_, musing_id) ->
- prerr_endline ("#### Started musing ID: " ^ musing_id);
- musing_id
- | Musing_aborted (_, musing_id) -> musing_id
- | msg ->
- prerr_endline (sprintf "Assertion failed, received msg: %s"
- (Hbugs_messages.string_of_msg msg));
- assert false
-;;
-
-let do_critical =
- let mutex = Mutex.create () in
- fun action ->
- try
-(* debug_print "Acquiring lock ..."; *)
- Mutex.lock mutex;
-(* debug_print "Lock Acquired!"; *)
- let res = Lazy.force action in
-(* debug_print "Releaseing lock ..."; *)
- Mutex.unlock mutex;
-(* debug_print "Lock released!"; *)
- res
- with e -> Mutex.unlock mutex; raise e
-;;
-
- (* registries *)
-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 registries =
- [ (clients :> Hbugs_broker_registry.registry);
- (tutors :> Hbugs_broker_registry.registry);
- (musings :> Hbugs_broker_registry.registry) ]
-in
-
-let my_own_id = Hbugs_id_generator.new_broker_id () in
-
- (* debugging: dump broker internal status, used by '/dump' method *)
-let dump_registries () =
- assert debug;
- String.concat "\n" (List.map (fun o -> o#dump) registries)
-in
-
-let handle_msg outchan msg =
- (* messages from clients *)
- (match msg with
-
- | Help ->
- Hbugs_messages.respond_msg (Usage usage_string) outchan
- | Register_client (client_id, client_url) -> do_critical (lazy (
- try
- clients#register client_id client_url;
- Hbugs_messages.respond_msg (Client_registered my_own_id) outchan
- with Hbugs_broker_registry.Client_already_in id ->
- Hbugs_messages.respond_exc "already_registered" id outchan
- ))
- | Unregister_client client_id -> do_critical (lazy (
- if clients#isAuthenticated client_id then begin
- clients#unregister client_id;
- Hbugs_messages.respond_msg (Client_unregistered my_own_id) outchan
- end else
- Hbugs_messages.respond_exc "forbidden" client_id outchan
- ))
- | List_tutors client_id -> do_critical (lazy (
- if clients#isAuthenticated client_id then begin
- Hbugs_messages.respond_msg
- (Tutor_list (my_own_id, tutors#index))
- outchan
- end else
- Hbugs_messages.respond_exc "forbidden" client_id outchan
- ))
- | Subscribe (client_id, tutor_ids) -> do_critical (lazy (
- if clients#isAuthenticated client_id then begin
- if List.length tutor_ids <> 0 then begin (* at least one tutor id *)
- if List.for_all tutors#exists tutor_ids then begin
- clients#subscribe client_id tutor_ids;
- Hbugs_messages.respond_msg
- (Subscribed (my_own_id, tutor_ids)) outchan
- end else (* required subscription to at least one unexistent tutor *)
- let missing_tutors =
- List.filter (fun id -> not (tutors#exists id)) tutor_ids
- in
- Hbugs_messages.respond_exc
- "tutor_not_found" (String.concat " " missing_tutors) outchan
- end else (* no tutor id specified *)
- Hbugs_messages.respond_exc "no_tutor_specified" "" outchan
- end else
- Hbugs_messages.respond_exc "forbidden" client_id outchan
- ))
- | State_change (client_id, new_state) -> do_critical (lazy (
- if clients#isAuthenticated client_id then begin
- let active_musings = musings#getByClientId client_id in
- prerr_endline (sprintf "ACTIVE MUSINGS: %s" (String.concat ", " active_musings));
- if List.length active_musings = 0 then
- prerr_endline ("No active musings for client " ^ client_id);
- prerr_endline "CSC: State change!!!" ;
- let stop_answers =
- List.map (* collect Abort_musing message's responses *)
- (fun id -> (* musing id *)
- let tutor = snd (musings#getByMusingId id) in
- Hbugs_messages.submit_req
- ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id)))
- active_musings
- in
- let stopped_musing_ids = List.map parse_musing_id stop_answers in
- List.iter musings#unregister active_musings;
- (match new_state with
- | Some new_state -> (* need to start new musings *)
- let subscriptions = clients#getSubscription client_id in
- if List.length subscriptions = 0 then
- prerr_endline ("No subscriptions for client " ^ client_id);
- let started_musing_ids =
- List.map (* register new musings and collect their ids *)
- (fun tutor_id ->
- let res =
- Hbugs_messages.submit_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)
- subscriptions
- in
- Hbugs_messages.respond_msg
- (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids))
- outchan
- | None -> (* no need to start new musings *)
- Hbugs_messages.respond_msg
- (State_accepted (my_own_id, stopped_musing_ids, []))
- outchan)
- end else
- Hbugs_messages.respond_exc "forbidden" client_id outchan
- ))
-
- (* messages from tutors *)
-
- | Register_tutor (tutor_id, tutor_url, hint_type, dsc) -> do_critical (lazy (
- try
- tutors#register tutor_id tutor_url hint_type dsc;
- Hbugs_messages.respond_msg (Tutor_registered my_own_id) outchan
- with Hbugs_broker_registry.Tutor_already_in id ->
- Hbugs_messages.respond_exc "already_registered" id outchan
- ))
- | Unregister_tutor tutor_id -> do_critical (lazy (
- if tutors#isAuthenticated tutor_id then begin
- tutors#unregister tutor_id;
- Hbugs_messages.respond_msg (Tutor_unregistered my_own_id) outchan
- end else
- Hbugs_messages.respond_exc "forbidden" tutor_id outchan
- ))
-
- | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy (
- if not (tutors#isAuthenticated tutor_id) then begin (* unauthorized *)
- Hbugs_messages.respond_exc "forbidden" tutor_id outchan;
- end else if not (musings#isActive musing_id) then begin (* too late *)
- Hbugs_messages.respond_msg (Too_late (my_own_id, musing_id)) outchan;
- end else begin (* all is ok: autorhized and on time *)
- (match result with
- | Sorry -> ()
- | Eureka hint ->
- let client_url =
- clients#getUrl (fst (musings#getByMusingId musing_id))
- in
- let res =
- Hbugs_messages.submit_req ~url:client_url (Hint (my_own_id, hint))
- in
- (match res with
- | Wow _ -> () (* ok: client is happy with our hint *)
- | unexpected_msg ->
- prerr_endline
- (sprintf
- "Warning: unexpected msg from client: %s\nExpected was: Wow"
- (Hbugs_messages.string_of_msg msg))));
- Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan;
- musings#unregister musing_id
- end
- ))
-
- | msg -> (* unexpected message *)
- debug_print "Unknown message!";
- Hbugs_messages.respond_exc
- "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan)
-in
-(* (* DEBUGGING wrapper around 'handle_msg' *)
-let handle_msg outchan =
- if debug then
- (fun msg -> (* filter handle_msg through a function which dumps input
- messages *)
- debug_print (Hbugs_messages.string_of_msg msg);
- handle_msg outchan msg)
- else
- handle_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 "<help> not yet written </help>" outchan
- | "/act" ->
- let msg = Hbugs_messages.msg_of_string req#body in
- handle_msg outchan msg
- | "/dump" ->
- if debug then
- Http_daemon.respond ~body:(dump_registries ()) outchan
- else
- Http_daemon.respond_error ~code:400 outchan
- | _ -> Http_daemon.respond_error ~code:400 outchan);
- debug_print "Done!\n"
- with
- | Http_types.Param_not_found attr_name ->
- Hbugs_messages.respond_exc "missing_parameter" attr_name outchan
- | exc ->
- Hbugs_messages.respond_exc
- "uncaught_exception" (Printexc.to_string exc) outchan
-in
-
- (* thread who cleans up ancient client/tutor/musing registrations *)
-let ragman () =
- let delay = 3600.0 in (* 1 hour delay *)
- while true do
- Thread.delay delay;
- List.iter (fun o -> o#purge) registries
- done
-in
-
- (* start daemon *)
-printf "Listening on port %d ...\n" port;
-flush stdout;
-ignore (Thread.create ragman ());
-Http_daemon.start' ~port ~mode:`Thread callback
-
projects / helm.git / blobdiff