(* $Id: history.ml,v 5.14 2007-09-12 09:58:44 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)

open Config
open Def
open Gwdb
open TemplAst
open Util

(* S: Fail if conf.bname is undefined? *)
let file_name conf =
  let bname =
    if Filename.check_suffix conf.bname ".gwb" then conf.bname
    else conf.bname ^ ".gwb"
  in
  Filename.concat (Util.bpath bname) "history"

(* Record history when committing updates *)

let ext_flags =
  [ Open_wronly; Open_append; Open_creat; Open_text; Open_nonblock ]

(* ********************************************************************** *)
(*  [Fonc] slash_name_of_key : string -> string -> int -> string          *)

(* ********************************************************************** *)

(** [Description] : Renvoie la clé nom/prénom/occ.
    [Args] :
      - fn  : string
      - sn  : string
      - occ : int
    [Retour] : string
    [Rem] : Non exporté en clair hors de ce module.                       *)
let slash_name_of_key fn sn occ =
  let space_to_unders = Mutil.tr ' ' '_' in
  let fn = space_to_unders (Name.lower fn) in
  let sn = space_to_unders (Name.lower sn) in
  sn ^ "/" ^ fn ^ "/" ^ string_of_int occ

(* ********************************************************************** *)
(* [Fonc] diff_visibility :
            config -> base -> gen_person -> gen_person -> string array *)

(* ********************************************************************** *)

