<commit_before>(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "hack" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

open Core
open Sys_utils
open ServerEnv
open ServerUtils
open Utils

exception State_not_found

let sprintf = Printf.sprintf

(*****************************************************************************)
(* Main initialization *)
(*****************************************************************************)

module MainInit : sig
  val go:
    ServerArgs.options ->
    (unit -> env) ->    (* init function to run while we have init lock *)
    env
end = struct
  let grab_init_lock root =
    ignore(Lock.grab (ServerFiles.init_file root))

  let release_init_lock root =
    ignore(Lock.release (ServerFiles.init_file root))

  let wakeup_client oc msg =
    Option.iter oc
      ~f:(fun oc ->
          try
            output_string oc (msg ^ "\n");
            flush oc
          with _ ->
            (* In case the client don't care... *)
            ())

  let close_waiting_channel oc =
    Option.iter oc
      ~f:(fun oc ->
          try Unix.close (Unix.descr_of_out_channel oc)
          with exn -> Printf.eprintf "Close: %S\n%!" (Printexc.to_string exn))

  (* This code is only executed when the options --check is NOT present *)
  let go options init_fun =
    let waiting_channel =
      Option.map
        (ServerArgs.waiting_client options)
        ~f:Handle.to_out_channel in
    let root = ServerArgs.root options in
    let t = Unix.gettimeofday () in
    Hh_logger.log "Initializing Server (This might take some time)";
    grab_init_lock root;
    wakeup_client waiting_channel "starting";
    (* note: we only run periodical tasks on the root, not extras *)
    ServerIdle.init root;
    let env = init_fun () in
    release_init_lock root;
    Hh_logger.log "Server is READY";
    wakeup_client waiting_channel "ready";
    let t' = Unix.gettimeofday () in
    Hh_logger.log "Took %f seconds to initialize." (t' -. t);
    close_waiting_channel waiting_channel;
    env
end

module type SERVER_PROGRAM = sig
  val preinit : unit -> unit
  val init : genv -> env -> env
  val run_once_and_exit : genv -> env -> unit
  val should_recheck : Relative_path.t -> bool
  (* filter and relativize updated file paths *)
  val process_updates : genv -> env -> SSet.t -> Relative_path.Set.t
  val recheck: genv -> env -> Relative_path.Set.t -> env
  val post_recheck_hook: genv -> env -> env -> Relative_path.Set.t -> unit
  val parse_options: unit -> ServerArgs.options
  val get_watch_paths: ServerArgs.options -> Path.t list
  val name: string
  val config_filename : unit -> Relative_path.t
  val load_config : unit -> ServerConfig.t
  val validate_config : genv -> bool
  val handle_client : genv -> env -> (in_channel * out_channel) -> unit
  (* This is a hack for us to save / restore the global state that is not
   * already captured by ServerEnv *)
  val marshal : out_channel -> unit
  val unmarshal : in_channel -> unit
end

module Program : SERVER_PROGRAM =
  struct
    let name = "hh_server"

    let config_filename_ =
      Relative_path.concat Relative_path.Root ".hhconfig"

    let config_filename () = config_filename_

    let load_config () = ServerConfig.load config_filename_

    let validate_config genv =
      let new_config = load_config () in
      (* This comparison can eventually be made more complex; we may not always
       * need to restart hh_server, e.g. changing the path to the load script
       * is immaterial*)
      genv.config = new_config

    let handle_client (genv:ServerEnv.genv) (env:ServerEnv.env) client =
      ServerCommand.handle genv env client

    let preinit () =
      HackSearchService.attach_hooks ();
      (* Force hhi files to be extracted and their location saved before workers
       * fork, so everyone can know about the same hhi path. *)
      ignore (Hhi.get_hhi_root());
      if not Sys.win32 then
        ignore @@
        Sys.signal Sys.sigusr1 (Sys.Signal_handle Typing.debug_print_last_pos)

    let make_next_files dir =
      let php_next_files = Find.make_next_files FindUtils.is_php dir in
      let js_next_files = Find.make_next_files FindUtils.is_js dir in
      fun () -> php_next_files () @ js_next_files ()

    let stamp_file = Filename.concat GlobalConfig.tmp_dir "stamp"
    let touch_stamp () =
      Sys_utils.mkdir_no_fail (Filename.dirname stamp_file);
      Sys_utils.with_umask
        0o111
        (fun () ->
         (* Open and close the file to set its mtime. Don't use the Unix.utimes
          * function since that will fail if the stamp file doesn't exist. *)
         close_out (open_out stamp_file)
        )
    let touch_stamp_errors l1 l2 =
      (* We don't want to needlessly touch the stamp file if the error list is
       * the same and nothing has changed, but we also don't want to spend a ton
       * of time comparing huge lists of errors over and over (i.e., grind to a
       * halt in the cases when there are thousands of errors). So we cut off
       * the comparison at an arbitrary point. *)
      let rec length_greater_than n = function
        | [] -> false
        | _ when n = 0 -> true
        | _::l -> length_greater_than (n-1) l in
      if length_greater_than 5 l1 || length_greater_than 5 l2 || l1 <> l2
      then touch_stamp ()

    let init genv env =
      let module RP = Relative_path in
      let root = ServerArgs.root genv.options in
      let hhi_root = Hhi.get_hhi_root () in
      let next_files_hhi =
        compose (List.map ~f:(RP.create RP.Hhi)) (make_next_files hhi_root) in
      let next_files_root =
        compose (List.map ~f:(RP.create RP.Root)) (make_next_files root)
      in
      let next_files = fun () ->
        match next_files_hhi () with
        | [] -> next_files_root ()
        | x -> x in
      let env = ServerInit.init genv env next_files in
      touch_stamp ();
      env

    let run_once_and_exit genv env =
      ServerError.print_errorl
        (ServerArgs.json_mode genv.options)
        (List.map env.errorl Errors.to_absolute) stdout;
      match ServerArgs.convert genv.options with
      | None ->
         exit (if env.errorl = [] then 0 else 1)
      | Some dirname ->
         ServerConvert.go genv env dirname;
         exit 0

    let process_updates _genv _env updates =
      Relative_path.relativize_set Relative_path.Root updates

    let should_recheck update =
      FindUtils.is_php (Relative_path.suffix update)

    let recheck genv old_env typecheck_updates =
      if Relative_path.Set.is_empty typecheck_updates then
        old_env
      else
        let failed_parsing =
          Relative_path.Set.union typecheck_updates old_env.failed_parsing in
        let check_env = { old_env with failed_parsing = failed_parsing } in
        let new_env = ServerTypeCheck.check genv check_env in
        begin
          touch_stamp_errors old_env.errorl new_env.errorl;
          new_env
        end

    let post_recheck_hook = BuildMain.incremental_update

    let parse_options = ServerArgs.parse_options

    let get_watch_paths _options = []

    let marshal chan =
      Typing_deps.marshal chan;
      HackSearchService.SS.MasterApi.marshal chan

    let unmarshal chan =<commit_msg>[hack] Filter dfind updates that don't belong under the .hhconfig dir<commit_after>(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "hack" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

open Core
open Sys_utils
open ServerEnv
open ServerUtils
open Utils

exception State_not_found

let sprintf = Printf.sprintf

(*****************************************************************************)
(* Main initialization *)
(*****************************************************************************)

module MainInit : sig
  val go:
    ServerArgs.options ->
    (unit -> env) ->    (* init function to run while we have init lock *)
    env
end = struct
  let grab_init_lock root =
    ignore(Lock.grab (ServerFiles.init_file root))

  let release_init_lock root =
    ignore(Lock.release (ServerFiles.init_file root))

  let wakeup_client oc msg =
    Option.iter oc
      ~f:(fun oc ->
          try
            output_string oc (msg ^ "\n");
            flush oc
          with _ ->
            (* In case the client don't care... *)
            ())

  let close_waiting_channel oc =
    Option.iter oc
      ~f:(fun oc ->
          try Unix.close (Unix.descr_of_out_channel oc)
          with exn -> Printf.eprintf "Close: %S\n%!" (Printexc.to_string exn))

  (* This code is only executed when the options --check is NOT present *)
  let go options init_fun =
    let waiting_channel =
      Option.map
        (ServerArgs.waiting_client options)
        ~f:Handle.to_out_channel in
    let root = ServerArgs.root options in
    let t = Unix.gettimeofday () in
    Hh_logger.log "Initializing Server (This might take some time)";
    grab_init_lock root;
    wakeup_client waiting_channel "starting";
    (* note: we only run periodical tasks on the root, not extras *)
    ServerIdle.init root;
    let env = init_fun () in
    release_init_lock root;
    Hh_logger.log "Server is READY";
    wakeup_client waiting_channel "ready";
    let t' = Unix.gettimeofday () in
    Hh_logger.log "Took %f seconds to initialize." (t' -. t);
    close_waiting_channel waiting_channel;
    env
end

module type SERVER_PROGRAM = sig
  val preinit : unit -> unit
  val init : genv -> env -> env
  val run_once_and_exit : genv -> env -> unit
  val should_recheck : Relative_path.t -> bool
  (* filter and relativize updated file paths *)
  val process_updates : genv -> env -> SSet.t -> Relative_path.Set.t
  val recheck: genv -> env -> Relative_path.Set.t -> env
  val post_recheck_hook: genv -> env -> env -> Relative_path.Set.t -> unit
  val parse_options: unit -> ServerArgs.options
  val get_watch_paths: ServerArgs.options -> Path.t list
  val name: string
  val config_filename : unit -> Relative_path.t
  val load_config : unit -> ServerConfig.t
  val validate_config : genv -> bool
  val handle_client : genv -> env -> (in_channel * out_channel) -> unit
  (* This is a hack for us to save / restore the global state that is not
   * already captured by ServerEnv *)
  val marshal : out_channel -> unit
  val unmarshal : in_channel -> unit
end

module Program : SERVER_PROGRAM =
  struct
    let name = "hh_server"

    let config_filename_ =
      Relative_path.concat Relative_path.Root ".hhconfig"

    let config_filename () = config_filename_

    let load_config () = ServerConfig.load config_filename_

    let validate_config genv =
      let new_config = load_config () in
      (* This comparison can eventually be made more complex; we may not always
       * need to restart hh_server, e.g. changing the path to the load script
       * is immaterial*)
      genv.config = new_config

    let handle_client (genv:ServerEnv.genv) (env:ServerEnv.env) client =
      ServerCommand.handle genv env client

    let preinit () =
      HackSearchService.attach_hooks ();
      (* Force hhi files to be extracted and their location saved before workers
       * fork, so everyone can know about the same hhi path. *)
      ignore (Hhi.get_hhi_root());
      if not Sys.win32 then
        ignore @@
        Sys.signal Sys.sigusr1 (Sys.Signal_handle Typing.debug_print_last_pos)

    let make_next_files dir =
      let php_next_files = Find.make_next_files FindUtils.is_php dir in
      let js_next_files = Find.make_next_files FindUtils.is_js dir in
      fun () -> php_next_files () @ js_next_files ()

    let stamp_file = Filename.concat GlobalConfig.tmp_dir "stamp"
    let touch_stamp () =
      Sys_utils.mkdir_no_fail (Filename.dirname stamp_file);
      Sys_utils.with_umask
        0o111
        (fun () ->
         (* Open and close the file to set its mtime. Don't use the Unix.utimes
          * function since that will fail if the stamp file doesn't exist. *)
         close_out (open_out stamp_file)
        )
    let touch_stamp_errors l1 l2 =
      (* We don't want to needlessly touch the stamp file if the error list is
       * the same and nothing has changed, but we also don't want to spend a ton
       * of time comparing huge lists of errors over and over (i.e., grind to a
       * halt in the cases when there are thousands of errors). So we cut off
       * the comparison at an arbitrary point. *)
      let rec length_greater_than n = function
        | [] -> false
        | _ when n = 0 -> true
        | _::l -> length_greater_than (n-1) l in
      if length_greater_than 5 l1 || length_greater_than 5 l2 || l1 <> l2
      then touch_stamp ()

    let init genv env =
      let module RP = Relative_path in
      let root = ServerArgs.root genv.options in
      let hhi_root = Hhi.get_hhi_root () in
      let next_files_hhi =
        compose (List.map ~f:(RP.create RP.Hhi)) (make_next_files hhi_root) in
      let next_files_root =
        compose (List.map ~f:(RP.create RP.Root)) (make_next_files root)
      in
      let next_files = fun () ->
        match next_files_hhi () with
        | [] -> next_files_root ()
        | x -> x in
      let env = ServerInit.init genv env next_files in
      touch_stamp ();
      env

    let run_once_and_exit genv env =
      ServerError.print_errorl
        (ServerArgs.json_mode genv.options)
        (List.map env.errorl Errors.to_absolute) stdout;
      match ServerArgs.convert genv.options with
      | None ->
         exit (if env.errorl = [] then 0 else 1)
      | Some dirname ->
         ServerConvert.go genv env dirname;
         exit 0

    let process_updates genv _env updates =
      let root = Path.to_string @@ ServerArgs.root genv.options in
      (* Because of symlinks, we can have updates from files that aren't in
       * the .hhconfig directory *)
      let updates = SSet.filter (fun p -> str_starts_with p root) updates in
      Relative_path.(relativize_set Root updates)

    let should_recheck update =
      FindUtils.is_php (Relative_path.suffix update)

    let recheck genv old_env typecheck_updates =
      if Relative_path.Set.is_empty typecheck_updates then
        old_env
      else
        let failed_parsing =
          Relative_path.Set.union typecheck_updates old_env.failed_parsing in
        let check_env = { old_env with failed_parsing = failed_parsing } in
        let new_env = ServerTypeCheck.check genv check_env in
        begin
          touch_stamp_errors old_env.errorl new_env.errorl;
          new_env
        end

    let post_recheck_hook = BuildMain.incremental_update

    let parse_options = ServerArgs.parse_options

    let get_watch_paths _options = []

    let marshal chan =
      Typing_deps.marshal chan;
      HackSearchService.SS.MasterApi.marshal chan

    let unmarshal chan =
{'fraction_non_alphanumeric': 0.0966849008106505, 'fraction_numerical': 0.0031635141369537995, 'mean_word_length': 2.686588921282799, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 92, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4978818', 'n_tokens_mistral': 4691, 'n_tokens_neox': 4492, 'n_words': 1511}