836 lines
30 KiB
OCaml
836 lines
30 KiB
OCaml
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Geneweb
|
|
open Config
|
|
open Def
|
|
open Gwdb
|
|
open Util
|
|
|
|
let person_is_std_key conf base p k =
|
|
let k = Name.strip_lower k in
|
|
if k = Name.strip_lower (p_first_name base p ^ " " ^ p_surname base p) then
|
|
true
|
|
else if
|
|
List.exists (fun n -> Name.strip n = k)
|
|
(person_misc_names base p (nobtit conf base))
|
|
then
|
|
true
|
|
else false
|
|
|
|
let select_std_eq conf base pl k =
|
|
List.fold_right
|
|
(fun p pl -> if person_is_std_key conf base p k then p :: pl else pl) pl
|
|
[]
|
|
|
|
let find_all conf base an =
|
|
let sosa_ref = Util.find_sosa_ref conf base in
|
|
let sosa_nb = try Some (Sosa.of_string an) with _ -> None in
|
|
match sosa_ref, sosa_nb with
|
|
| Some p, Some n ->
|
|
if n <> Sosa.zero then
|
|
match Util.branch_of_sosa conf base n p with
|
|
Some (p :: _) -> [p], true
|
|
| _ -> [], false
|
|
else [], false
|
|
| _ ->
|
|
let acc = SearchName.search_by_key conf base an in
|
|
if acc <> [] then acc, false
|
|
else
|
|
( SearchName.search_key_aux begin fun conf base acc an ->
|
|
let spl = select_std_eq conf base acc an in
|
|
if spl = [] then
|
|
if acc = [] then SearchName.search_by_name conf base an
|
|
else acc
|
|
else spl
|
|
end conf base an
|
|
, false )
|
|
|
|
let relation_print conf base p =
|
|
let p1 =
|
|
match p_getenv conf.senv "ei" with
|
|
| Some i ->
|
|
conf.senv <- [] ;
|
|
let i = iper_of_string i in
|
|
if Gwdb.iper_exists base i
|
|
then Some (pget conf base i)
|
|
else None
|
|
| None ->
|
|
match find_person_in_env conf base "1" with
|
|
| Some p1 ->
|
|
conf.senv <- [];
|
|
Some p1
|
|
| None -> None
|
|
in
|
|
RelationDisplay.print conf base p p1
|
|
|
|
let specify conf base n pl =
|
|
let title _ = Output.printf conf "%s : %s" n (transl conf "specify") in
|
|
let n = Name.crush_lower n in
|
|
let ptll =
|
|
List.map
|
|
(fun p ->
|
|
let tl = ref [] in
|
|
let add_tl t =
|
|
tl :=
|
|
let rec add_rec =
|
|
function
|
|
t1 :: tl1 ->
|
|
if eq_istr t1.t_ident t.t_ident &&
|
|
eq_istr t1.t_place t.t_place
|
|
then
|
|
t1 :: tl1
|
|
else t1 :: add_rec tl1
|
|
| [] -> [t]
|
|
in
|
|
add_rec !tl
|
|
in
|
|
let compare_and_add t pn =
|
|
let pn = sou base pn in
|
|
if Name.crush_lower pn = n then add_tl t
|
|
else
|
|
match get_qualifiers p with
|
|
nn :: _ ->
|
|
let nn = sou base nn in
|
|
if Name.crush_lower (pn ^ " " ^ nn) = n then add_tl t
|
|
| _ -> ()
|
|
in
|
|
List.iter
|
|
(fun t ->
|
|
match t.t_name, get_public_name p with
|
|
Tname s, _ -> compare_and_add t s
|
|
| _, pn when sou base pn <> "" -> compare_and_add t pn
|
|
| _ -> ())
|
|
(nobtit conf base p);
|
|
p, !tl)
|
|
pl
|
|
in
|
|
Hutil.header conf title;
|
|
Hutil.print_link_to_welcome conf true;
|
|
(* Si on est dans un calcul de parenté, on affiche *)
|
|
(* l'aide sur la sélection d'un individu. *)
|
|
Util.print_tips_relationship conf;
|
|
Output.print_sstring conf "<ul>\n";
|
|
(* Construction de la table des sosa de la base *)
|
|
let () = SosaCache.build_sosa_ht conf base in
|
|
List.iter
|
|
(fun (p, _tl) ->
|
|
Output.print_sstring conf "<li>\n";
|
|
SosaCache.print_sosa conf base p true;
|
|
Update.print_person_parents_and_spouses conf base p;
|
|
Output.print_sstring conf "</li>\n"
|
|
) ptll;
|
|
Output.print_sstring conf "</ul>\n";
|
|
Hutil.trailer conf
|
|
|
|
let incorrect_request ?(comment = "") conf =
|
|
Hutil.incorrect_request ~comment:comment conf
|
|
|
|
let person_selected conf base p =
|
|
match p_getenv conf.senv "em" with
|
|
Some "R" -> relation_print conf base p
|
|
| Some _ -> incorrect_request conf ~comment:"error #9"
|
|
| None -> record_visited conf (get_iper p); Perso.print conf base p
|
|
|
|
let person_selected_with_redirect conf base p =
|
|
match p_getenv conf.senv "em" with
|
|
| Some "R" -> relation_print conf base p
|
|
| Some _ -> incorrect_request conf ~comment:"error #8"
|
|
| None ->
|
|
Wserver.http_redirect_temporarily
|
|
(commd conf ^^^ Util.acces conf base p :> string)
|
|
|
|
let updmenu_print = Perso.interp_templ "updmenu"
|
|
|
|
let very_unknown conf _ =
|
|
match p_getenv conf.env "n", p_getenv conf.env "p" with
|
|
| Some sname, Some fname ->
|
|
let title _ =
|
|
transl conf "not found"
|
|
|> Utf8.capitalize_fst
|
|
|> Output.print_sstring conf ;
|
|
Output.print_sstring conf (transl conf ":") ;
|
|
Output.print_sstring conf {| "|} ;
|
|
Output.print_string conf (Util.escape_html fname) ;
|
|
Output.print_sstring conf {| |} ;
|
|
Output.print_string conf (Util.escape_html sname) ;
|
|
Output.print_sstring conf {|"|} ;
|
|
in
|
|
Output.status conf Def.Not_Found;
|
|
Hutil.rheader conf title;
|
|
Hutil.print_link_to_welcome conf false;
|
|
Hutil.trailer conf
|
|
| _ ->
|
|
match p_getenv conf.env "i" with
|
|
| Some i ->
|
|
let title _ =
|
|
Output.print_sstring conf "<kbd>" ;
|
|
Output.print_string conf (Util.escape_html i) ;
|
|
Output.print_sstring conf "</kbd>" ;
|
|
Output.print_sstring conf (transl conf ":") ;
|
|
Output.print_sstring conf " " ;
|
|
transl conf "not found"
|
|
|> Utf8.capitalize_fst
|
|
|> Output.print_sstring conf ;
|
|
in
|
|
Output.status conf Def.Not_Found;
|
|
Hutil.rheader conf title;
|
|
Hutil.print_link_to_welcome conf false;
|
|
Hutil.trailer conf
|
|
| None -> Hutil.incorrect_request conf ~comment:"error #1"
|
|
|
|
(* Print Not found page *)
|
|
let unknown conf n =
|
|
let title _ =
|
|
transl conf "not found"
|
|
|> Utf8.capitalize_fst
|
|
|> Output.print_sstring conf ;
|
|
Output.print_sstring conf (transl conf ":") ;
|
|
Output.print_sstring conf {| "|} ;
|
|
Output.print_string conf (Util.escape_html n) ;
|
|
Output.print_sstring conf {|"|} ;
|
|
in
|
|
Output.status conf Def.Not_Found;
|
|
Hutil.rheader conf title;
|
|
Hutil.print_link_to_welcome conf false;
|
|
Hutil.trailer conf
|
|
|
|
let make_henv conf base =
|
|
let conf =
|
|
match Util.find_sosa_ref conf base with
|
|
| Some p ->
|
|
let x =
|
|
let first_name = p_first_name base p in
|
|
let surname = p_surname base p in
|
|
if Util.accessible_by_key conf base p first_name surname then
|
|
[ "pz", Name.lower first_name |> Mutil.encode
|
|
; "nz", Name.lower surname |> Mutil.encode
|
|
; "ocz", get_occ p |> string_of_int |> Mutil.encode
|
|
]
|
|
else [ "iz", get_iper p |> string_of_iper |> Mutil.encode ]
|
|
in
|
|
{ conf with henv = conf.henv @ x }
|
|
| None -> conf
|
|
in
|
|
let conf =
|
|
match p_getenv conf.env "dsrc" with
|
|
| Some "" | None -> conf
|
|
| Some s -> { conf with henv = conf.henv @ ["dsrc", Mutil.encode s] }
|
|
in
|
|
let conf =
|
|
match p_getenv conf.env "templ" with
|
|
| None -> conf
|
|
| Some s -> { conf with henv = conf.henv @ ["templ", Mutil.encode s] }
|
|
in
|
|
let conf =
|
|
match Util.p_getenv conf.env "escache" with
|
|
| Some _ -> { conf with henv = conf.henv @ ["escache", escache_value base] }
|
|
| None -> conf
|
|
in
|
|
let conf =
|
|
if Util.p_getenv conf.env "manitou" = Some "off"
|
|
then { conf with henv = conf.henv @ ["manitou", Adef.encoded "off"] }
|
|
else conf
|
|
in
|
|
let aux param conf =
|
|
match Util.p_getenv conf.env param with
|
|
| Some s -> { conf with henv = conf.henv @ [param, Mutil.encode s] }
|
|
| None -> conf
|
|
in
|
|
aux "alwsurn" conf
|
|
|> aux "pure_xhtml"
|
|
|> aux "size"
|
|
|> aux "p_mod"
|
|
|> aux "wide"
|
|
|
|
let special_vars =
|
|
[ "alwsurn"; "cgl"; "dsrc"; "em"; "ei"; "ep"; "en"; "eoc"; "escache"; "et";
|
|
"iz"; "long"; "manitou"; "nz"; "ocz";
|
|
"p_mod"; "pure_xhtml"; "pz"; "size"; "templ"; "wide" ]
|
|
|
|
let only_special_env env = List.for_all (fun (x, _) -> List.mem x special_vars) env
|
|
|
|
let make_senv conf base =
|
|
let set_senv conf vm vi =
|
|
let aux k v conf =
|
|
if p_getenv conf.env k = Some v
|
|
then { conf with senv = conf.senv @ [ k, Mutil.encode v ] }
|
|
else conf
|
|
in
|
|
let conf =
|
|
{ conf with senv = ["em", vm; "ei", vi] }
|
|
|> aux "long" "on"
|
|
in
|
|
let conf =
|
|
match p_getenv conf.env "et" with
|
|
| Some x -> { conf with senv = conf.senv @ ["et", Mutil.encode x] }
|
|
| _ -> conf
|
|
in
|
|
let conf = aux "cgl" "on" conf in
|
|
let conf =
|
|
match p_getenv conf.env "bd" with
|
|
| None | Some ("0" | "") -> conf
|
|
| Some x -> { conf with senv = conf.senv @ ["bd", Mutil.encode x] }
|
|
in
|
|
match p_getenv conf.env "color" with
|
|
| Some x -> { conf with senv = conf.senv @ ["color", Mutil.encode x] }
|
|
| _ -> conf
|
|
in
|
|
let get x = Util.p_getenv conf.env x in
|
|
match get "em", get "ei", get "ep", get "en", get "eoc" with
|
|
| Some vm, Some vi, _, _, _ -> set_senv conf (Mutil.encode vm) (Mutil.encode vi)
|
|
| Some vm, None, Some vp, Some vn, voco ->
|
|
let voc =
|
|
match voco with
|
|
| Some voc -> (try int_of_string voc with Failure _ -> 0)
|
|
| None -> 0
|
|
in
|
|
let ip =
|
|
match person_of_key base vp vn voc with
|
|
| Some ip -> ip
|
|
| None -> Hutil.incorrect_request conf ~comment:"error #2"; raise Exit
|
|
in
|
|
let vi = string_of_iper ip in
|
|
set_senv conf (Mutil.encode vm) (Mutil.encode vi)
|
|
| _ -> conf
|
|
|
|
let propose_base conf =
|
|
let title _ = Output.print_sstring conf "Base" in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf {|<ul><li><form method="GET" action="|} ;
|
|
Output.print_sstring conf conf.indep_command ;
|
|
Output.print_sstring conf {|">|} ;
|
|
Output.print_sstring conf {|<input name="b" size="40"> => |} ;
|
|
Output.print_sstring conf {|<button type="submit" class="btn btn-secondary btn-lg">|} ;
|
|
transl_nth conf "validate/delete" 0
|
|
|> Utf8.capitalize_fst
|
|
|> Output.print_sstring conf ;
|
|
Output.print_sstring conf "</button></li></ul>";
|
|
Hutil.trailer conf
|
|
|
|
let try_plugin list conf base_name m =
|
|
let fn =
|
|
if List.mem "*" list
|
|
then (fun ( _, fn) -> fn conf base_name)
|
|
else (fun (ns, fn) -> (List.mem ns conf.forced_plugins || List.mem ns list) && fn conf base_name)
|
|
in
|
|
List.exists fn (Hashtbl.find_all GwdPlugin.ht m)
|
|
|
|
let w_lock ~onerror fn conf (base_name : string option) =
|
|
let bfile = Util.bpath (conf.bname ^ ".gwb") in
|
|
Lock.control
|
|
(Mutil.lock_file bfile) true
|
|
~onerror:(fun () -> onerror conf base_name)
|
|
(fun () -> fn conf base_name)
|
|
|
|
let w_base ~none fn conf (bfile : string option) =
|
|
match bfile with
|
|
| None -> none conf
|
|
| Some bfile ->
|
|
let base = try Some (Gwdb.open_base bfile) with _ -> None in
|
|
match base with
|
|
| None -> none conf
|
|
| Some base ->
|
|
let conf = make_henv conf base in
|
|
let conf = make_senv conf base in
|
|
let conf = match Util.default_sosa_ref conf base with
|
|
| Some p -> { conf with default_sosa_ref = get_iper p, Some p;
|
|
nb_of_persons = Gwdb.nb_of_persons base }
|
|
| None -> { conf with
|
|
nb_of_persons = Gwdb.nb_of_persons base }
|
|
in
|
|
fn conf base
|
|
|
|
let w_person ~none fn conf base =
|
|
match find_person_in_env conf base "" with
|
|
| Some p -> fn conf base p
|
|
| _ -> none conf base
|
|
|
|
let output_error ?headers ?content conf code =
|
|
!GWPARAM.output_error ?headers ?content conf code
|
|
|
|
let w_wizard fn conf base =
|
|
if conf.wizard then
|
|
fn conf base
|
|
else if conf.just_friend_wizard then
|
|
output_error conf Def.Forbidden
|
|
else
|
|
(* FIXME: send authentification headers *)
|
|
output_error conf Def.Unauthorized
|
|
|
|
let treat_request =
|
|
let w_lock = w_lock ~onerror:(fun conf _ -> Update.error_locked conf) in
|
|
let w_base =
|
|
let none conf =
|
|
if conf.bname = "" then output_error conf Def.Bad_Request
|
|
else output_error conf Def.Not_Found
|
|
in
|
|
w_base ~none
|
|
in
|
|
let w_person = w_person ~none:very_unknown in
|
|
fun conf ->
|
|
let bfile =
|
|
if conf.bname = "" then None
|
|
else
|
|
let bfile = Util.bpath (conf.bname ^ ".gwb") in
|
|
if Sys.file_exists bfile
|
|
then Some bfile
|
|
else None
|
|
in
|
|
let process () =
|
|
if conf.wizard
|
|
|| conf.friend
|
|
|| List.assoc_opt "visitor_access" conf.base_env <> Some "no"
|
|
then begin
|
|
#ifdef UNIX
|
|
begin match bfile with
|
|
| None -> ()
|
|
| Some bfile ->
|
|
let stat = Unix.stat bfile in
|
|
Unix.setgid stat.Unix.st_gid ;
|
|
Unix.setuid stat.Unix.st_uid ;
|
|
end ;
|
|
#endif
|
|
let plugins =
|
|
match List.assoc_opt "plugins" conf.Config.base_env with
|
|
| None -> []
|
|
| Some list -> String.split_on_char ',' list
|
|
in
|
|
if List.mem "*" plugins then
|
|
List.iter (fun (_ , fn) -> fn conf bfile) !GwdPlugin.se
|
|
else
|
|
List.iter (fun (ns, fn) -> if List.mem ns plugins then fn conf bfile) !GwdPlugin.se ;
|
|
let m = Option.value ~default:"" (p_getenv conf.env "m") in
|
|
if not @@ try_plugin plugins conf bfile m
|
|
then begin
|
|
if List.assoc_opt "counter" conf.base_env <> Some "no" &&
|
|
m <> "IM" && m <> "IM_C" && m <> "SRC" && m <> "DOC"
|
|
then begin
|
|
match
|
|
if only_special_env conf.env
|
|
then SrcfileDisplay.incr_welcome_counter conf
|
|
else SrcfileDisplay.incr_request_counter conf
|
|
with
|
|
| Some (welcome_cnt, request_cnt, start_date) ->
|
|
GwdLog.log begin fun oc ->
|
|
let thousand oc x = output_string oc @@ Mutil.string_of_int_sep "," x in
|
|
Printf.fprintf oc " #accesses %a (#welcome %a) since %s\n"
|
|
thousand (welcome_cnt + request_cnt) thousand welcome_cnt
|
|
start_date
|
|
end ;
|
|
| None -> ()
|
|
end ;
|
|
let incorrect_request ?(comment = "") conf _ =
|
|
incorrect_request ~comment:comment conf
|
|
in
|
|
let doc_aux conf base print =
|
|
match Util.p_getenv conf.env "s" with
|
|
| Some f ->
|
|
if Filename.check_suffix f ".txt" then
|
|
let f = Filename.chop_suffix f ".txt" in
|
|
SrcfileDisplay.print_source conf base f
|
|
else print conf f
|
|
| _ -> incorrect_request conf ~comment:"error #3" base
|
|
in
|
|
match m with
|
|
| "" ->
|
|
let base =
|
|
match bfile with
|
|
| None -> None
|
|
| Some bfile -> try Some (Gwdb.open_base bfile) with _ -> None
|
|
in
|
|
if base <> None then
|
|
w_base @@
|
|
if only_special_env conf.env then SrcfileDisplay.print_start
|
|
else w_person @@ fun conf base p ->
|
|
match p_getenv conf.env "ptempl" with
|
|
| Some t when List.assoc_opt "ptempl" conf.base_env = Some "yes" ->
|
|
Perso.interp_templ t conf base p
|
|
| _ -> person_selected conf base p
|
|
else if conf.bname = ""
|
|
then fun conf _ -> include_template conf [] "index" (fun () -> propose_base conf)
|
|
else
|
|
w_base begin (* print_start -> welcome.txt *)
|
|
if only_special_env conf.env then SrcfileDisplay.print_start
|
|
else w_person @@ fun conf base p ->
|
|
match p_getenv conf.env "ptempl" with
|
|
| Some t when List.assoc_opt "ptempl" conf.base_env = Some "yes" ->
|
|
Perso.interp_templ t conf base p
|
|
| _ -> person_selected conf base p
|
|
end
|
|
|
|
| "A" ->
|
|
AscendDisplay.print |> w_person |> w_base
|
|
| "ADD_FAM" ->
|
|
w_wizard @@ w_base @@ UpdateFam.print_add
|
|
| "ADD_FAM_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_add
|
|
| "ADD_IND" ->
|
|
w_wizard @@ w_base @@ UpdateInd.print_add
|
|
| "ADD_IND_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateIndOk.print_add
|
|
| "ADD_PAR" ->
|
|
w_wizard @@ w_base @@ UpdateFam.print_add_parents
|
|
| "ADD_PAR_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_add_parents
|
|
| "ANM" ->
|
|
w_base @@ fun conf _ -> BirthdayDisplay.print_anniversaries conf
|
|
| "AN" ->
|
|
w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
|
|
| Some x -> BirthdayDisplay.print_birth conf base (int_of_string x)
|
|
| _ -> BirthdayDisplay.print_menu_birth conf base
|
|
end
|
|
| "AD" ->
|
|
w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
|
|
| Some x -> BirthdayDisplay.print_dead conf base (int_of_string x)
|
|
| _ -> BirthdayDisplay.print_menu_dead conf base
|
|
end
|
|
| "AM" ->
|
|
w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
|
|
| Some x -> BirthdayDisplay.print_marriage conf base (int_of_string x)
|
|
| _ -> BirthdayDisplay.print_menu_marriage conf base
|
|
end
|
|
| "AS_OK" ->
|
|
w_base @@ AdvSearchOkDisplay.print
|
|
| "C" ->
|
|
w_base @@ w_person @@ CousinsDisplay.print
|
|
| "CAL" ->
|
|
fun conf _ -> Hutil.print_calendar conf
|
|
| "CHG_CHN" when conf.wizard ->
|
|
w_wizard @@ w_base @@ ChangeChildrenDisplay.print
|
|
| "CHG_CHN_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ ChangeChildrenDisplay.print_ok
|
|
| "CHG_EVT_IND_ORD" ->
|
|
w_wizard @@ w_base @@ UpdateInd.print_change_event_order
|
|
| "CHG_EVT_IND_ORD_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateIndOk.print_change_event_order
|
|
| "CHG_EVT_FAM_ORD" ->
|
|
w_wizard @@ w_base @@ UpdateFam.print_change_event_order
|
|
| "CHG_EVT_FAM_ORD_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_change_event_order
|
|
| "CHG_FAM_ORD" ->
|
|
w_wizard @@ w_base @@ UpdateFam.print_change_order
|
|
| "CHG_FAM_ORD_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_change_order_ok
|
|
| "CONN_WIZ" ->
|
|
w_wizard @@ w_base @@ WiznotesDisplay.connected_wizards
|
|
| "D" ->
|
|
w_base @@ w_person @@ DescendDisplay.print
|
|
| "DAG" ->
|
|
w_base @@ DagDisplay.print
|
|
| "DEL_FAM" ->
|
|
w_wizard @@ w_base @@ UpdateFam.print_del
|
|
| "DEL_FAM_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_del
|
|
|
|
| "DEL_IMAGE" ->
|
|
w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_del
|
|
| "DEL_IMAGE_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_del_ok
|
|
| "DEL_IMAGE_C_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_main_c
|
|
|
|
| "DEL_IND" ->
|
|
w_wizard @@ w_base @@ UpdateInd.print_del
|
|
| "DEL_IND_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateIndOk.print_del
|
|
| "DOC" ->
|
|
w_base @@ fun conf base -> doc_aux conf base
|
|
ImageDisplay.print_source
|
|
| "DOCH" ->
|
|
w_base @@ fun conf base -> doc_aux conf base
|
|
(fun conf _base -> ImageDisplay.print_html conf)
|
|
| "F" ->
|
|
w_base @@ w_person @@ Perso.interp_templ "family"
|
|
| "H" ->
|
|
w_wizard @@ w_base @@ fun conf base ->
|
|
( match p_getenv conf.env "v" with
|
|
| Some f -> SrcfileDisplay.print conf base f
|
|
| None -> incorrect_request conf base ~comment:"error #4")
|
|
| "HIST" ->
|
|
w_base @@ History.print
|
|
| "HIST_CLEAN" ->
|
|
w_wizard @@ w_base @@ fun conf _ -> HistoryDiffDisplay.print_clean conf
|
|
| "HIST_CLEAN_OK" ->
|
|
w_wizard @@ w_base @@ fun conf _ -> HistoryDiffDisplay.print_clean_ok conf
|
|
| "HIST_DIFF" ->
|
|
w_base @@ HistoryDiffDisplay.print
|
|
| "HIST_SEARCH" ->
|
|
w_base @@ History.print_search
|
|
|
|
| "IM_C" ->
|
|
w_base @@ ImageCarrousel.print_c ~saved:false
|
|
| "IM_C_S" ->
|
|
w_base @@ ImageCarrousel.print_c ~saved:true
|
|
|
|
|
|
| "IM" ->
|
|
w_base @@ ImageDisplay.print
|
|
| "IMH" ->
|
|
w_base @@ fun conf _ -> ImageDisplay.print_html conf
|
|
| "INV_FAM" ->
|
|
w_wizard @@ w_base @@ UpdateFam.print_inv
|
|
| "INV_FAM_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_inv
|
|
| "KILL_ANC" ->
|
|
w_wizard @@ w_lock @@ w_base @@ MergeIndDisplay.print_kill_ancestors
|
|
| "L" -> w_base @@ fun conf base -> Perso.interp_templ "list" conf base
|
|
(Gwdb.empty_person base Gwdb.dummy_iper)
|
|
| "LB" when conf.wizard || conf.friend ->
|
|
w_base @@ BirthDeathDisplay.print_birth
|
|
| "LD" when conf.wizard || conf.friend ->
|
|
w_base @@ BirthDeathDisplay.print_death
|
|
| "LINKED" ->
|
|
w_base @@ w_person @@ Perso.print_what_links
|
|
| "LL" ->
|
|
w_base @@ BirthDeathDisplay.print_longest_lived
|
|
| "LM" when conf.wizard || conf.friend ->
|
|
w_base @@ BirthDeathDisplay.print_marriage
|
|
| "MISC_NOTES" ->
|
|
w_base @@ NotesDisplay.print_misc_notes
|
|
| "MISC_NOTES_SEARCH" ->
|
|
w_base @@ NotesDisplay.print_misc_notes_search
|
|
| "MOD_DATA" ->
|
|
w_wizard @@ w_base @@ UpdateDataDisplay.print_mod
|
|
| "MOD_DATA_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateDataDisplay.print_mod_ok
|
|
| "MOD_FAM" ->
|
|
w_wizard @@ w_base @@ UpdateFam.print_mod
|
|
| "MOD_FAM_OK" when conf.wizard ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateFamOk.print_mod
|
|
| "MOD_IND" ->
|
|
w_wizard @@ w_base @@ UpdateInd.print_mod
|
|
| "MOD_IND_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ UpdateIndOk.print_mod
|
|
| "MOD_NOTES" ->
|
|
w_wizard @@ w_base @@ NotesDisplay.print_mod
|
|
| "MOD_NOTES_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ NotesDisplay.print_mod_ok
|
|
| "MOD_WIZNOTES" when conf.authorized_wizards_notes ->
|
|
w_base @@ WiznotesDisplay.print_mod
|
|
| "MOD_WIZNOTES_OK" when conf.authorized_wizards_notes ->
|
|
w_lock @@ w_base @@ WiznotesDisplay.print_mod_ok
|
|
| "MRG" ->
|
|
w_wizard @@ w_base @@ w_person @@ MergeDisplay.print
|
|
| "MRG_DUP" ->
|
|
w_wizard @@ w_base @@ MergeDupDisplay.main_page
|
|
| "MRG_DUP_IND_Y_N" ->
|
|
w_wizard @@ w_lock @@ w_base @@ MergeDupDisplay.answ_ind_y_n
|
|
| "MRG_DUP_FAM_Y_N" ->
|
|
w_wizard @@ w_lock @@ w_base @@ MergeDupDisplay.answ_fam_y_n
|
|
| "MRG_FAM" ->
|
|
w_wizard @@ w_base @@ MergeFamDisplay.print
|
|
| "MRG_FAM_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ MergeFamOk.print_merge
|
|
| "MRG_MOD_FAM_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ MergeFamOk.print_mod_merge
|
|
| "MRG_IND" ->
|
|
w_wizard @@ w_lock @@ w_base @@ MergeIndDisplay.print
|
|
| "MRG_IND_OK" -> (* despite the _OK suffix, this one does not actually update databse *)
|
|
w_wizard @@ w_base @@ MergeIndOkDisplay.print_merge
|
|
| "MRG_MOD_IND_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ MergeIndOkDisplay.print_mod_merge
|
|
| "N" ->
|
|
w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
|
|
| Some v -> Some.search_surname_print conf base Some.surname_not_found v
|
|
| _ -> AllnDisplay.print_surnames conf base
|
|
end
|
|
| "NG" -> w_base @@ begin fun conf base ->
|
|
(* Rétro-compatibilité <= 6.06 *)
|
|
let env =
|
|
match p_getenv conf.env "n" with
|
|
Some n ->
|
|
begin match p_getenv conf.env "t" with
|
|
Some "P" -> ("fn", Mutil.encode n) :: conf.env
|
|
| Some "N" -> ("sn", Mutil.encode n) :: conf.env
|
|
| _ -> ("v", Mutil.encode n) :: conf.env
|
|
end
|
|
| None -> conf.env
|
|
in
|
|
let conf = {conf with env = env} in
|
|
(* Nouveau mode de recherche. *)
|
|
match p_getenv conf.env "select" with
|
|
| Some "input" | None ->
|
|
(* Récupère le contenu non vide de la recherche. *)
|
|
let real_input label =
|
|
match p_getenv conf.env label with
|
|
| Some s -> if s = "" then None else Some s
|
|
| None -> None
|
|
in
|
|
(* Recherche par clé, sosa, alias ... *)
|
|
let search n =
|
|
let (pl, sosa_acc) = find_all conf base n in
|
|
match pl with
|
|
| [] ->
|
|
Some.search_surname_print conf base unknown n
|
|
| [p] ->
|
|
if sosa_acc
|
|
|| Gutil.person_of_string_key base n <> None
|
|
|| person_is_std_key conf base p n
|
|
then person_selected_with_redirect conf base p
|
|
else specify conf base n pl
|
|
| pl -> specify conf base n pl
|
|
in
|
|
begin match real_input "v" with
|
|
| Some n -> search n
|
|
| None ->
|
|
match real_input "fn", real_input "sn" with
|
|
Some fn, Some sn -> search (fn ^ " " ^ sn)
|
|
| Some fn, None ->
|
|
Some.search_first_name_print conf base fn
|
|
| None, Some sn ->
|
|
Some.search_surname_print conf base unknown sn
|
|
| None, None -> incorrect_request conf base ~comment:"error #5"
|
|
end
|
|
| Some i ->
|
|
relation_print conf base
|
|
(pget conf base (iper_of_string i))
|
|
end
|
|
| "NOTES" ->
|
|
w_base @@ NotesDisplay.print
|
|
| "OA" when conf.wizard || conf.friend ->
|
|
w_base @@ BirthDeathDisplay.print_oldest_alive
|
|
| "OE" when conf.wizard || conf.friend ->
|
|
w_base @@ BirthDeathDisplay.print_oldest_engagements
|
|
| "P" ->
|
|
w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
|
|
| Some v -> Some.search_first_name_print conf base v
|
|
| None -> AllnDisplay.print_first_names conf base
|
|
end
|
|
|
|
|
|
| "PERSO" ->
|
|
w_base @@ w_person @@ Geneweb.Perso.interp_templ "perso"
|
|
|
|
| "POP_PYR" when conf.wizard || conf.friend ->
|
|
w_base @@ BirthDeathDisplay.print_population_pyramid
|
|
| "PS" ->
|
|
w_base @@ PlaceDisplay.print_all_places_surnames
|
|
| "PPS" ->
|
|
w_base @@ Place.print_all_places_surnames
|
|
| "R" ->
|
|
w_base @@ w_person @@ relation_print
|
|
| "REFRESH" ->
|
|
w_base @@ w_person @@ Perso.interp_templ "carrousel"
|
|
| "REQUEST" ->
|
|
w_wizard @@ fun _ _ ->
|
|
Output.status conf Def.OK;
|
|
Output.header conf "Content-type: text";
|
|
List.iter begin fun s ->
|
|
Output.print_sstring conf s ;
|
|
Output.print_sstring conf "\n"
|
|
end conf.Config.request ;
|
|
|
|
| "RESET_IMAGE_C_OK" ->
|
|
w_base @@ ImageCarrousel.print_main_c
|
|
|
|
| "RL" ->
|
|
w_base @@ RelationLink.print
|
|
| "RLM" ->
|
|
w_base @@ RelationDisplay.print_multi
|
|
| "S" ->
|
|
w_base @@ fun conf base -> SearchName.print conf base specify unknown
|
|
|
|
| "SND_IMAGE" -> w_wizard @@w_lock @@ w_base @@ ImageCarrousel.print
|
|
| "SND_IMAGE_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_send_ok
|
|
| "SND_IMAGE_C" ->
|
|
w_base @@ w_person @@ Perso.interp_templ "carrousel"
|
|
| "SND_IMAGE_C_OK" ->
|
|
w_wizard @@ w_lock @@ w_base @@ ImageCarrousel.print_main_c
|
|
|
|
| "SRC" ->
|
|
w_base @@ fun conf base -> begin match p_getenv conf.env "v" with
|
|
| Some f -> SrcfileDisplay.print_source conf base f
|
|
| _ -> incorrect_request conf base ~comment:"error #6"
|
|
end
|
|
| "STAT" ->
|
|
w_base @@ fun conf _ -> BirthDeathDisplay.print_statistics conf
|
|
| "CHANGE_WIZ_VIS" ->
|
|
w_wizard @@ w_lock @@ w_base @@ WiznotesDisplay.change_wizard_visibility
|
|
| "TP" ->
|
|
w_base @@ fun conf base ->
|
|
begin match Util.p_getenv conf.env "v" with
|
|
| Some f ->
|
|
begin match Util.find_person_in_env conf base "" with
|
|
| Some p -> Perso.interp_templ ("tp_" ^ f) conf base p
|
|
| _ -> Perso.interp_templ ("tp0_" ^ f) conf base
|
|
(Gwdb.empty_person base Gwdb.dummy_iper)
|
|
end
|
|
| None -> incorrect_request conf base ~comment:"error #7"
|
|
end
|
|
| "TT" ->
|
|
w_base @@ TitleDisplay.print
|
|
| "U" ->
|
|
w_wizard @@ w_base @@ w_person @@ updmenu_print
|
|
| "VIEW_WIZNOTES" when conf.authorized_wizards_notes ->
|
|
w_wizard @@ w_base @@ WiznotesDisplay.print_view
|
|
| "WIZNOTES" when conf.authorized_wizards_notes ->
|
|
w_base @@ WiznotesDisplay.print
|
|
| "WIZNOTES_SEARCH" when conf.authorized_wizards_notes ->
|
|
w_base @@ WiznotesDisplay.print_search
|
|
| _ ->
|
|
w_base @@ fun conf base ->
|
|
incorrect_request conf base ~comment:"error #10"
|
|
end conf bfile ;
|
|
end else begin
|
|
let title _ =
|
|
Printf.sprintf "%s %s %s"
|
|
(transl conf "base" |> Utf8.capitalize_fst)
|
|
conf.bname
|
|
(transl conf "reserved to friends or wizards")
|
|
|> Output.print_sstring conf
|
|
in
|
|
Hutil.rheader conf title ;
|
|
let base_name =
|
|
if conf.cgi then (Printf.sprintf "b=%s&" conf.bname) else ""
|
|
in
|
|
let user = transl_nth conf "user/password/cancel" 0 in
|
|
let passwd = transl_nth conf "user/password/cancel" 1 in
|
|
let body =
|
|
if conf.cgi then
|
|
Printf.sprintf {|
|
|
<input type="text" class="form-control" name="w"
|
|
title="%s/%s %s" placeholder="%s:%s"
|
|
aria-label="password input"
|
|
aria-describedby="username:password" autofocus>
|
|
<label for="w" class="sr-only">%s:%s</label>
|
|
<div class="input-group-append">
|
|
<button type="submit" class="btn btn-primary">OK</button>
|
|
</div>|}
|
|
(transl_nth conf "wizard/wizards/friend/friends/exterior" 2)
|
|
(transl_nth conf "wizard/wizards/friend/friends/exterior" 0)
|
|
passwd user passwd user passwd
|
|
else
|
|
Printf.sprintf {|
|
|
<div>
|
|
<ul>
|
|
<li>%s%s <a href="%s?%sw=f"> %s</a></li>
|
|
<li>%s%s <a href="%s?%sw=w"> %s</a></li>
|
|
</ul>
|
|
</div> |}
|
|
(transl conf "access" |> Utf8.capitalize_fst) (transl conf ":")
|
|
(conf.command :> string) base_name
|
|
(transl_nth conf "wizard/wizards/friend/friends/exterior" 2)
|
|
(transl conf "access" |> Utf8.capitalize_fst) (transl conf ":")
|
|
(conf.command :> string) base_name
|
|
(transl_nth conf "wizard/wizards/friend/friends/exterior" 0)
|
|
in
|
|
Output.print_sstring conf
|
|
(Printf.sprintf {|
|
|
<form class="form-inline" method="post" action="%s">
|
|
<div class="input-group mt-1">
|
|
<input type="hidden" name="b" value="%s">
|
|
%s
|
|
</div>
|
|
</form>
|
|
|} (conf.command :> string) (conf.bname) body
|
|
);
|
|
Hutil.trailer conf
|
|
end
|
|
in
|
|
if conf.debug then Mutil.bench (__FILE__ ^ " " ^ string_of_int __LINE__) process
|
|
else process ()
|
|
|
|
let treat_request conf =
|
|
try treat_request conf with Update.ModErr _ -> Output.flush conf
|