441 lines
17 KiB
OCaml
441 lines
17 KiB
OCaml
open Geneweb
|
|
open Config
|
|
open Gwdb
|
|
|
|
let arg_f_parents = "f_parents"
|
|
let arg_f_children = "f_children"
|
|
let arg_p_parents = "p_parents"
|
|
let arg_p_NBDS = "p_NBDS"
|
|
let arg_p_families = "p_families"
|
|
let arg_pevents_witnesses = "pevents_witnesses"
|
|
let arg_fevents_witnesses = "fevents_witnesses"
|
|
let arg_marriage_divorce = "marriage_divorce"
|
|
let arg_missing_spouses = "missing_spouses"
|
|
let arg_invalid_utf8 = "invalid_utf8"
|
|
let arg_p_key = "p_key"
|
|
let arg_tstab = "tstab"
|
|
let arg_password = "password"
|
|
|
|
module UI = struct
|
|
let enabled conf s = (List.assoc_opt s conf.env :> string option) = Some "on"
|
|
|
|
let print_arg conf
|
|
((name, kind, doc) :
|
|
Adef.encoded_string * [> `Arg_Set | `Arg_String ] * Adef.safe_string) =
|
|
match kind with
|
|
| `Arg_Set ->
|
|
Output.print_sstring conf {|<p><label><input type="checkbox" name="|};
|
|
Output.print_string conf name;
|
|
Output.print_sstring conf {|" value="on"> |};
|
|
Output.print_string conf doc;
|
|
Output.print_sstring conf {|</label></p>|}
|
|
| `Arg_String ->
|
|
Output.print_sstring conf {|<p><label><input type="type" name="|};
|
|
Output.print_string conf name;
|
|
Output.print_sstring conf {|"> |};
|
|
Output.print_string conf doc;
|
|
Output.print_sstring conf {|</label></p>|}
|
|
|
|
let form conf (m : Adef.encoded_string) (submit : Adef.safe_string) args =
|
|
Output.print_sstring conf {|<form action="|};
|
|
Output.print_string conf (Util.commd conf);
|
|
Output.print_sstring conf {|" method="GET">|};
|
|
Output.print_sstring conf {|<input type="hidden" name="m" value="|};
|
|
Output.print_string conf m;
|
|
Output.print_sstring conf {|">|};
|
|
(match List.assoc_opt arg_password conf.env with
|
|
| Some x ->
|
|
Output.print_sstring conf
|
|
{|<input type="hidden" name="password" value="|};
|
|
Output.print_string conf x;
|
|
Output.print_sstring conf {|">|}
|
|
| None -> ());
|
|
List.iter (print_arg conf) args;
|
|
Output.print_sstring conf {|<input type="submit" value="|};
|
|
Output.print_string conf submit;
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_sstring conf {|</form>|}
|
|
end
|
|
|
|
let opt_password =
|
|
match Sys.getenv_opt "GW_PLUGIN_FIXBASE_PASSWORD" with
|
|
| Some "" | None -> None
|
|
| Some x -> Some (Mutil.encode x)
|
|
|
|
let opt_manitou =
|
|
match Sys.getenv_opt "GW_PLUGIN_FIXBASE_ONLY_MANITOU" with
|
|
| Some ("on" | "ON" | "y" | "Y" | "1") -> true
|
|
| _ -> false
|
|
|
|
let missing_password conf =
|
|
let args =
|
|
[
|
|
( Mutil.encode arg_password,
|
|
`Arg_String,
|
|
Util.transl conf "plugin_fixbase_password_missing" |> Adef.safe );
|
|
]
|
|
in
|
|
UI.form conf (List.assoc "m" conf.env)
|
|
(Util.transl conf "plugin_fixbase_password_submit" |> Adef.safe)
|
|
args
|
|
|
|
let wrap conf title fn =
|
|
!GWPARAM.wrap_output conf title @@ fun () ->
|
|
if opt_password = List.assoc_opt arg_password conf.env then fn ()
|
|
else missing_password conf
|
|
|
|
let fixbase conf _base =
|
|
wrap conf (Util.transl conf "plugin_fixbase_FIXBASE" |> Adef.safe)
|
|
@@ fun () ->
|
|
Output.print_sstring conf {|<p>|};
|
|
Output.print_sstring conf (Util.transl conf "plugin_fixbase_description");
|
|
Output.print_sstring conf {|</p>|};
|
|
let args =
|
|
let input name txt =
|
|
(Mutil.encode name, `Arg_Set, Util.transl conf txt |> Adef.safe)
|
|
in
|
|
[
|
|
input arg_f_parents "plugin_fixbase_f_parents";
|
|
input arg_f_children "plugin_fixbase_f_children";
|
|
input arg_p_parents "plugin_fixbase_p_parents";
|
|
input arg_p_NBDS "plugin_fixbase_p_NBDS";
|
|
input arg_p_families "plugin_fixbase_p_families";
|
|
input arg_pevents_witnesses "plugin_fixbase_pevents_witnesses";
|
|
input arg_fevents_witnesses "plugin_fixbase_fevents_witnesses";
|
|
input arg_marriage_divorce "plugin_fixbase_marriage_divorce";
|
|
input arg_missing_spouses "plugin_fixbase_missing_spouses";
|
|
input arg_invalid_utf8 "plugin_fixbase_invalid_utf8";
|
|
input arg_p_key "plugin_fixbase_p_key";
|
|
input arg_tstab "plugin_fixbase_tstab";
|
|
]
|
|
in
|
|
UI.form conf
|
|
(Adef.encoded "FIXBASE_OK")
|
|
(Util.transl conf "plugin_fixbase_submit" |> Adef.safe)
|
|
args
|
|
|
|
let fixbase_ok conf base =
|
|
let dry_run = Util.p_getenv conf.env "dry_run" <> Some "off" in
|
|
let process () =
|
|
ignore @@ Unix.alarm 0;
|
|
(* cancel timeout *)
|
|
let base' = Gwdb.open_base @@ Util.base_path [] (bname base ^ ".gwb") in
|
|
let ipers = ref [] in
|
|
let ifams = ref [] in
|
|
let istrs = ref [] in
|
|
let report = function
|
|
| Fixbase.Fix_NBDS ip
|
|
| Fix_AddedUnion ip
|
|
| Fix_AddedParents ip
|
|
| Fix_ParentDeleted ip
|
|
| Fix_AddedRelatedFromPevent (ip, _)
|
|
| Fix_AddedRelatedFromFevent (ip, _)
|
|
| Fix_UpdatedOcc (ip, _, _) ->
|
|
ipers := ip :: !ipers
|
|
| Fix_RemovedUnion (iper, ifam)
|
|
| Fix_RemovedDuplicateUnion (iper, ifam)
|
|
| Fix_MissingSpouse (ifam, iper) ->
|
|
ifams := ifam :: !ifams;
|
|
ipers := iper :: !ipers
|
|
| Fix_MarriageDivorce ifam | Fix_AddedChild ifam ->
|
|
ifams := ifam :: !ifams
|
|
| Fix_WrongUTF8Encoding (ifam, iper, istr) ->
|
|
istrs := (ifam, iper, istr) :: !istrs
|
|
in
|
|
let progress (_ : int) (_ : int) = () in
|
|
let enabled = List.exists (UI.enabled conf) in
|
|
if
|
|
enabled
|
|
[
|
|
"marriage_divorce";
|
|
"f_parents";
|
|
"f_children";
|
|
"fevents_witnesses";
|
|
"missing_spouses";
|
|
"invalid_utf8";
|
|
]
|
|
then Gwdb.load_families_array base;
|
|
if enabled [ "invalid_utf8"; "p_key" ] then Gwdb.load_strings_array base;
|
|
if enabled [ "f_parents"; "p_families" ] then Gwdb.load_unions_array base;
|
|
if enabled [ "f_children"; "p_parents" ] then (
|
|
Gwdb.load_descends_array base;
|
|
Gwdb.load_ascends_array base);
|
|
load_persons_array base;
|
|
let opt s (fn : ?report:_ -> _ -> _ -> _) =
|
|
if UI.enabled conf s then fn ~report progress base
|
|
in
|
|
wrap conf (Util.transl conf "plugin_fixbase_FIXBASE_OK" |> Adef.safe)
|
|
@@ fun () ->
|
|
opt "f_parents" Fixbase.check_families_parents;
|
|
opt "f_children" Fixbase.check_families_children;
|
|
opt "p_parents" Fixbase.check_persons_parents;
|
|
opt "p_NBDS" Fixbase.check_NBDS;
|
|
opt "p_families" Fixbase.check_persons_families;
|
|
opt "pevents_witnesses" Fixbase.check_pevents_witnesses;
|
|
opt "fevents_witnesses" Fixbase.check_fevents_witnesses;
|
|
opt "marriage_divorce" Fixbase.fix_marriage_divorce;
|
|
opt "missing_spouses" Fixbase.fix_missing_spouses;
|
|
opt "invalid_utf8" Fixbase.fix_utf8_sequence;
|
|
opt "p_key" Fixbase.fix_key;
|
|
opt "p_key" Fixbase.fix_key;
|
|
clear_persons_array base;
|
|
clear_strings_array base;
|
|
clear_families_array base;
|
|
clear_unions_array base;
|
|
clear_descends_array base;
|
|
clear_ascends_array base;
|
|
let ifneq x1 x2 label s =
|
|
if x1 <> x2 then (
|
|
Output.print_sstring conf {|<tr><td><b>|};
|
|
Output.print_string conf label;
|
|
Output.print_sstring conf {|</b></td><td>|};
|
|
Output.print_string conf (s x1 |> Util.escape_html);
|
|
Output.print_sstring conf {|</td><td>|};
|
|
Output.print_string conf (s x2 |> Util.escape_html);
|
|
Output.print_sstring conf {|</td></tr>|})
|
|
in
|
|
let dump_p p p' =
|
|
let mka p =
|
|
let a = gen_ascend_of_person p in
|
|
{ a with parents = Option.map string_of_ifam a.parents }
|
|
in
|
|
let mku p =
|
|
{ Def.family = Array.map string_of_ifam (gen_union_of_person p).family }
|
|
in
|
|
let mkp p =
|
|
let p = gen_person_of_person p in
|
|
let p = Futil.map_person_ps string_of_iper (sou base) p in
|
|
{ p with key_index = string_of_iper p.key_index }
|
|
in
|
|
let a1 = mka p in
|
|
let u1 = mku p in
|
|
let p1 = mkp p in
|
|
let a2 = mka p' in
|
|
let u2 = mku p' in
|
|
let p2 = mkp p' in
|
|
let ifneq x1 x2 label s = ifneq x1 x2 (Util.escape_html label) s in
|
|
ifneq p1.first_name p2.first_name "first_name" (fun s -> s);
|
|
ifneq p1.surname p2.surname "surname" (fun s -> s);
|
|
ifneq p1.occ p2.occ "occ" string_of_int;
|
|
ifneq p1.image p2.image "image" (fun s -> s);
|
|
ifneq p1.public_name p2.public_name "public_name" (fun s -> s);
|
|
ifneq p1.qualifiers p2.qualifiers "qualifiers" [%show: string list];
|
|
ifneq p1.aliases p2.aliases "aliases" [%show: string list];
|
|
ifneq p1.first_names_aliases p2.first_names_aliases "first_names_aliases"
|
|
[%show: string list];
|
|
ifneq p1.surnames_aliases p2.surnames_aliases "surnames_aliases"
|
|
[%show: string list];
|
|
ifneq p1.titles p2.titles "titles" [%show: string Def_show.gen_title list];
|
|
ifneq p1.rparents p2.rparents "rparents"
|
|
[%show: (string, string) Def_show.gen_relation list];
|
|
ifneq p1.related p2.related "related" [%show: string list];
|
|
ifneq p1.occupation p2.occupation "occupation" (fun s -> s);
|
|
ifneq p1.sex p2.sex "sex" [%show: Def_show.sex];
|
|
ifneq p1.access p2.access "access" [%show: Def_show.access];
|
|
ifneq p1.birth p2.birth "birth" [%show: Def_show.cdate];
|
|
ifneq p1.birth_place p2.birth_place "birth_place" (fun s -> s);
|
|
ifneq p1.birth_note p2.birth_note "birth_note" (fun s -> s);
|
|
ifneq p1.birth_src p2.birth_src "birth_src" (fun s -> s);
|
|
ifneq p1.baptism p2.baptism "baptism" [%show: Def_show.cdate];
|
|
ifneq p1.baptism_place p2.baptism_place "baptism_place" (fun s -> s);
|
|
ifneq p1.baptism_note p2.baptism_note "baptism_note" (fun s -> s);
|
|
ifneq p1.baptism_src p2.baptism_src "baptism_src" (fun s -> s);
|
|
ifneq p1.death p2.death "death" [%show: Def_show.death];
|
|
ifneq p1.death_place p2.death_place "death_place" (fun s -> s);
|
|
ifneq p1.death_note p2.death_note "death_note" (fun s -> s);
|
|
ifneq p1.death_src p2.death_src "death_src" (fun s -> s);
|
|
ifneq p1.burial p2.burial "burial" [%show: Def_show.burial];
|
|
ifneq p1.burial_place p2.burial_place "burial_place" (fun s -> s);
|
|
ifneq p1.burial_note p2.burial_note "burial_note" (fun s -> s);
|
|
ifneq p1.burial_src p2.burial_src "burial_src" (fun s -> s);
|
|
ifneq p1.pevents p2.pevents "pevents"
|
|
[%show: (string, string) Def_show.gen_pers_event list];
|
|
ifneq p1.notes p2.notes "notes" (fun s -> s);
|
|
ifneq p1.psources p2.psources "psources" (fun s -> s);
|
|
ifneq p1.key_index p2.key_index "key_index" (fun s -> s);
|
|
ifneq a1.parents a2.parents "parents" [%show: string option];
|
|
ifneq a1.consang a2.consang "consang" [%show: Def_show.fix];
|
|
ifneq u1.family u2.family "family" [%show: string array]
|
|
in
|
|
let dump_f f f' =
|
|
let mkf f =
|
|
Futil.map_family_ps string_of_iper string_of_ifam (sou base)
|
|
(gen_family_of_family f)
|
|
in
|
|
let mkc f =
|
|
Futil.map_couple_p false string_of_iper (gen_couple_of_family f)
|
|
in
|
|
let mkd f =
|
|
Futil.map_descend_p string_of_iper (gen_descend_of_family f)
|
|
in
|
|
let f1 = mkf f in
|
|
let c1 = mkc f in
|
|
let d1 = mkd f in
|
|
let f2 = mkf f' in
|
|
let c2 = mkc f' in
|
|
let d2 = mkd f' in
|
|
let ifneq x1 x2 label s = ifneq x1 x2 (Util.escape_html label) s in
|
|
ifneq f1.marriage f2.marriage "marriage" [%show: Def_show.cdate];
|
|
ifneq f1.marriage_place f2.marriage_place "marriage_place" (fun s -> s);
|
|
ifneq f1.marriage_note f2.marriage_note "marriage_note" (fun s -> s);
|
|
ifneq f1.marriage_src f2.marriage_src "marriage_src" (fun s -> s);
|
|
ifneq f1.witnesses f2.witnesses "witnesses" [%show: string array];
|
|
ifneq f1.relation f2.relation "relation" [%show: Def_show.relation_kind];
|
|
ifneq f1.divorce f2.divorce "divorce" [%show: Def_show.divorce];
|
|
ifneq f1.fevents f2.fevents "fevents"
|
|
[%show: (string, string) Def_show.gen_fam_event list];
|
|
ifneq f1.comment f2.comment "comment" (fun s -> s);
|
|
ifneq f1.origin_file f2.origin_file "origin_file" (fun s -> s);
|
|
ifneq f1.fsources f2.fsources "fsources" (fun s -> s);
|
|
ifneq f1.fam_index f2.fam_index "fam_index" (fun s -> s);
|
|
ifneq (Adef.father c1) (Adef.father c2) "father" (fun s -> s);
|
|
ifneq (Adef.mother c1) (Adef.mother c2) "mother" (fun s -> s);
|
|
ifneq d1.children d2.children "children" [%show: string array]
|
|
in
|
|
let string_of_p i =
|
|
Printf.sprintf {|<a href="%s&i=%s">%s</a>|}
|
|
(Util.commd conf :> string)
|
|
(string_of_iper i |> Mutil.encode :> string)
|
|
(Util.designation base (poi base i) : Adef.escaped_string :> string)
|
|
|> Adef.safe
|
|
in
|
|
let string_of_f i =
|
|
let fam = foi base i in
|
|
Printf.sprintf "[%s & %s]"
|
|
(string_of_p @@ get_father fam : Adef.safe_string :> string)
|
|
(string_of_p @@ get_mother fam : Adef.safe_string :> string)
|
|
|> Adef.safe
|
|
in
|
|
let dump string_of dump get data =
|
|
List.iter
|
|
(fun i ->
|
|
Output.print_sstring conf "<b>";
|
|
Output.print_string conf (string_of i);
|
|
Output.print_sstring conf "</b>";
|
|
Output.print_sstring conf "<table>";
|
|
dump (get base' i) (get base i);
|
|
Output.print_sstring conf "</table>")
|
|
data
|
|
in
|
|
dump string_of_p dump_p poi !ipers;
|
|
dump string_of_f dump_f foi !ifams;
|
|
List.iter
|
|
(fun (ifam_opt, iper_opt, opt) ->
|
|
let aux, sou =
|
|
match opt with
|
|
| Some (i, i') -> (ifneq i i', sou base)
|
|
| None -> (ifneq empty_string quest_string, fun _ -> "Dtext")
|
|
in
|
|
Output.print_sstring conf "<table>";
|
|
aux
|
|
(match ifam_opt with
|
|
| Some i -> string_of_f i
|
|
| None -> (
|
|
match iper_opt with
|
|
| Some i -> string_of_p i
|
|
| None -> assert false))
|
|
sou;
|
|
Output.print_sstring conf "</table>")
|
|
!istrs;
|
|
let repost dry txt =
|
|
Output.print_sstring conf {|<form action="|};
|
|
Output.print_string conf (Util.commd conf);
|
|
Output.print_sstring conf {|" method="GET">|};
|
|
Output.print_sstring conf
|
|
{|<input type="hidden" name="m" value="FIXBASE_OK">|};
|
|
if not dry then
|
|
Output.print_sstring conf
|
|
{|<input type="hidden" name="dry_run" value="off">|};
|
|
Output.print_sstring conf
|
|
{|<input type="hidden" name="date_of_last_change" value="|};
|
|
Output.print_sstring conf
|
|
(Gwdb.date_of_last_change base |> string_of_float);
|
|
Output.print_sstring conf {|">|};
|
|
let opt s =
|
|
if UI.enabled conf s then (
|
|
Output.print_sstring conf {|<input type="hidden" name="|};
|
|
Output.print_string conf (Mutil.encode s);
|
|
Output.print_sstring conf {|" value="on">|})
|
|
in
|
|
opt "f_parents";
|
|
opt "f_children";
|
|
opt "p_parents";
|
|
opt "p_NBDS";
|
|
opt "p_families";
|
|
opt "pevents_witnesses";
|
|
opt "fevents_witnesses";
|
|
opt "marriage_divorce";
|
|
opt "missing_spouses";
|
|
opt "invalid_utf8";
|
|
opt "p_key";
|
|
opt "tstab";
|
|
Output.print_sstring conf {|<p>|};
|
|
Output.print_sstring conf {|<input type="submit" value="|};
|
|
Output.print_string conf txt;
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_sstring conf {|</p>|};
|
|
Output.print_sstring conf {|</form>|}
|
|
in
|
|
let tstab () =
|
|
if UI.enabled conf "tstab" then (
|
|
let bname = Util.base_path [] (bname base ^ ".gwb") in
|
|
Mutil.rm (Filename.concat bname "tstab_visitor");
|
|
Mutil.rm (Filename.concat bname "tstab");
|
|
Output.print_sstring conf {|<p>|};
|
|
Output.print_sstring conf (Util.transl conf "plugin_fixbase_ok_tstab");
|
|
Output.print_sstring conf {|</p>|})
|
|
in
|
|
if not dry_run then
|
|
if
|
|
Util.p_getenv conf.env "date_of_last_change"
|
|
= Some (Gwdb.date_of_last_change base |> string_of_float)
|
|
then (
|
|
Gwdb.commit_patches base;
|
|
Output.print_sstring conf {|<p>|};
|
|
Output.print_sstring conf
|
|
(Util.transl conf "plugin_fixbase_ok_commit_patches");
|
|
Output.print_sstring conf {|</p>|};
|
|
tstab ())
|
|
else if !ipers <> [] || !ifams <> [] || !istrs <> [] then (
|
|
Output.print_sstring conf {|<p>|};
|
|
Output.print_sstring conf
|
|
(Util.transl conf "plugin_fixbase_ok_base_changed");
|
|
Output.print_sstring conf {|</p>|};
|
|
repost true (Util.transl conf "plugin_fixbase_ok_refresh" |> Adef.safe))
|
|
else tstab ()
|
|
else if !ipers <> [] || !ifams <> [] || !istrs <> [] then
|
|
repost false (Util.transl conf "plugin_fixbase_ok_apply" |> Adef.safe)
|
|
else (
|
|
Output.print_sstring conf {|<p>|};
|
|
Output.print_sstring conf (Util.transl conf "plugin_fixbase_ok_nothing");
|
|
Output.print_sstring conf {|</p>|});
|
|
Output.print_sstring conf {|<p><a href="|};
|
|
Output.print_string conf (Util.commd conf : Adef.escaped_string);
|
|
Output.print_sstring conf {|&m=FIXBASE">|};
|
|
Output.print_sstring conf (Util.transl conf "plugin_fixbase_ok_return");
|
|
Output.print_sstring conf {|</a></p>|}
|
|
in
|
|
if dry_run then process ()
|
|
else
|
|
Lock.control
|
|
(Mutil.lock_file @@ Util.base_path [] (conf.bname ^ ".gwb"))
|
|
false
|
|
~onerror:(fun () -> !GWPARAM.output_error conf Def.Service_Unavailable)
|
|
process
|
|
|
|
let ns = "fixbase"
|
|
|
|
let _ =
|
|
let aux fn _assets conf base =
|
|
if if opt_manitou then conf.manitou else conf.wizard then (
|
|
fn conf base;
|
|
true)
|
|
else false
|
|
in
|
|
let w_base = Gwd_lib.Request.w_base ~none:(fun _ -> false) in
|
|
Gwd_lib.GwdPlugin.register ~ns
|
|
[
|
|
("FIXBASE", fun assets -> w_base @@ aux fixbase assets);
|
|
("FIXBASE_OK", fun assets -> w_base @@ aux fixbase_ok assets);
|
|
]
|