Initial comit - Clone

bin/gwd/README.md

@@ -0,0 +1,79 @@
+# gwd - The GeneWeb daemon
+
+## Plugins
+
+### Disclaimer
+
+Plugin system allow you to run **ANY** piece of code as a handler
+for any requests.
+
+It means that you could run **harmful** code if you do not control the source
+of compiled.
+
+i.e you should not run plugins using the `-unsafe_*` options unless
+you are developping your own plugin.
+
+*Reliable* plugins are the ones accepted by `-plugin` and `-plugins` option.
+
+*Reliable* means that the compiled code and assets you load are the one used
+in official distribution. It does not make the code safe, but you
+know what is actually running on your machine by reading the source code.
+
+### How to load a plugin in gwd
+
+If you want to control what plugins `gwd` loads, and control the order,
+use the `-plugin path/to/foo` option, and it will load
+`path/to/foo/plugin_foo.cmxs` file.
+
+A simpler solution is to use `-plugins path/to/plugins/` and let
+`gwd` load all available plugins in the directory, using `META` files
+in order to load the plugins in the right order.
+
+### How to write a plugin for gwd
+
+It is expected that you follow a simple architecture when writing a
+plugin for `gwd`.
+
+```
+foo/
+    META
+    assets/
+    dune
+    plugin_foo.cmxs
+```
+
+- `META`: describe your plugin metadata such as name, and dependencies.
+- `assets/`: every static assets needed by you plugin (css, js, images, etc...)
+- `plugin_foo.cmxs`: the which will load handlers.
+
+The `dune` file must define the `plugin` `alias`.
+
+```
+(executable
+  (name plugin_foo)
+  (modes (native plugin))
+)
+
+(alias (name plugin) (deps plugin_foo.cmxs))
+```
+
+#### Allowing gwd to run your plugin
+
+Anything in GeneWeb distribution will be registered in whitelist, and
+gwd will check file integrity before loading the plugin.
+
+You can still execute an untrusted plugin with `-unsafe_plugin`
+and `-unsafe_plugins` options.
+
+#### META file
+
+```
+version: version of your plugin
+maintainers: comma-seperated list of plugin maintainers
+depends: comma-seperated list of other plugins needed
+```
+
+### Stability
+
+Plugin system is new and still under heavy test and development.
+API should not be considered stable yet.

bin/gwd/base64.ml

@@ -0,0 +1,42 @@
+(* $Id: base64.ml,v 5.2 2007-01-19 01:53:16 ddr Exp $ *)
+(* Copyright (c) 1998-2007 INRIA *)
+
+(* For basic credentials only *)
+(* Encoding is [A-Z][a-z][0-9]+/= *)
+(* 3 chars = 24 bits = 4 * 6-bit groups -> 4 chars *)
+
+(* Init the index *)
+let index64 =
+  let index64 = Array.make 128 0 in
+  for i = 0 to 25 do
+    index64.(i + Char.code 'A') <- i
+  done;
+  for i = 0 to 25 do
+    index64.(i + Char.code 'a') <- i + 26
+  done;
+  for i = 0 to 9 do
+    index64.(i + Char.code '0') <- i + 52
+  done;
+  index64.(Char.code '+') <- 62;
+  index64.(Char.code '/') <- 63;
+  index64
+
+let decode s =
+  let rpos = ref 0 and wpos = ref 0 and len = String.length s in
+  let res = Bytes.create (len / 4 * 3) in
+  while !rpos < len do
+    let v1 = index64.(Char.code s.[!rpos]) in
+    let v2 = index64.(Char.code s.[!rpos + 1]) in
+    let v3 = index64.(Char.code s.[!rpos + 2]) in
+    let v4 = index64.(Char.code s.[!rpos + 3]) in
+    let i = (v1 lsl 18) lor (v2 lsl 12) lor (v3 lsl 6) lor v4 in
+    Bytes.set res !wpos (Char.chr (i lsr 16));
+    Bytes.set res (!wpos + 1) (Char.chr ((i lsr 8) land 0xFF));
+    Bytes.set res (!wpos + 2) (Char.chr (i land 0xFF));
+    rpos := !rpos + 4;
+    wpos := !wpos + 3
+  done;
+  let cut =
+    if s.[len - 1] = '=' then if s.[len - 2] = '=' then 2 else 1 else 0
+  in
+  Bytes.sub_string res 0 (Bytes.length res - cut)

