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