(* $Id: finder_daemon.ml 1277 2009-10-13 00:03:45Z gerd $ *)

(* This is a RPC server built from the Netplex and RPC components.
 * It is configured in the netplex.cfg file.
 * Note: start program with option "-conf netplex.cfg"
 *
 * This program iterates through the directories every time a search query
 * is solved. One can imagine to improve that, but this is only a simple
 * example without too much optimization.
 *)

(**********************************************************************)
(* The "find" procedure                                               *)
(**********************************************************************)

let proc_find root_dir searched_name =
  
  let rec iterate_dir dir =
    let f = Unix.opendir dir in
    try
      let r = iterate_next dir f in
      Unix.closedir f;
      r
    with
      | End_of_file ->
	  Unix.closedir f;
	  None
      | Unix.Unix_error((Unix.EACCES | Unix.EPERM), _, _) ->
	  (* ignore these *)
	  Unix.closedir f;
	  None
      | error ->
	  Unix.closedir f;
	  raise error

  and iterate_next dir f =
    let file = Unix.readdir f in
    if file <> "." && file <> ".." then (
      let fullname = Filename.concat dir file in
      if file = searched_name then
	Some fullname
      else (
	try
	  let s = Unix.lstat fullname in
	  if s.Unix.st_kind = Unix.S_DIR then
	    let r = iterate_dir fullname in
	    match r with
	      | None -> iterate_next dir f
	      | Some _ -> r
	  else
	    iterate_next dir f
	with
	  | Unix.Unix_error(_,_,_) ->  (* lstat error *)
	      (* ignore *)
	      iterate_next dir f
      )
    )
    else
      iterate_next dir f

  in

  Netplex_sharedvar.set_value "finder.lastquery" searched_name;
  (* Make the last query globally accessible. This is an example how to use
     a plugin only - set_value is not very efficient.
   *)

  match iterate_dir root_dir with
    | None -> `not_found
    | Some fullname -> `found fullname
;;


let proc_lastquery () =
  match Netplex_sharedvar.get_value "finder.lastquery" with
    | None ->
	""
    | Some v ->
	v
;;

(**********************************************************************)
(* Create the RPC server                                              *)
(**********************************************************************)

let configure cf addr =
  let root_dir =
    try
      cf # string_param (cf # resolve_parameter addr "root_dir")
    with
      | Not_found ->
	  failwith "Required parameter root_dir is missing!" in
  root_dir
;;


let setup srv root_dir =
  (* Bind the RPC's: *)
  Finder_service_srv.Finder.V1.bind 
    ~proc_ping:(fun () -> ())
    ~proc_find:(proc_find root_dir)
    ~proc_lastquery:(proc_lastquery)
    ~proc_shutdown:Netplex_cenv.system_shutdown
    srv;
  (* Limit client queries to 1000 bytes: *)
  Rpc_server.set_session_filter 
    srv
    (fun _ -> `Accept_limit_length(1000, `Reject))
;;


let win32_debug_gc = ref false
let debug_fd = ref false


let start() =
  let (opt_list, cmdline_cfg) = Netplex_main.args() in

  let use_mt = ref false in

  let opt_list' =
    [ "-mt", Arg.Set use_mt,
      "  Use multi-threading instead of multi-processing";
      
      "-debug", Arg.String (fun s -> Netlog.Debug.enable_module s),
      "<module>  Enable debug messages for <module>";

      "-debug-all", Arg.Unit (fun () -> Netlog.Debug.enable_all()),
      "  Enable all debug messages";

      "-debug-list", Arg.Unit (fun () -> 
				 List.iter print_endline (Netlog.Debug.names());
				 exit 0),
      "  Show possible modules for -debug, then exit";

      "-debug-win32", Arg.Unit (fun () -> 
				  win32_debug_gc := true;
				  Netsys_win32.Debug.debug_c_wrapper true),
      "  Special debug log of Win32 wrapper";

      "-debug-fd", Arg.Unit(fun () -> 
			      Netlog.Debug.enable_fd_tracking := true;
			      debug_fd := true;      
			   ),
      "  Special debugging of file descriptors";
   ] @ opt_list in

  Arg.parse
    opt_list'
    (fun s -> raise (Arg.Bad ("Don't know what to do with: " ^ s)))
    "usage: netplex [options]";

  if Sys.os_type = "Win32" && not !use_mt then
    failwith "For Win32 multi-processing is unsupported. Use -mt switch";

  let parallelizer =
    if !use_mt then
      Netplex_mt.mt()     (* multi-threading *)
    else
      Netplex_mp.mp() in  (* multi-processing *)
  let finder_factory =
    Rpc_netplex.rpc_factory
      ~configure
      ~name:"finder"
      ~setup
      ~hooks:(fun _ ->
	      object(self)
		inherit Netplex_kit.empty_processor_hooks() 
		method post_add_hook _ ctrl = 
		  ctrl # add_plugin Netplex_sharedvar.plugin
		method post_start_hook _ =
		  let _cr_flag = 
		    Netplex_sharedvar.create_var "finder.lastquery" in
		  ()
	      end
	     )
      () in
  Netplex_main.startup
    parallelizer
    Netplex_log.logger_factories   (* allow all built-in logging styles *)
    Netplex_workload.workload_manager_factories (* ... all ways of workload management *)
    [ finder_factory ]           (* make this service type available *)
    cmdline_cfg
;;

Netsys_signal.init();
start();;

if !debug_fd then
  List.iter prerr_endline (Netlog.Debug.fd_table());;

let () =  (* debugging: check that all resources are freed *)
  if !win32_debug_gc then (
    for k = 1 to 10 do
      Gc.full_major();
      Netsys_win32.gc_proxy()
    done
  )
;;