bin/gwd/base64.mli

@@ -0,0 +1,2 @@
+val decode : string -> string
+(** Decode {i Base64} binary-to-text encoding used at the moment of basic autorization *)

bin/gwd/dune.in

@@ -0,0 +1,49 @@
+(rule
+  (target gwdPluginMD5.ml)
+  (deps
+    (alias_rec %{project_root}/plugins/plugin)
+    (:maker mk_gwdPluginMD5.ml)
+  )
+  (action (with-stdout-to %{target} (run ocaml %{maker} %{project_root}/plugins)))
+)
+
+(library
+  (name gwd_lib)
+  (public_name geneweb.gwd_lib)
+  (wrapped true)
+  (libraries
+    geneweb
+    wserver
+    %%%GWDB_PKG%%%
+    %%%SOSA_PKG%%%
+    %%%SYSLOG_PKG%%%
+  )
+  (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file})))
+  (modules gwdLog gwdPlugin request)
+)
+
+(executable
+  (name gwd)
+  (public_name geneweb.gwd)
+  (flags -linkall)
+  (libraries
+    dynlink
+    geneweb
+    gwd_lib
+    str
+    unix
+    uri
+    wserver
+    %%%GWDB_PKG%%%
+    %%%SOSA_PKG%%%
+  )
+  (preprocess (action (run %{bin:cppo} %%%CPPO_D%%% %{input-file})))
+  (modules
+    base64
+    gwd
+    gwdPluginDep
+    gwdPluginMD5
+    gwdPluginMETA
+    robot
+  )
+)

bin/gwd/gwdLog.ml

