(*
 * 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 ;;

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 "<help> not yet written </help>" 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