(** [Description] : Si la visibilité de la personne a changé (entre
                    l'ancienne et la nouvelle), alors on revoie un tableau
                    avec la nouvelle visibilité.
    [Args] :
      - conf : configuration de la base
      - base : base de donnée
      - op   : la person avant les modifications
      - np   : la person après les modifications
    [Retour] : string array
    [Rem] : Non exporté en clair hors de ce module.                       *)
let diff_visibility conf base op np =
  let k = slash_name_of_key np.first_name np.surname np.occ in
  let empty_union = { family = [||] } in
  let empty_ascend = { parents = None; consang = Adef.fix (-1) } in
  let op = Futil.map_person_ps (fun p -> p) (Gwdb.insert_string base) op in
  let np = Futil.map_person_ps (fun p -> p) (Gwdb.insert_string base) np in
  let o_p = Gwdb.person_of_gen_person base (op, empty_ascend, empty_union) in
  let n_p = Gwdb.person_of_gen_person base (np, empty_ascend, empty_union) in
  let tmp_conf = { conf with wizard = false; friend = false } in
  let old_visibility = Util.authorized_age tmp_conf base o_p in
  let new_visibility = Util.authorized_age tmp_conf base n_p in
  if old_visibility <> new_visibility then
    [| "VISIBLE"; k; string_of_bool new_visibility |]
  else [||]

type kind_diff =
  | Diff_person of
      (iper, iper, string) gen_person * (iper, iper, string) gen_person
  | Diff_string of (string * string * int) * (string * string * int)

(* ********************************************************************** *)
(*  [Fonc] diff_key : gen_person -> gen_person -> string array            *)

(* ********************************************************************** *)

(** [Description] : Si la clé de la personne a changé, alors on renvoie un
                    tableau avec l'ancienne clé et la nouvelle clé.
    [Args] :
      - op   : la person avant les modifications
      - np   : la person après les modifications
    [Retour] : string array
    [Rem] : Non exporté en clair hors de ce module.                       *)
let diff_key d =
  match d with
  | Diff_person (op, np) ->
      let o_key = slash_name_of_key op.first_name op.surname op.occ in
      let n_key = slash_name_of_key np.first_name np.surname np.occ in
      if o_key <> n_key then [| "KEY"; o_key; n_key |] else [||]
  | Diff_string ((ofn, osn, oocc), (fn, sn, occ)) ->
      let o_key = slash_name_of_key ofn osn oocc in
      let n_key = slash_name_of_key fn sn occ in
      if o_key <> n_key then [| "KEY"; o_key; n_key |] else [||]

(* ********************************************************************** *)
(* [Fonc] diff_person :
            config -> base -> gen_person -> gen_person -> string array *)

(* ********************************************************************** *)

(** [Description] : Fonction qui ajouté des paramètres passés dans la
                    ligne de commande de notify_change. Elle permet de
                    savoir quelle genre de modifications ont été faites.
    [Args] :
      - conf : configuration de la base
      - base : base de donnée
      - op   : la person avant les modifications
      - np   : la person après les modifications
    [Retour] : string array
    [Rem] : Non exporté en clair hors de ce module.                       *)
let diff_person conf base changed =
  match changed with
  | U_Add_person _ | U_Delete_person _ -> [||]
  | U_Modify_person (o, n) ->
      Array.append
        (diff_key (Diff_person (o, n)))
        (diff_visibility conf base o n)
  | U_Merge_person (p1, p2, p) ->
      let args_p1 =
        Array.append
          (diff_key (Diff_person (p1, p)))
          (diff_visibility conf base p1 p)
      in
      let args_p2 =
        Array.append
          (diff_key (Diff_person (p2, p)))
          (diff_visibility conf base p2 p)
      in
      Array.append args_p1 args_p2
  | U_Send_image _ | U_Delete_image _
  | U_Add_family (_, _)
  | U_Modify_family (_, _, _)
  | U_Delete_family (_, _)
  | U_Invert_family (_, _)
  | U_Merge_family (_, _, _, _)
  | U_Add_parent (_, _) ->
      [||]
  | U_Change_children_name (_, l) ->
      List.fold_left
        (fun accu ((ofn, osn, oocc, _), (fn, sn, occ, _)) ->
          Array.append accu
            (diff_key (Diff_string ((ofn, osn, oocc), (fn, sn, occ)))))
        [||] l
  | U_Multi (o, n, _) -> diff_key (Diff_person (o, n))
  | U_Notes (_, _) | U_Kill_ancestors _ -> [||]

(* ************************************************************************ *)
(*  [Fonc] notify_change : config -> base -> base_changed -> string -> unit *)

(* ************************************************************************ *)

(** [Description] : Appel le script défini par la variable notify_change du
                    fichier gwf.
    [Args] :
      - conf : configuration de la base
      - base : base de donnée
      - changed : le type de modification (voir def.mli)
      - action : le code du type de modification
    [Retour] : Néant
    [Rem] : Non exporté en clair hors de ce module.                         *)
let notify_change conf base changed action =
  if Sys.unix then
    match List.assoc_opt "notify_change" conf.base_env with
    | Some comm -> (
        let base_args =
          match changed with
          | U_Add_person p
          | U_Modify_person (_, p)
          | U_Delete_person p
          | U_Merge_person (_, _, p)
          | U_Send_image p
          | U_Delete_image p
          | U_Add_family (p, _)
          | U_Modify_family (p, _, _)
          | U_Delete_family (p, _)
          | U_Invert_family (p, _)
          | U_Merge_family (p, _, _, _)
          | U_Add_parent (p, _)
          | U_Kill_ancestors p
          | U_Change_children_name (p, _)
          | U_Multi (_, p, _) ->
              let key = slash_name_of_key p.first_name p.surname p.occ in
              [| key; string_of_iper p.key_index |]
          | U_Notes (Some num, file) -> [| file; string_of_int num |]
          | U_Notes (None, file) -> [| file |]
        in
        let optional_args = diff_person conf base changed in
        let args = Array.append base_args optional_args in
        let args =
          Array.append [| comm; conf.bname; conf.user; action |] args
        in
        match Unix.fork () with
        | 0 ->
            if Unix.fork () <> 0 then exit 0
            else (
              (try Unix.execvp comm args with _ -> ());
              exit 0)
        | id -> ignore (Unix.waitpid [] id))
    | None -> ()

(* ************************************************************************ *)
(*  [Fonc] gen_record : config -> base -> base_changed -> string -> unit    *)

(* ************************************************************************ *)

(** [Description] : Enregistre dans le fichier historique si la variable
      "hitory" du fichier gwf est valorisée à "yes". Le fait qu'on ait des
      gen_person, nous permet de pouvoir faire un diff entre avant et après
      la modification d'une personne.
    [Args] :
      - conf : configuration de la base
      - base : base de donnée
      - changed : le type de modification (voir def.mli)
      - action : le code du type de modification
    [Retour] : Néant
    [Rem] : Non exporté en clair hors de ce module.                         *)
let gen_record conf base changed action =
  (match List.assoc_opt "history" conf.base_env with
  | Some "yes" when not conf.manitou -> (
      let item =
        match changed with
        | U_Add_person p
        | U_Modify_person (_, p)
        | U_Delete_person p
        | U_Merge_person (_, _, p)
        | U_Send_image p
        | U_Delete_image p
        | U_Add_family (p, _)
        | U_Modify_family (p, _, _)
        | U_Delete_family (p, _)
        | U_Invert_family (p, _)
        | U_Merge_family (p, _, _, _)
        | U_Add_parent (p, _)
        | U_Kill_ancestors p
        | U_Change_children_name (p, _)
        | U_Multi (_, p, _) ->
            p.first_name ^ "." ^ string_of_int p.occ ^ " " ^ p.surname
        | U_Notes (Some num, file) ->
            let s = string_of_int num in
            if file = "" then s else file ^ "/" ^ s
        | U_Notes (None, file) -> file
      in
      let fname = file_name conf in
      match
        try Some (Secure.open_out_gen ext_flags 0o644 fname)
        with Sys_error _ -> None
      with
      | Some oc ->
          Printf.fprintf oc "%s [%s] %s %s\n"
            (Util.sprintf_today conf :> string)
            conf.user action item;
          close_out oc
      | None -> ())
  | _ -> ());
  HistoryDiff.record_diff conf base changed;
  (* Effet de bord des modifications en masse : on peut facilement  *)
  (* créer 5000 nouveaux processus à chaque mise à jour.            *)
  (* Pour éviter cela, on n'appelle jamais notify_change lors de la *)
  (* mise à jour de l'historique.                                   *)
  match changed with
  | U_Multi (_, _, _) -> ()
  | _ -> notify_change conf base changed action

(* ************************************************************************ *)
(*  [Fonc] record : config -> base -> base_changed -> string -> unit        *)

(* ************************************************************************ *)

(** [Description] : Suite à la mise à jour de la base, on réalise les
      traitements suivant :
        - mise à jour (si nécessaire) du fichier gwf pour le sosa_ref
        - mise à jour du fichier historique
        - appel du script notify_change
    [Args] :
      - conf : configuration de la base
      - base : base de donnée
      - changed : le type de modification (voir def.mli)
      - action : le code du type de modification
    [Retour] : Néant
    [Rem] : Non exporté en clair hors de ce module.                         *)
let record conf base changed action =
  (* Mise à jour du fichier gwf si le sosa_ref a changé. *)
  (match changed with
  | U_Modify_person (_, p) ->
      let fn, sn, occ, ip = (p.first_name, p.surname, p.occ, p.key_index) in
      update_gwf_sosa conf base (ip, (fn, sn, occ))
  | U_Merge_person (p1, _, p) ->
      let fn, sn, occ, ip = (p1.first_name, p1.surname, p1.occ, p1.key_index) in
      update_gwf_sosa conf base (ip, (fn, sn, occ));
      (* On n'a pas besoin de faire un update sur "p2" *)
      (* parce qu'on le fait sur p dans tous les cas.  *)
      let fn, sn, occ, ip = (p.first_name, p.surname, p.occ, p.key_index) in
      update_gwf_sosa conf base (ip, (fn, sn, occ))
  | U_Change_children_name (_, l) ->
      List.iter
        (fun (_, (fn, sn, occ, ip)) ->
          update_gwf_sosa conf base (ip, (fn, sn, occ)))
        l
  | _ -> ());
  (* Mise à jour du fichier historique et appel de notify_change. *)
  gen_record conf base changed action

(* ************************************************************************ *)
(*  [Fonc] notify : config -> base -> string -> unit                        *)

(* ************************************************************************ *)

(** [Description] : Appel explicite de notify_change suite à une modification
                    de masse de la base (typiquement, le dico des lieux).
                    On évite comme ça la création de 5000 processus.
    [Args] :
      - conf : configuration de la base
      - base : base de donnée
      - action : le code du type de modification
    [Retour] : Néant
    [Rem] : Non exporté en clair hors de ce module.                         *)
let notify conf base action =
  let empty_person = Gwdb.empty_person base Gwdb.dummy_iper in
  let empty_person =
    Util.string_gen_person base (gen_person_of_person empty_person)
  in
  notify_change conf base (U_Multi (empty_person, empty_person, false)) action

(* Request for history printing *)

let line_tpl = "0000-00-00 00:00:00 xx ."

let line_fields line =
  if String.length line > String.length line_tpl then
    let time = String.sub line 0 19 in
    let user, i =
      match (line.[20], String.index_opt line ']') with
      | '[', Some i ->
          let user = String.sub line 21 (i - 21) in
          (user, i + 2)
      | _ -> ("", 20)
    in
    let action = String.sub line i 2 in
    let key =
      let i = i + 3 in
      if i >= String.length line then None
      else Some (String.sub line i (String.length line - i))
    in
    Some (time, user, action, key)
  else None

type hist_item = HI_notes of string * int option | HI_ind of person | HI_none

type 'a env =
  | Vcnt of int ref
  | Vinfo of string * string * string * hist_item * string
  | Vpos of int ref
  | Vsearch of (bool * string * int) option
  | Vother of 'a
  | Vnone

let get_env v env = try List.assoc v env with Not_found -> Vnone
let get_vother = function Vother x -> Some x | _ -> None
let set_vother x = Vother x

let possibly_highlight env s =
  match get_env "search" env with
  | Vsearch (Some (case_sens, h, _)) ->
      if in_text case_sens h s then html_highlight case_sens h s else s
  | _ -> s

let safe_val (s : Adef.safe_string) = VVstring (s :> string)

let rec eval_var conf base env _ _ = function
  | [ "count" ] -> (
      match get_env "count" env with
      | Vcnt c -> VVstring (string_of_int !c)
      | _ -> VVstring "")
  | [ "first_name" ] -> (
      match get_env "info" env with
      | Vinfo (_, _, _, HI_ind p, _) -> VVstring (p_first_name base p)
      | _ -> VVstring "")
  | [ "found" ] -> (
      match get_env "search" env with
      | Vsearch (Some _) -> VVbool true
      | _ -> VVbool false)
  | [ "incr_count" ] -> (
      match get_env "count" env with
      | Vcnt c ->
          incr c;
          VVstring ""
      | _ -> VVstring "")
  | [ "is_note" ] -> (
      match get_env "info" env with
      | Vinfo (_, _, _, HI_notes (_, _), _) -> VVbool true
      | _ -> VVbool false)
  | [ "key" ] -> (
      match get_env "info" env with
      | Vinfo (_, _, _, _, s) -> VVstring (possibly_highlight env s)
      | _ -> raise Not_found)
  | "note" :: "page" :: sl -> (
      match get_env "info" env with
      | Vinfo (_, _, _, HI_notes (s, _), _) ->
          let s =
            match sl with
            | [ "v" ] -> s
            | [] -> possibly_highlight env s
            | _ -> raise Not_found
          in
          VVstring s
      | _ -> raise Not_found)
  | [ "note"; "part" ] -> (
      match get_env "info" env with
      | Vinfo (_, _, _, HI_notes (_, Some x), _) -> VVstring (string_of_int x)
      | Vinfo (_, _, _, HI_notes (_, None), _) -> VVstring ""
      | _ -> raise Not_found)
  | [ "occ" ] -> (
      match get_env "info" env with
      | Vinfo (_, _, _, HI_ind p, _) -> VVstring (string_of_int (get_occ p))
      | _ -> VVstring "")
  | "person" :: sl -> (
      match get_env "info" env with
      | Vinfo (_, _, _, HI_ind p, _) -> eval_person_field_var conf base env p sl
      | _ -> raise Not_found)
  | [ "pos" ] -> (
      match get_env "pos" env with
      | Vpos r -> VVstring (string_of_int !r)
      | _ -> raise Not_found)
  | [ "reset_count" ] -> (
      match get_env "count" env with
      | Vcnt c ->
          c := 0;
          VVstring ""
      | _ -> VVstring "")
  | [ "surname" ] -> (
      match get_env "info" env with
      | Vinfo (_, _, _, HI_ind p, _) -> VVstring (p_surname base p)
      | _ -> VVstring "")
  | [ "time" ] -> (
      match get_env "info" env with
      | Vinfo (s, _, _, _, _) -> VVstring (possibly_highlight env s)
      | _ -> raise Not_found)
  | "update" :: sl -> (
      match get_env "info" env with
      | Vinfo (_, u, _, _, _) -> eval_string u sl
      | _ -> raise Not_found)
  | "user" :: sl -> (
      match get_env "info" env with
      | Vinfo (_, _, s, _, _) ->
          let s =
            match sl with
            | [ "v" ] -> s
            | [] -> possibly_highlight env s
            | _ -> raise Not_found
          in
          VVstring s
      | _ -> raise Not_found)
  | _ -> raise Not_found

and eval_string s = function
  | [ "var" ] -> VVother (eval_string s)
  | [] -> VVstring s
  | _ -> raise Not_found

and eval_person_field_var conf base env p = function
  | [ "access" ] -> safe_val (Util.acces conf base p :> Adef.safe_string)
  | [ "dates" ] -> safe_val (DateDisplay.short_dates_text conf base p)
  | [ "has_history" ] ->
      let fn = sou base (get_first_name p) in
      let sn = sou base (get_surname p) in
      let occ = get_occ p in
      let person_file = HistoryDiff.history_file fn sn occ in
      VVbool (Sys.file_exists (HistoryDiff.history_path conf person_file))
  | [ "history_file" ] ->
      let fn = sou base (get_first_name p) in
      let sn = sou base (get_surname p) in
      let occ = get_occ p in
      VVstring (HistoryDiff.history_file fn sn occ)
  | [ "is_invisible" ] ->
      let conf = { conf with wizard = false; friend = false } in
      VVbool (not (Util.authorized_age conf base p))
  | [ "title" ] -> safe_val (person_title conf base p)
  | [] ->
      VVstring
        (possibly_highlight env
           (simple_person_text conf base p : Adef.safe_string :> string))
  | _ -> VVstring "person..."

and simple_person_text conf base p =
  match main_title conf base p with
  | Some t -> titled_person_text conf base p t
  | None -> gen_person_text conf base p

let print_foreach conf base print_ast eval_expr =
  let eval_int_expr env ep e =
    let s = eval_expr env ep e in
    try int_of_string s with Failure _ -> raise Not_found
  in
  let rec print_foreach env xx _ s sl el al =
    match (s, sl) with
    | "history_line", [] -> print_foreach_history_line env xx el al
    | _, _ -> raise Not_found
  and print_foreach_history_line env xx el al =
    match
      try Some (Secure.open_in_bin (file_name conf)) with Sys_error _ -> None
    with
    | Some ic -> (
        try
          let k, pos, wiz =
            match el with
            | [ [ e1 ]; [ e2 ]; [ e3 ] ] ->
                let k = eval_int_expr env xx e1 in
                let pos =
                  match get_env "search" env with
                  | Vsearch (Some (_, _, pos)) -> pos
                  | Vsearch None -> in_channel_length ic
                  | _ -> (
                      try eval_int_expr env xx e2
                      with Not_found -> in_channel_length ic)
                in
                let wiz = eval_expr env xx e3 in
                (k, pos, wiz)
            | [] -> (3, in_channel_length ic, "")
            | _ -> raise Not_found
          in
          let pos =
            let vv = (ref (Bytes.create 0), ref 0) in
            let rec loop pos i =
              if i >= k then pos
              else
                match
                  try Some (Mutil.rev_input_line ic pos vv)
                  with End_of_file -> None
                with
                | Some (line, pos) ->
                    let i = print_history_line2 env xx line wiz i al in
                    loop pos i
                | None -> pos
            in
            loop pos 0
          in
          (match get_env "pos" env with Vpos r -> r := pos | _ -> ());
          close_in ic
        with e ->
          close_in ic;
          raise e)
    | None -> ()
  and print_history_line2 env xx line wiz i al =
    match line_fields line with
    | Some (time, user, action, keyo) ->
        if wiz = "" || user = wiz then (
          let hist_item =
            match keyo with
            | Some key -> (
                match action with
                | "mn" -> (
                    let i, j =
                      try
                        let i = String.rindex key '/' in
                        (i, i + 1)
                      with Not_found -> (0, 0)
                    in
                    let pg = String.sub key 0 i in
                    let s = String.sub key j (String.length key - j) in
                    try HI_notes (pg, Some (int_of_string s))
                    with Failure _ -> HI_notes (key, None))
                | _ -> (
                    match Gutil.person_ht_find_all base key with
                    | [ ip ] -> HI_ind (pget conf base ip)
                    | _ -> HI_none))
            | None -> HI_none
          in
          let not_displayed =
            match hist_item with
            | HI_ind p ->
                is_hidden p
                || (is_hide_names conf p && not (authorized_age conf base p))
            | _ -> false
          in
          if not_displayed then i
          else
            let key = match keyo with Some s -> s | None -> "" in
            let env =
              ("info", Vinfo (time, action, user, hist_item, key)) :: env
            in
            List.iter (print_ast env xx) al;
            i + 1)
        else i
    | None -> i
  in
  print_foreach

let gen_print conf base hoo =
  let env =
    let env = [ ("pos", Vpos (ref 0)); ("count", Vcnt (ref 0)) ] in
    match hoo with Some ho -> ("search", Vsearch ho) :: env | None -> env
  in
  Hutil.interp conf "updhist"
    {
      Templ.eval_var = eval_var conf base;
      Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
      Templ.eval_predefined_apply = (fun _ -> raise Not_found);
      Templ.get_vother;
      Templ.set_vother;
      Templ.print_foreach = print_foreach conf base;
    }
    env ()

let print conf base = gen_print conf base None

(* searching *)

let search_text conf base s =
  let s = if s = "" then " " else s in
  let case_sens = p_getenv conf.env "c" = Some "on" in
  let found =
    match
      try Some (Secure.open_in_bin (file_name conf)) with Sys_error _ -> None
    with
    | Some ic ->
        let pos =
          match p_getint conf.env "pos" with
          | Some pos -> pos
          | None -> in_channel_length ic
        in
        let vv = (ref (Bytes.create 0), ref 0) in
        let rec loop pos =
          match
            try Some (Mutil.rev_input_line ic pos vv) with End_of_file -> None
          with
          | Some (line, pos2) -> (
              match line_fields line with
              | Some (time, user, _, keyo) ->
                  let key = match keyo with Some key -> key | None -> "" in
                  if
                    in_text case_sens s time || in_text case_sens s user
                    || in_text case_sens s key
                  then Some pos
                  else loop pos2
              | None -> None)
          | None -> None
        in
        loop pos
    | None -> None
  in
  let h =
    match found with Some pos -> Some (case_sens, s, pos) | None -> None
  in
  gen_print conf base (Some h)

let print_search conf base =
  if conf.wizard || conf.friend then
    match try Some (List.assoc "s" conf.env) with Not_found -> None with
    | Some s -> search_text conf base (Mutil.gen_decode false s)
    | None -> print conf base
  else print conf base