@@ -0,0 +1,80 @@
+let verbosity = ref 7
+let debug = ref false
+
+let oc : out_channel option ref = ref None
+
+let log fn =
+  match !oc with
+  | Some oc -> fn oc
+  | None -> ()
+
+type level =
+  [ `LOG_ALERT
+  | `LOG_CRIT
+  | `LOG_DEBUG
+  | `LOG_EMERG
+  | `LOG_ERR
+  | `LOG_INFO
+  | `LOG_NOTICE
+  | `LOG_WARNING
+  ]
+
+#ifdef SYSLOG
+let syslog (level : level) msg =
+  let flags = if !debug then [`LOG_PERROR] else [] in
+  if !verbosity
+     >=
+     match level with
+     | `LOG_EMERG -> 0
+     | `LOG_ALERT -> 1
+     | `LOG_CRIT -> 2
+     | `LOG_ERR -> 3
+     | `LOG_WARNING -> 4
+     | `LOG_NOTICE -> 5
+     | `LOG_INFO -> 6
+     | `LOG_DEBUG -> 7
+  then begin
+    let log = Syslog.openlog ~flags @@ Filename.basename @@ Sys.executable_name in
+    Syslog.syslog log level msg ;
+    Syslog.closelog log ;
+    if !debug then Printexc.print_backtrace stderr ;
+  end
+#endif
+
+#ifndef SYSLOG
+let syslog (level : level) msg =
+  if !verbosity
+     >=
+     match level with
+     | `LOG_EMERG -> 0
+     | `LOG_ALERT -> 1
+     | `LOG_CRIT -> 2
+     | `LOG_ERR -> 3
+     | `LOG_WARNING -> 4
+     | `LOG_NOTICE -> 5
+     | `LOG_INFO -> 6
+     | `LOG_DEBUG -> 7
+  then begin
+    let tm = Unix.(time () |> localtime) in
+    let level =
+      match level with
+      | `LOG_EMERG -> "EMERGENCY"
+      | `LOG_ALERT -> "ALERT"
+      | `LOG_CRIT -> "CRITICAL"
+      | `LOG_ERR -> "ERROR"
+      | `LOG_WARNING -> "WARNING"
+      | `LOG_NOTICE -> "NOTICE"
+      | `LOG_INFO -> "INFO"
+      | `LOG_DEBUG -> "DEBUG"
+    in
+    let print oc = Printf.fprintf oc "[%s]: %s %s\n" (Mutil.sprintf_date tm :> string) level msg in
+    begin match Sys.getenv_opt "GW_SYSLOG_FILE" with
+      | Some fn ->
+        let oc = open_out_gen [ Open_wronly ; Open_creat ; Open_append ] 0o644 fn in
+        print oc ;
+        close_out oc
+      | None -> print stderr
+    end ;
+    if !debug then Printexc.print_backtrace stderr ;
+  end
+#endif

bin/gwd/gwdLog.mli

@@ -0,0 +1,27 @@
+val verbosity : int ref
+(** Verbosity level: defines the verbosity level that will
+    allow the [syslog] function to print anything. *)
+
+val debug : bool ref
+(** If set to [true], prints backtrace when printing log. *)
+
+val oc : out_channel option ref
+(** The output channel in which log is written. *)
+
+val log : (out_channel -> unit) -> unit
+(** Prints on [oc] *)
+
+type level =
+  [ `LOG_EMERG  (** Print if `!verbosity >= 0` *)
+  | `LOG_ALERT  (** Print if `!verbosity >= 1` *)
+  | `LOG_CRIT  (** Print if `!verbosity >= 2` *)
+  | `LOG_ERR  (** Print if `!verbosity >= 3` *)
+  | `LOG_WARNING  (** Print if `!verbosity >= 4` *)
+  | `LOG_NOTICE  (** Print if `!verbosity >= 5` *)
+  | `LOG_INFO  (** Print if `!verbosity >= 6` *)
+  | `LOG_DEBUG  (** Print if `!verbosity >= 7` *) ]
+(** The level of log. *)
+
+val syslog : level -> string -> unit
+(** [syslog level msg]
+    Prints [msg] on [!oc] depending on the verbosity. *)

bin/gwd/gwdPlugin.ml

@@ -0,0 +1,19 @@
+open Geneweb
+
+let assets = ref ""
+let registered = ref []
+
+let ht : (string, string * (Config.config -> string option -> bool)) Hashtbl.t =
+  Hashtbl.create 0
+
+let register ~ns list =
+  assert (not @@ List.mem ns !registered);
+  registered := ns :: !registered;
+  List.iter
+    (fun (m, fn) ->
+      let fn = fn !assets in
+      Hashtbl.add ht m (ns, fn))
+    list
+
+let se : (string * (Config.config -> string option -> unit)) list ref = ref []
+let register_se ~ns fn = Mutil.list_ref_append se (ns, fn !assets)

bin/gwd/gwdPlugin.mli

@@ -0,0 +1,50 @@
+val assets : string ref
+(** When dynamically loading a plugin, this variable contains
+    the path of the assets directory associated to the plugin
+    being currently loaded.
+*)
+
+val register :
+  ns:string ->
+  (string * (string -> Geneweb.Config.config -> string option -> bool)) list ->
+  unit
+(** [register ~ns handlers] register modes handlers of a plugin.
+
+    [ns] is the namespace of the plugin (i.e. its name)
+
+    [handler] is a associative list of handler.
+    The key is the mode (the `m` GET/POST parameter).
+    The value is the handler itself. The difference between a plugin
+    handler and default gwd's handlers (the ones in request.ml) is that
+    a plugin handler takes an extra (first) argument being
+    the path of the asset directory associated to this plugin
+    and returns a boolean.
+
+    If the handler returns [true], it means that it actually processed
+    the request. If is is [false], [gwd] must try another plugin handler to
+    treat the request. If no plugin is suitable, gwd's default handler
+    must be used, or fail if it does not exists.
+
+    Handlers can overwrite pre-existing modes or create new ones.
+ *)
+
+val ht :
+  (string, string * (Geneweb.Config.config -> string option -> bool)) Hashtbl.t
+(** Table of handlers registered by plugins.  *)
+
+val register_se :
+  ns:string ->
+  (string -> Geneweb.Config.config -> string option -> unit) ->
+  unit
+(** [register_se ~ns hook] register a plugin hook (side effect function).
+
+    If enabled, hooks are executed before the request handlers, in the
+    order of registration (first registred = first executed).
+
+    For exemple, a plugin could be to change the [conf] output to print everything
+    in a buffer and apply a transformation to the resulting document before actually
+    sending it to the client.
+  *)
+
+val se : (string * (Geneweb.Config.config -> string option -> unit)) list ref
+(** Table of hooks registered by plugins. *)

bin/gwd/gwdPluginDep.ml

@@ -0,0 +1,122 @@
+(* https://github.com/dmbaturin/ocaml-tsort *)
+(* Authors: Daniil Baturin (2019), Martin Jambon (2020). *)
+(* See LICENSE at the end of the file *)
+
+(* Adapted to GeneWeb by Julien Sagot *)
+
+type 'a sort_result = Sorted of 'a list | ErrorCycle of 'a list
+
+(* Finds "isolated" nodes,
+   that is, nodes that have no dependencies *)
+let find_isolated_nodes hash =
+  let aux id deps acc = match deps with [] -> id :: acc | _ -> acc in
+  Hashtbl.fold aux hash []
+
+(* Takes a node name list and removes all those nodes from a hash *)
+let remove_nodes nodes hash = List.iter (Hashtbl.remove hash) nodes
+
+(* Walks through a node:dependencies hash and removes a dependency
+   from all nodes that have it in their dependency lists *)
+let remove_dependency hash dep =
+  let aux dep hash id =
+    let deps = Hashtbl.find hash id in
+    let deps = List.filter (( <> ) dep) deps in
+    Hashtbl.remove hash id;
+    Hashtbl.add hash id deps
+  in
+  let ids = Hashtbl.fold (fun k _ a -> k :: a) hash [] in
+  List.iter (aux dep hash) ids
+
+(* Deduplicate list items. *)
+let deduplicate l =
+  let tbl = Hashtbl.create (List.length l) in
+  List.fold_left
+    (fun acc x ->
+      if Hashtbl.mem tbl x then acc
+      else (
+        Hashtbl.add tbl x ();
+        x :: acc))
+    [] l
+  |> List.rev
+
+(*
+   Append missing nodes to the graph, in the order in which they were
+   encountered. This particular order doesn't have to be guaranteed by the
+   API but seems nice to have.
+*)
+let add_missing_nodes graph_l graph =
+  let missing =
+    List.fold_left
+      (fun acc (_, vl) ->
+        List.fold_left
+          (fun acc v ->
+            if not (Hashtbl.mem graph v) then (v, []) :: acc else acc)
+          acc vl)
+      [] graph_l
+    |> List.rev
+  in
+  List.iter (fun (v, vl) -> Hashtbl.replace graph v vl) missing;
+  graph_l @ missing
+
+(* The Kahn's algorithm:
+    1. Find nodes that have no dependencies ("isolated") and remove them from
+       the graph hash.
+       Add them to the initial sorted nodes list and the list of isolated
+       nodes for the first sorting pass.
+    2. For every isolated node, walk through the remaining nodes and
+       remove it from their dependency list.
+       Nodes that only depended on it now have empty dependency lists.
+    3. Find all nodes with empty dependency lists and append them to the sorted
+       nodes list _and_ the list of isolated nodes to use for the next step
+    4. Repeat until the list of isolated nodes is empty
+    5. If the graph hash is still not empty, it means there is a cycle.
+*)
+let sort nodes =
+  let rec sorting_loop deps hash acc =
+    match deps with
+    | [] -> acc
+    | dep :: deps ->
+        let () = remove_dependency hash dep in
+        let isolated_nodes = find_isolated_nodes hash in
+        let () = remove_nodes isolated_nodes hash in
+        sorting_loop
+          (List.append deps isolated_nodes)
+          hash
+          (List.append acc isolated_nodes)
+  in
+  let nodes_hash =
+    let tbl = Hashtbl.create 32 in
+    List.iter (fun (k, v) -> Hashtbl.add tbl k v) nodes;
+    tbl
+  in
+  let _nodes = add_missing_nodes nodes nodes_hash in
+  let base_nodes = find_isolated_nodes nodes_hash in
+  let () = remove_nodes base_nodes nodes_hash in
+  let sorted_node_ids = sorting_loop base_nodes nodes_hash [] in
+  let sorted_node_ids = List.append base_nodes sorted_node_ids in
+  let remaining_ids = Hashtbl.fold (fun k _ a -> k :: a) nodes_hash [] in
+  match remaining_ids with
+  | [] -> Sorted sorted_node_ids
+  | _ -> ErrorCycle remaining_ids
+
+(* MIT License *)
+
+(* Copyright (c) 2019 Daniil Baturin *)
+
+(* Permission is hereby granted, free of charge, to any person obtaining a copy *)
+(* of this software and associated documentation files (the "Software"), to deal *)
+(* in the Software without restriction, including without limitation the rights *)
+(* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell *)
+(* copies of the Software, and to permit persons to whom the Software is *)
+(* furnished to do so, subject to the following conditions: *)
+
+(* The above copyright notice and this permission notice shall be included in all *)
+(* copies or substantial portions of the Software. *)
+
+(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *)
+(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
+(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE *)
+(* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *)
+(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, *)
+(* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE *)
+(* SOFTWARE. *)

bin/gwd/gwdPluginDep.mli

@@ -0,0 +1,9 @@
+type 'a sort_result = Sorted of 'a list | ErrorCycle of 'a list
+
+val sort : ('a * 'a list) list -> 'a sort_result
+(** Given a list of elements (in this case, plugins) and their dependencies,
+    tries to compute a valid order `l` and return `Sorted l` .
+    If there is a cycle, returns `ErrorCycle l'` where `l'` is a dependency
+    cycle.
+    Uses Kahn's algorithm for cycle detection.
+ *)

bin/gwd/gwdPluginMD5.mli

@@ -0,0 +1 @@
+val allowed : string -> bool

bin/gwd/gwdPluginMETA.ml

@@ -0,0 +1,30 @@
+type meta = {
+  version : string;
+  maintainers : string list;
+  depends : string list;
+}
+
+let parse fname =
+  let ic = open_in fname in
+  let rec loop meta =
+    match input_line ic with
+    | exception End_of_file ->
+        close_in ic;
+        meta
+    | s -> (
+        match String.index_opt s ':' with
+        | None -> loop meta
+        | Some i -> (
+            let v =
+              String.trim @@ String.sub s (i + 1) (String.length s - i - 1)
+            in
+            let split_and_trim v =
+              List.map String.trim @@ String.split_on_char ',' v
+            in
+            match String.trim @@ String.sub s 0 i with
+            | "depends" -> loop { meta with depends = split_and_trim v }
+            | "maintainers" -> loop { meta with maintainers = split_and_trim v }
+            | "version" -> loop { meta with version = v }
+            | _ -> loop meta))
+  in
+  loop { version = ""; maintainers = []; depends = [] }

bin/gwd/gwdPluginMETA.mli

@@ -0,0 +1,7 @@
+type meta = {
+  version : string;
+  maintainers : string list;
+  depends : string list;
+}
+
+val parse : string -> meta

bin/gwd/mk_gwdPluginMD5.ml

@@ -0,0 +1,71 @@
+let md5 plugin =
+  let files =
+    let rec loop result = function
+      | [] -> result
+      | f :: fs ->
+          if Sys.file_exists f then
+            if String.get f (String.length f - 1) = '~' then loop result fs
+            else if Sys.is_directory f then
+              Sys.readdir f |> Array.to_list
+              |> List.rev_map (Filename.concat f)
+              |> List.rev_append fs |> loop result
+            else loop (f :: result) fs
+          else loop result fs
+    in
+    loop []
+      [
+        Filename.concat plugin @@ "plugin_" ^ Filename.basename plugin ^ ".cmxs";
+        Filename.concat plugin "assets";
+      ]
+  in
+  let files = List.sort compare files in
+  let b = Buffer.create 1024 in
+  List.iter
+    (fun f -> Digest.file f |> Digest.to_hex |> Buffer.add_string b)
+    files;
+  Buffer.contents b |> Digest.string |> Digest.to_hex
+
+let () =
+  print_endline
+    {|let md5 plugin =
+  let files =
+    let rec loop result = function
+      | [] -> result
+      | f :: fs ->
+        if Sys.file_exists f
+        then
+          if String.get f (String.length f - 1) = '~'
+          then loop result fs
+          else if Sys.is_directory f
+          then
+            Sys.readdir f
+            |> Array.to_list
+            |> List.rev_map (Filename.concat f)
+            |> List.rev_append fs
+            |> loop result
+          else (loop (f :: result) fs)
+        else (loop result fs)
+    in
+    loop [] [ Filename.concat plugin @@ "plugin_" ^ Filename.basename plugin ^ ".cmxs"
+            ; Filename.concat plugin "assets"
+            ]
+  in
+  let files = List.sort compare files in
+  let b = Buffer.create 1024 in
+  List.iter begin fun f ->
+    Digest.file f
+    |> Digest.to_hex
+    |> Buffer.add_string b
+  end files ;
+  Buffer.contents b
+  |> Digest.string
+  |> Digest.to_hex
+|};
+  print_endline {|let allowed p = match Filename.basename p with|};
+  Array.iter
+    (fun p ->
+      print_endline
+      @@ Printf.sprintf {||"%s" -> md5 p = "%s"|} p
+           (md5 @@ Filename.concat Sys.argv.(1) p))
+    (Sys.readdir Sys.argv.(1));
+  print_endline {||_ -> false|}

bin/gwd/request.ml

@@ -0,0 +1,835 @@
+(* 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"> =&gt; |} ;
+  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

bin/gwd/request.mli

@@ -0,0 +1,59 @@
+(* Copyright (c) 1998-2007 INRIA *)
+
+open Geneweb
+
+val make_senv : Config.config -> Gwdb.base -> Config.config
+val make_henv : Config.config -> Gwdb.base -> Config.config
+
+val w_base :
+  none:(Config.config -> 'a) ->
+  (Config.config -> Gwdb.base -> 'a) ->
+  Config.config ->
+  string option ->
+  'a
+(** [w_lock ~none callback conf base]
+    Acquire a write lock on the base and call [callback], or fail with [none].
+*)
+
+val w_lock :
+  onerror:(Config.config -> string option -> 'a) ->
+  (Config.config -> string option -> 'a) ->
+  Config.config ->
+  string option ->
+  'a
+(** [w_lock ~onerror callback conf base]
+    Acquire a write lock on the base and call the callback, or fail with [onerror].
+*)
+
+val w_wizard :
+  (Config.config -> Gwdb.base -> unit) -> Config.config -> Gwdb.base -> unit
+(** [w_wizard callback conf base]
+    Run [callback conf base] if conf has wizard rights or
+    return [Forbidden] or [Unauthorized].
+*)
+
+val w_person :
+  none:(Config.config -> Gwdb.base -> 'a) ->
+  (Config.config -> Gwdb.base -> Gwdb.person -> 'a) ->
+  Config.config ->
+  Gwdb.base ->
+  'a
+(** [w_person ~none callback conf base]
+    Find a person in environement and call [callback], or fail with [none].
+*)
+
+(**/**)
+
+(* Used internally by [gwd]. Not intended to be used by other programs. *)
+val treat_request : Config.config -> unit
+
+(**/**)
+
+(**/**)
+
+(* Used by v7 plugin *)
+val incorrect_request : ?comment:string -> Config.config -> unit
+val very_unknown : Config.config -> Gwdb.base -> unit
+val only_special_env : (string * _) list -> bool
+
+(**/**)

bin/gwd/robot.ml

@@ -0,0 +1,206 @@
+(* Copyright (c) 1998-2007 INRIA *)
+
+open Geneweb
+open Config
+
+let magic_robot = "GWRB0007"
+
+module W = Map.Make (struct
+  type t = string
+
+  let compare = compare
+end)
+
+type norfriwiz = Normal | Friend of string | Wizard of string
+
+type who = {
+  acc_times : float list;
+  oldest_time : float;
+  nb_connect : int;
+  nbase : string;
+  utype : norfriwiz;
+}
+
+type excl = {
+  mutable excl : (string * int ref) list;
+  mutable who : who W.t;
+  mutable max_conn : int * string;
+}
+
+let robot_error conf cnt sec =
+  Output.status conf Def.Forbidden;
+  Output.header conf "Content-type: text/html; charset=iso-8859-1";
+  let env =
+    [
+      ("cnt", Adef.encoded (string_of_int cnt));
+      ("sec", Adef.encoded (string_of_int sec));
+    ]
+  in
+  Util.include_template conf env "robot" (fun () ->
+      let title _ = Output.print_sstring conf "Access refused" in
+      Output.print_sstring conf "<head><title>";
+      title true;
+      Output.print_sstring conf "</title>\n<body>\n<h1>";
+      title false;
+      Output.print_sstring conf "</body>\n");
+  raise Exit
+
+let purge_who tm xcl sec =
+  let sec = float sec in
+  let to_remove =
+    W.fold
+      (fun k who l ->
+        match who.acc_times with
+        | tm0 :: _ -> if tm -. tm0 > sec then k :: l else l
+        | [] -> k :: l)
+      xcl.who []
+  in
+  List.iter (fun k -> xcl.who <- W.remove k xcl.who) to_remove
+
+let input_excl ic =
+  let b = really_input_string ic (String.length magic_robot) in
+  if b <> magic_robot then raise Not_found else (input_value ic : excl)
+
+let output_excl oc xcl =
+  output_string oc magic_robot;
+  output_value oc (xcl : excl)
+
+let robot_excl () =
+  let fname = SrcfileDisplay.adm_file "robot" in
+  let xcl =
+    match try Some (Secure.open_in_bin fname) with _ -> None with
+    | Some ic ->
+        let v =
+          try input_excl ic
+          with _ -> { excl = []; who = W.empty; max_conn = (0, "") }
+        in
+        close_in ic;
+        v
+    | None -> { excl = []; who = W.empty; max_conn = (0, "") }
+  in
+  (xcl, fname)
+
+let min_disp_req = ref 6
+
+let check tm from max_call sec conf suicide =
+  let nfw =
+    if conf.wizard then Wizard conf.user
+    else if conf.friend then Friend conf.user
+    else Normal
+  in
+  let xcl, fname = robot_excl () in
+  let refused =
+    match try Some (List.assoc from xcl.excl) with Not_found -> None with
+    | Some att ->
+        incr att;
+        if !att mod max_call = 0 then
+          Gwd_lib.GwdLog.syslog `LOG_NOTICE
+          @@ Printf.sprintf
+               {|From: %s --- %d refused attempts --- to restore access, delete file "%s"|}
+               from !att fname;
+        true
+    | None ->
+        purge_who tm xcl sec;
+        let r = try (W.find from xcl.who).acc_times with Not_found -> [] in
+        let cnt, tml, tm0 =
+          let sec = float sec in
+          let rec count cnt tml = function
+            | [] -> (cnt, tml, tm)
+            | [ tm1 ] ->
+                if tm -. tm1 < sec then (cnt + 1, tm1 :: tml, tm1)
+                else (cnt, tml, tm1)
+            | tm1 :: tml1 ->
+                if tm -. tm1 < sec then count (cnt + 1) (tm1 :: tml) tml1
+                else (cnt, tml, tm1)
+          in
+          count 1 [] r
+        in
+        let r = List.rev tml in
+        xcl.who <-
+          W.add from
+            {
+              acc_times = tm :: r;
+              oldest_time = tm0;
+              nb_connect = cnt;
+              nbase = conf.bname;
+              utype = nfw;
+            }
+            xcl.who;
+        let refused =
+          if suicide || cnt > max_call then (
+            Gwd_lib.GwdLog.log (fun oc ->
+                Printf.fprintf oc "--- %s is a robot" from;
+                if suicide then
+                  Printf.fprintf oc " (called the \"suicide\" request)\n"
+                else
+                  Printf.fprintf oc
+                    " (%d > %d connections in %g <= %d seconds)\n" cnt max_call
+                    (tm -. tm0) sec);
+            xcl.excl <- (from, ref 1) :: xcl.excl;
+            xcl.who <- W.remove from xcl.who;
+            xcl.max_conn <- (0, "");
+            true)
+          else false
+        in
+        (match xcl.excl with
+        | [ _; _ ] ->
+            Gwd_lib.GwdLog.log (fun oc ->
+                List.iter
+                  (fun (s, att) ->
+                    Printf.fprintf oc "--- excluded:";
+                    Printf.fprintf oc " %s (%d refused attempts)\n" s !att)
+                  xcl.excl;
+                Printf.fprintf oc "--- to restore access, delete file \"%s\"\n"
+                  fname)
+        | _ -> ());
+        let list, nconn =
+          W.fold
+            (fun k w (list, nconn) ->
+              let tm = w.oldest_time in
+              let nb = w.nb_connect in
+              if nb > fst xcl.max_conn then xcl.max_conn <- (nb, k);
+              ( (if nb < !min_disp_req then list else (k, tm, nb) :: list),
+                nconn + 1 ))
+            xcl.who ([], 0)
+        in
+        let list =
+          List.sort
+            (fun (_, tm1, nb1) (_, tm2, nb2) ->
+              match compare nb2 nb1 with 0 -> compare tm2 tm1 | x -> x)
+            list
+        in
+        Gwd_lib.GwdLog.log (fun oc ->
+            List.iter
+              (fun (k, tm0, nb) ->
+                Printf.fprintf oc "--- %3d req - %3.0f sec - %s\n" nb
+                  (tm -. tm0) k)
+              list;
+            Printf.fprintf oc "--- max %d req by %s / conn %d\n"
+              (fst xcl.max_conn) (snd xcl.max_conn) nconn);
+        refused
+  in
+  (match try Some (Secure.open_out_bin fname) with Sys_error _ -> None with
+  | Some oc ->
+      output_excl oc xcl;
+      close_out oc
+  | None -> ());
+  if refused then robot_error conf max_call sec;
+  W.fold
+    (fun _ w (c, cw, cf, wl) ->
+      if w.nbase = conf.bname && w.nbase <> "" then
+        match w.utype with
+        | Wizard n ->
+            let at = List.hd w.acc_times in
+            if List.mem_assoc n wl then
+              let old_at = List.assoc n wl in
+              if at > old_at then
+                let wl = List.remove_assoc n wl in
+                (c, cw, cf, (n, at) :: wl)
+              else (c, cw, cf, wl)
+            else (c + 1, cw + 1, cf, (n, at) :: wl)
+        | Friend _ ->
+            if w.nb_connect > 2 then (c + 1, cw, cf + 1, wl) else (c, cw, cf, wl)
+        | Normal ->
+            if w.nb_connect > 2 then (c + 1, cw, cf, wl) else (c, cw, cf, wl)
+      else (c, cw, cf, wl))
+    xcl.who (0, 0, 0, [])

bin/gwd/robot.mli

@@ -0,0 +1,53 @@
+(** A module handling robots requests *)
+(* S: This module seems obsolete *)
+
+val magic_robot : string
+
+module W : Map.S with type key = string
+
+type norfriwiz = Normal | Friend of string | Wizard of string
+
+type who = private {
+  acc_times : float list;  (** The timings of the connexion attempts *)
+  oldest_time : float;
+      (** The first connection in the specified window
+                           (check option -robot-xcl) of time in which successive
+                           connections are attempted. *)
+  nb_connect : int;  (** The number of connection in the specified window. *)
+  nbase : string;  (** Always be equal to conf.bname *)
+  utype : norfriwiz;  (** The kind of robot *)
+}
+
+type excl = {
+  mutable excl : (string * int ref) list;
+  mutable who : who W.t;
+  mutable max_conn : int * string;
+}
+(** A collection of robots: the list contains forbidden robots and
+    the map contains accepted (under conditions) robots. *)
+
+val robot_error : Geneweb.Config.config -> int -> int -> 'a
+(** Prints an error "Access refuned" in HTML and raises an `Exit` exception. *)
+
+val robot_excl : unit -> excl * string
+(** Reads the content of the admin file managing robots and returns its content
+    and the full file name. *)
+
+val min_disp_req : int ref
+
+val check :
+  float ->
+  string ->
+  int ->
+  int ->
+  Geneweb.Config.config ->
+  bool ->
+  int * int * int * (string * float) list
+(** [check tm from max_call sec conf suicide]
+    Returns a tuple containing:
+    * the number of robots who attempted to connect twice
+    * the number of wizard robots who attempted to connect twice
+    * the number of friend robots who attempted to connect twice
+    * the wizards list and their last connection attempt.
+    It also updates the robot file by blocking robots who did too many attempts.
+*)