bin/distrib/setup/setup.camlp5

open Geneweb

let port = ref 2316
let gwd_port = ref 2317
let default_lang = ref "en"
let setup_dir = ref "."
let bin_dir = ref ""
let base_dir = ref ""
let lang_param = ref ""
let only_file = ref ""
let bname = ref ""
let commnd = ref ""

let slashify s =
  String.map (function '\\' -> '/' | c -> c) s

let slashify_linux_dos s =
  String.map (function '/' when not Sys.unix -> '\\' | c -> c) s

let rec list_remove_assoc x =
  function
    (x1, y1) :: l -> if x = x1 then l else (x1, y1) :: list_remove_assoc x l
  | [] -> []

let rec list_assoc_all x =
  function
    [] -> []
  | (a, b) :: l ->
      if a = x then b :: list_assoc_all x l else list_assoc_all x l

type config =
  { lang : string;
    comm : string;
    env : (string * string) list;
    request : string list;
    lexicon : (string, string) Hashtbl.t }

let transl conf w =
  try Hashtbl.find conf.lexicon w with Not_found -> "[" ^ w ^ "]"

let charset conf =
  try Hashtbl.find conf.lexicon " !charset" with Not_found -> "utf-8"

let header_no_page_title conf title =
  Wserver.http HttpStatus.OK;
  Wserver.header "Content-type: text/html; charset=%s" (charset conf);
  Wserver.printf
    "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \
     \"http://www.w3.org/TR/REC-html40/loose.dtd\">\n";
  Wserver.printf "<head>\n";
  Wserver.printf "  <meta name=\"robots\" content=\"none\">\n";
  Wserver.printf "  <title>";
  title true;
  Wserver.printf "</title>\n";
  Wserver.printf "</head>\n";
  Wserver.printf "<body>\n"

let abs_setup_dir () =
  if Filename.is_relative !setup_dir then
    Filename.concat (Sys.getcwd ()) !setup_dir
  else !setup_dir

let trailer _conf =
  Wserver.printf "\n<br />\n";
  Wserver.printf "<div id=\"footer\">\n";
  Wserver.printf "<hr />\n";
  Wserver.printf "<div>\n";
  Wserver.printf "<em>\n";
  Wserver.printf "<a href=\"https://github.com/geneweb/geneweb/\">\
                  <img src=\"images/logo_bas.png\" style = \"border: 0\" /></a> \
                  Version %s Copyright &copy 1998-2017\n</em>\n" Version.txt;
  Wserver.printf "</div>\n";
  Wserver.printf "</div>\n";
  (* finish the html page *)
  Wserver.printf "</body>\n";
  Wserver.printf "</html>\n"

let header conf title =
  header_no_page_title conf title;
  Wserver.printf "<h1>";
  title false;
  Wserver.printf "</h1>\n"

let strip_control_m s =
  let rec loop i len =
    if i = String.length s then Buff.get len
    else if s.[i] = '\r' then loop (i + 1) len
    else loop (i + 1) (Buff.store len s.[i])
  in
  loop 0 0

let strip_spaces str =
  let start =
    let rec loop i =
      if i = String.length str then i
      else
        match str.[i] with
          ' ' | '\r' | '\n' | '\t' -> loop (i + 1)
        | _ -> i
    in
    loop 0
  in
  let stop =
    let rec loop i =
      if i = -1 then i + 1
      else
        match str.[i] with
          ' ' | '\r' | '\n' | '\t' -> loop (i - 1)
        | _ -> i + 1
    in
    loop (String.length str - 1)
  in
  if start = 0 && stop = String.length str then str
  else if start > stop then ""
  else String.sub str start (stop - start)

let code_varenv = Wserver.encode
let decode_varenv = Wserver.decode

let getenv env label = decode_varenv (List.assoc (decode_varenv label) env)

let p_getenv env label = try Some (getenv env label) with Not_found -> None

let s_getenv env label = try getenv env label with Not_found -> ""

let rec skip_spaces s i =
  if i < String.length s && s.[i] = ' ' then skip_spaces s (i + 1) else i

let create_env s =
  let rec get_assoc beg i =
    if i = String.length s then
      if i = beg then [] else [String.sub s beg (i - beg)]
    else if s.[i] = ';' || s.[i] = '&' then
      let next_i = skip_spaces s (succ i) in
      String.sub s beg (i - beg) :: get_assoc next_i next_i
    else get_assoc beg (succ i)
  in
  let rec separate i s =
    if i = String.length s then s, ""
    else if s.[i] = '=' then
      String.sub s 0 i, String.sub s (succ i) (String.length s - succ i)
    else separate (succ i) s
  in
  List.map (separate 0) (get_assoc 0 0)

let numbered_key k =
  if k = "" then None
  else
    match k.[String.length k - 1] with
      '1'..'9' as c -> Some (String.sub k 0 (String.length k - 1), c)
    | _ -> None

let stringify s =
  try let _ = String.index s ' ' in "\"" ^ s ^ "\"" with Not_found -> s

let parameters =
  let rec loop comm =
    function
      (k, s) :: env ->
        let k = strip_spaces (decode_varenv k) in
        let s = strip_spaces (decode_varenv s) in
        if k = "" || s = "" then loop comm env
        else if k = "opt" then loop comm env
        else if k = "anon" then loop (comm ^ " " ^ stringify s) env
        else
          begin match numbered_key k with
            Some (k, '1') ->
              let (s, env) =
                let rec loop s =
                  function
                    (k1, s1) :: env as genv ->
                      begin match numbered_key k1 with
                        Some (k1, _) when k1 = k ->
                          let s1 = strip_spaces (decode_varenv s1) in
                          let s =
                            if s1 = "" then s else s ^ " \"" ^ s1 ^ "\""
                          in
                          loop s env
                      | _ -> s, genv
                      end
                  | [] -> s, []
                in
                loop ("\"" ^ s ^ "\"") env
              in
              loop (comm ^ " -" ^ k ^ " " ^ s) env
          | Some _ -> loop comm env
          | None ->
              if s = "none" then loop comm env
              else if s = "on" then loop (comm ^ " -" ^ k) env
              else if s.[0] = '_' then
                loop (comm ^ " -" ^ k ^ stringify s) env
              else if s.[String.length s - 1] = '_' then
                loop (comm ^ " -" ^ s ^ k) env
              else loop (comm ^ " -" ^ k ^ " " ^ stringify s) env
          end
    | [] -> comm
  in
  loop ""

let parameters_1 =
  let rec loop comm bname =
    function
    | (k, s) :: env ->
        let k = strip_spaces (decode_varenv k) in
        let s = strip_spaces (decode_varenv s) in
        if k = "" || s = "" then loop comm bname env
        else if k = "opt" then loop comm bname env
        else if k = "gwd_p" && s <> "" then loop (comm ^ " -gwd_p " ^ stringify s ) bname env
        else if k = "anon" && s <> "" then loop (comm ^ " " ^ stringify s) (stringify s) env
        else if k = "a" then loop (comm ^ " -a") bname env
        else if k = "s" then loop (comm ^ " -s") bname env
        else if k = "d" && s <> "" then loop (comm ^ " -d " ^ stringify s ) bname env
        else if k = "i" && s <> "" then loop (comm ^ " -i " ^ stringify s) bname env
        else if k = "bf" then loop (comm ^ " -bf") bname env
        else if k = "del" && s <> "" then loop (comm ^ " -del " ^ stringify s) bname env
        else if k = "cnt" && s <> "" then loop (comm ^ " -cnt " ^ stringify s) bname env
        else if k = "exact" then loop (comm ^ " -exact") bname env
        else if k = "o1" && s <> "" then
          let out = stringify s in
          comm ^ " -o " ^ out ^ " > " ^ out
        else if k = "o" && s <> "" then
          if s = "choice" then loop comm bname env
          else
            let out = stringify s in
            let out = if out = "/notes_d/connex.txt" then bname  ^ ".gwb" ^ out else out in
            let out = slashify_linux_dos out in
            comm ^ " -o " ^ out ^ " > " ^ out
        else loop comm bname env
    | [] -> comm
  in
  loop "" ""

let parameters_2 =
  let rec loop comm =
    function
    | (k, s) :: env ->
        let k = strip_spaces (decode_varenv k) in
        let s = strip_spaces (decode_varenv s) in
        if k = "" || s = "" then loop comm env
        else if k = "opt" then loop comm env
        else if k = "anon1" then loop (comm ^ " " ^ stringify s) env
        else if k = "anon2" then loop (comm ^ " " ^ stringify s) env
        else if k = "a1" then loop (comm ^ " -1 " ^ stringify s) env
        else if k = "a2" then loop (comm ^ " " ^ stringify s) env
        else if k = "a3" then loop (comm ^ " " ^ stringify s) env
        else if k = "b1" then loop (comm ^ " -2 "  ^ stringify s) env
        else if k = "b2" then loop (comm ^ " " ^ stringify s) env
        else if k = "b3" then loop (comm ^ " " ^ stringify s) env
        else if k = "ad" then loop (comm ^ " -ad ") env
        else if k = "d" then loop (comm ^ " -d ") env
        else if k = "mem" then loop (comm ^ " -mem") env
        else if k = "o" then loop (comm ^ " -o " ^ stringify s ^ " > " ^ stringify s) env
        else loop comm env
    | [] -> comm
  in
  loop ""


let rec list_replace k v =
  function
    [] -> [k, v]
  | (k1, _) :: env when k1 = k -> (k1, v) :: env
  | kv :: env -> kv :: list_replace k v env

let conf_with_env conf k v = {conf with env = list_replace k v conf.env}

let all_db dir =
  let list = ref [] in
  let dh = Unix.opendir dir in
  begin try
    while true do
      let e = Unix.readdir dh in
      if Filename.check_suffix e ".gwb" then
        list := Filename.chop_suffix e ".gwb" :: !list
    done
  with End_of_file -> ()
  end;
  Unix.closedir dh;
  list := List.sort compare !list;
  !list

let selected env =
  List.fold_right (fun (k, v) env -> if v = "on_" then k :: env else env) env
    []

let parse_upto lim =
  let rec loop len =
    parser
      [< 'c when c = lim >] -> Buff.get len
    | [< 'c; a = loop (Buff.store len c) >] -> a
  in
  loop 0

let parse_upto_void lim =
  let rec loop len =
    parser
      [< 'c when c = lim >] -> ()
    | [< 'c; a = loop (Buff.store len c) >] -> a
  in
  loop 0

let is_directory x =
  try (Unix.lstat x).Unix.st_kind = Unix.S_DIR with
    Unix.Unix_error (_, _, _) -> false

let server_string conf =
  let s = Wserver.extract_param "host: " '\r' conf.request in
  try let i = String.rindex s ':' in String.sub s 0 i with
    Not_found -> "127.0.0.1"

let referer conf = Wserver.extract_param "referer: " '\r' conf.request

let only_file_name () =
  if !only_file = "" then Filename.concat !setup_dir "only.txt"
  else !only_file

let macro conf =
  function
    '/' -> if Sys.unix then "/" else "\\"
  | 'a' -> strip_spaces (s_getenv conf.env "anon")
  | 'c' -> stringify !setup_dir
  | 'd' -> conf.comm
  | 'i' -> strip_spaces (s_getenv conf.env "i")
  | 'l' -> conf.lang
  | 'm' -> server_string conf
  | 'n' -> referer conf
  | 'o' -> strip_spaces (s_getenv conf.env "o")
  | 'O' -> Filename.remove_extension (Filename.basename (strip_spaces (s_getenv conf.env "o")))
  | 'p' -> parameters conf.env
  | 'q' -> Version.txt
  | 'u' -> Filename.dirname (abs_setup_dir ())
  | 'x' -> stringify !bin_dir
  | 'w' -> slashify (Sys.getcwd ())
  | 'y' -> Filename.basename (only_file_name ())
  | '%' -> "%"
  | 'K' -> (* print the name of -o filename, prepend bname or -o1 filename *)
    let outfile1 = strip_spaces (s_getenv conf.env "o") in
    let bname = strip_spaces (s_getenv conf.env "anon") in
    let outfile2 = strip_spaces (s_getenv conf.env "o1") in
    let outfile =
      if outfile2 <> "" then outfile2
      else if bname <> ""
      then slashify_linux_dos bname ^ ".gwb" ^ outfile1
      else outfile1
    in
    outfile
  | 'P' -> string_of_int !gwd_port
  | 'Q' -> parameters_1 conf.env
  | 'R' -> parameters_2 conf.env
  | c -> "BAD MACRO " ^ String.make 1 c

let get_variable strm =
  let rec loop len =
    match strm with parser
      [< '';' >] -> Buff.get len
    | [< 'c >] -> loop (Buff.store len c)
  in
  loop 0

let get_binding strm =
  let rec loop len =
    match strm with parser
      [< ''=' >] -> let k = Buff.get len in k, get_variable strm
    | [< 'c >] -> loop (Buff.store len c)
  in
  loop 0

let variables bname =
  let dir = Filename.concat !setup_dir "setup" in
  let fname = Filename.concat (Filename.concat dir "lang") bname in
  let ic = open_in fname in
  let strm = Stream.of_channel ic in
  let (vlist, flist) =
    let rec loop (vlist, flist) =
      match strm with parser
        [< ''%';
           vlist, flist =
             parser
               [< >] ->
                 match strm with parser
                   [< ''E' | 'C' >] ->
                     let (v, _) = get_binding strm in
                     if not (List.mem v vlist) then v :: vlist, flist
                     else vlist, flist
                 | [< ''V' >] ->
                     let v = get_variable strm in
                     if not (List.mem v vlist) then v :: vlist, flist
                     else vlist, flist
                 | [< ''F' >] ->
                     let v = get_variable strm in
                     if not (List.mem v flist) then vlist, v :: flist
                     else vlist, flist
                 | [< >] -> vlist, flist ?! >] ->
          loop (vlist, flist)
      | [< '_ >] -> loop (vlist, flist)
      | [< >] -> vlist, flist
    in
    loop ([], [])
  in
  close_in ic; List.rev vlist, flist

let nth_field s n =
  let rec loop nth i =
    let j = try String.index_from s i '/' with Not_found -> String.length s in
    if nth = n then String.sub s i (j - i)
    else if j = String.length s then s
    else loop (nth + 1) (j + 1)
  in
  loop 0 0

let translate_phrase lexicon s n =
  let n =
    match n with
      Some n -> n
    | None -> 0
  in
  try let s = Hashtbl.find lexicon s in nth_field s n with
    Not_found -> "[" ^ nth_field s n ^ "]"

let file_contents fname =
  try
    let ic = open_in fname in
    let rec loop len =
      match try Some (input_char ic) with End_of_file -> None with
      | Some '\r' -> loop len
      | Some c -> loop (Buff.store len c)
      | None -> close_in ic ; Buff.get len
    in loop 0
  with Sys_error _ -> ""

let cut_at_equal s =
  match String.index_opt s '=' with
  | Some i ->
    (String.sub s 0 i, String.sub s (succ i) (String.length s - succ i))
  | None -> (s, "")

let read_base_env bname =
  let fname = bname ^ ".gwf" in
  match try Some (open_in fname) with Sys_error _ -> None with
  | Some ic ->
    let rec loop env =
      match try Some (input_line ic) with End_of_file -> None with
      | None -> close_in ic ; env
      | Some s ->
        if s = "" || s.[0] = '#'
        then loop env
        else loop (cut_at_equal s :: env)
    in
    loop []
  | None -> []

let rec copy_from_stream conf print strm =
  try
    while true do
      match Stream.next strm with
        '[' ->
          begin match Stream.peek strm with
            Some '\n' ->
              let s = parse_upto ']' strm in
              let (s, alt) = Translate.inline conf.lang '%' (macro conf) s in
              let s = if alt then "[" ^ s ^ "]" else s in print s
          | _ ->
              let s =
                let rec loop len =
                  match strm with parser
                    [< '']' >] -> Buff.get len
                  | [< 'c >] -> loop (Buff.store len c)
                  | [< >] -> Buff.get len
                in
                loop 0
              in
              let n =
                match strm with parser
                  [< ''0'..'9' as c >] -> Some (Char.code c - Char.code '0')
                | [< >] -> None
              in
              print (translate_phrase conf.lexicon s n)
          end
      | '%' ->
          let c = Stream.next strm in
          begin match c with
            'b' -> for_all conf print (all_db ".") strm
          | 'e' ->
              print "lang=";
              print conf.lang;
              List.iter
                (fun (k, s) ->
                   if k = "opt" then ()
                   else begin print ";"; print k; print "="; print s; () end)
                conf.env
          | 'f' ->
              (* see r *)
                let in_file = get_variable strm in
                let s =
                  file_contents
                    (slashify_linux_dos (!bin_dir ^ "/setup/" ^ in_file))
                in
                let in_base = strip_spaces (s_getenv conf.env "anon") in
                let benv = read_base_env in_base in
                let conf = { conf with env = benv @ conf.env} in
                (* depending on when %f is called, conf may be sketchy *)
                (* conf will know bvars from basename.gwf and evars from url *)
                copy_from_stream conf print (Stream.of_string s)
          | 'g' -> print_specific_file conf print "comm.log" strm
          | 'h' ->
              print "<input type=hidden name=lang value=";
              print conf.lang;
              print ">\n";
              List.iter
                (fun (k, s) ->
                   if k <> "opt" then
                     begin
                       print "<input type=hidden name=";
                       print k;
                       print " value=\"";
                       print (decode_varenv s);
                       print "\">\n"
                     end)
                conf.env
          | 'j' -> print_selector conf print
          | 'k' -> for_all conf print (fst (List.split conf.env)) strm
          | 'r' ->
              print_specific_file conf print
                (Filename.concat !setup_dir "gwd.arg") strm
          | 's' -> for_all conf print (selected conf.env) strm
          | 't' -> print_if conf print (if Sys.unix then false else true) strm
          | 'v' ->
              let out = strip_spaces (s_getenv conf.env "o") in
              print_if conf print (Sys.file_exists (out ^ ".gwb")) strm
          | 'y' -> for_all conf print (all_db (s_getenv conf.env "anon")) strm
          | 'z' -> print (string_of_int !port)
          | 'A'..'Z' | '0'..'9' as c ->
              begin match c with
              | 'C' | 'E' ->
                  let (k, v) = get_binding strm in
                  begin match p_getenv conf.env k with
                    Some x ->
                      if x = v then
                        print (if c = 'C' then " checked" else " selected")
                  | None -> ()
                  end
              | 'L' ->
                  let lang = get_variable strm in
                  let lang_def = transl conf " !languages" in
                  print (Translate.language_name lang lang_def)
              | 'V' | 'F' ->
                  let k = get_variable strm in
                  begin match p_getenv conf.env k with
                    Some v -> print v
                  | None -> ()
                  end
              | 'G' -> print_specific_file_tail conf print "gwsetup.log" strm
              | 'H' ->
                  (* print the content of -o filename, prepend bname *)
                  let outfile = strip_spaces (s_getenv conf.env "o") in
                  let bname = strip_spaces (s_getenv conf.env "anon") in
                  let outfile = if bname <> ""
                    then slashify_linux_dos bname ^ ".gwb" ^ outfile
                    else outfile
                  in
                  print_specific_file conf print outfile strm;
              | 'I' ->
                  (* %Ivar;value;{var = value part|false part} *)
                  (* var is a evar from url or a bvar from basename.gwf or setup.gwf *)
                  let k1 = get_variable strm in
                  let k2 = get_variable strm in
                  print_if_else conf print (p_getenv conf.env k1 = Some k2) strm
              | 'O' ->
                  let fname = Filename.remove_extension (Filename.basename (strip_spaces (s_getenv conf.env "o"))) in
                  let fname = slashify_linux_dos fname in
                  print fname
              | 'P' -> print (string_of_int !gwd_port)
              | 'Q' -> print (parameters_1 conf.env) (* same as p *)
              | 'R' -> print (parameters_2 conf.env) (* same as p *)
              | _ ->
                  match p_getenv conf.env (String.make 1 c) with
                    | Some v ->
                      begin match strm with parser
                        [< ''{' >] ->
                          let s = parse_upto '}' strm in
                          print "\"";
                          print s;
                          print "\"";
                          if v = s then print " selected"
                      | [< ''[' >] ->
                          let s = parse_upto ']' strm in
                          print "\"";
                          print s;
                          print "\"";
                          if v = s then print " checked"
                      | [< >] -> print (strip_spaces v) end
                  | None -> print "BAD MACRO 2 "
              end
          | c -> print (macro conf c)
          end
      | c -> print (String.make 1 c)
    done
  with Stream.Failure -> ()
and print_specific_file conf print fname strm =
  match Stream.next strm with
    '{' ->
      let s = parse_upto '}' strm in
      if Sys.file_exists fname then
        let ic = open_in fname in
        if in_channel_length ic = 0 then
          copy_from_stream conf print (Stream.of_string s)
        else copy_from_stream conf print (Stream.of_channel ic);
        close_in ic
      else copy_from_stream conf print (Stream.of_string s)
  | _ -> ()
and print_specific_file_tail conf print fname strm =
  match Stream.next strm with
    '{' ->
      let s = parse_upto '}' strm in
      if Sys.file_exists fname then begin
        let ic = open_in fname in
        if in_channel_length ic = 0 then
          copy_from_stream conf print (Stream.of_string s)
        else copy_from_stream conf print (Stream.of_channel ic);
        close_in ic
      end
      else copy_from_stream conf print (Stream.of_string s)
  | _ -> ()
and print_selector conf print =
  let sel =
    try getenv conf.env "sel" with
      Not_found -> try Sys.getenv "HOME" with Not_found -> Sys.getcwd ()
  in
  let list =
    let sel =
      if Sys.unix then sel
      else if String.length sel = 3 && sel.[1] = ':' && sel.[2] = '\\' then
        sel ^ "."
      else sel
    in
    try
      let dh = Unix.opendir sel in
      let rec loop list =
        match try Some (Unix.readdir dh) with End_of_file -> None with
          Some x ->
            let list =
              if x = ".." then x :: list
              else if String.length x > 0 && x.[0] = '.' then list
              else x :: list
            in
            loop list
        | None -> List.sort compare list
      in
      loop []
    with Unix.Unix_error (_, _, _) -> [".."]
  in
  print "<pre>\n";
  print "     ";
  print "<input type=hidden name=anon value=\"";
  print sel;
  print "\">";
  print sel;
  let list =
    List.map
      (fun x ->
         let d =
           if x = ".." then
             if Sys.unix then Filename.dirname sel
             else if sel.[String.length sel - 1] <> '\\' then
               Filename.dirname sel ^ "\\"
             else Filename.dirname sel
           else Filename.concat sel x
         in
         let x = if is_directory d then Filename.concat x "" else x in d, x)
      list
  in
  let max_len =
    List.fold_left (fun max_len (_, x) -> max max_len (String.length x)) 0
      list
  in
  let min_interv = 2 in
  let line_len = 72 in
  let n_by_line = max 1 ((line_len + min_interv) / (max_len + min_interv)) in
  let newline () = print "\n" in
  newline ();
  begin let rec loop i =
    function
      (d, x) :: list ->
        print "<a class=\"j\" href=\"";
        print conf.comm;
        print "?lang=";
        print conf.lang;
        print ";";
        List.iter
          (fun (k, v) ->
             if k <> "sel" && k <> "body_prop"
             then begin print k; print "="; print v; print ";" end)
          conf.env;
        print "sel=";
        print (code_varenv d);
        print "\">";
        print x;
        print "</a>";
        if i = n_by_line then begin newline (); loop 1 list end
        else if list = [] then newline ()
        else
          begin
            print (String.make (max_len + 2 - String.length x) ' ');
            loop (i + 1) list
          end
    | [] -> print "\n"
  in
    loop 1 list
  end;
  print "</pre>\n"
and print_if conf print cond strm =
  match Stream.next strm with
    '{' ->
      let s = parse_upto '}' strm in
      if cond then copy_from_stream conf print (Stream.of_string s)
  | _ -> ()
and print_if_else conf print cond strm =
  match Stream.next strm with
    '{' ->
      let s1 = parse_upto '|' strm in
      let s2 = parse_upto '}' strm in
      if cond then copy_from_stream conf print (Stream.of_string s1)
      else copy_from_stream conf print (Stream.of_string s2)
  | _ -> ()
and for_all conf print list strm =
  match Stream.next strm with
    '{' ->
      let s_exist = parse_upto '|' strm in
      let s_empty = parse_upto '}' strm in
      let eol =
        match strm with parser
          [< ''\\' >] -> false
        | [< >] -> true
      in
      if list <> [] then
        List.iter
          (fun db ->
             let conf = conf_with_env conf "anon" db in
             copy_from_stream conf print (Stream.of_string s_exist);
             if eol then print "\n")
          list
      else
        begin
          copy_from_stream conf print (Stream.of_string s_empty);
          if eol then print "\n"
        end
  | _ -> ()

let print_file conf bname =
  let dir = Filename.concat !setup_dir "setup" in
  let fname = Filename.concat (Filename.concat dir "lang") bname in
  let ic_opt = try Some (open_in fname) with Sys_error _ -> None in
  match ic_opt with
    Some ic ->
      Wserver.http HttpStatus.OK;
      Wserver.header "Content-type: text/html; charset=%s" (charset conf);
      copy_from_stream conf (fun x -> Wserver.printf "%s" x)
        (Stream.of_channel ic);
      close_in ic;
      trailer conf
  | None ->
      let title _ = Wserver.printf "Error" in
      header conf title;
      Wserver.printf "<ul><li>\n";
      Wserver.printf "Cannot access file \"%s\".\n" fname;
      Wserver.printf "</ul>\n";
      trailer conf;
      raise Exit

let error conf str =
  header conf (fun _ -> Wserver.printf "Incorrect request");
  Wserver.printf "<em>%s</em>\n" (String.capitalize_ascii str);
  trailer conf

let exec_f comm =
  let s = comm ^ " > " ^ "comm.log" in
  Printf.eprintf "$ cd \"%s\"\n" (Sys.getcwd ());
  flush stderr;
  Printf.eprintf "$ %s\n" s;
  flush stderr;
  Sys.command s

let good_name s =
  let rec loop i =
    if i = String.length s then true
    else
      match s.[i] with
        'a'..'z' | 'A'..'Z' | '0'..'9' | '-' -> loop (i + 1)
      | _ -> false
  in
  loop 0

let out_name_of_ged in_file =
  let f = Filename.basename in_file in
  if Filename.check_suffix f ".ged" then Filename.chop_suffix f ".ged"
  else if Filename.check_suffix f ".GED" then Filename.chop_suffix f ".GED"
  else f

let out_name_of_gw in_file =
  let f = Filename.basename in_file in
  if Filename.check_suffix f ".gw" then Filename.chop_suffix f ".gw"
  else if Filename.check_suffix f ".GW" then Filename.chop_suffix f ".GW"
  else f

let basename s =
  let rec loop i =
    if i < 0 then s
    else
      match s.[i] with
        'a'..'z' | 'A'..'Z' | '0'..'9' | '_' | '.' -> loop (i - 1)
      | _ -> String.sub s (i + 1) (String.length s - i - 1)
  in
  loop (String.length s - 1)

let setup_gen conf =
  match p_getenv conf.env "v" with
    Some fname -> print_file conf (basename fname)
  | _ -> error conf "request needs \"v\" parameter"

let print_default_gwf_file conf =
  let gwf =
    ["access_by_key=yes"; "disable_forum=yes"; "hide_private_names=no";
     "use_restrict=no"; "show_consang=yes"; "display_sosa=yes";
     "place_surname_link_to_ind=yes"; "max_anc_level=8"; "max_anc_tree=7";
     "max_desc_level=12"; "max_desc_tree=4"; "max_cousins=2000";
     "max_cousins_level=5"; "latest_event=20"; "template=*"; "long_date=no";
     "counter=no"; "full_siblings=yes"; "hide_advanced_request=no";
     "perso_module_i=individu"; "perso_module_p=parents";
     "perso_module_g=gr_parents"; "perso_module_u=unions";
     "perso_module_f=fratrie"; "perso_module_r=relations";
     "perso_module_c=chronologie"; "perso_module_n=notes";
     "perso_module_s=sources"; "perso_module_a=arbres";
     "perso_module_d=data_3col"; "perso_module_l=ligne"; "p_mod="]
  in
  let bname = try List.assoc "o" conf.env with Not_found -> "" in
  let dir = Sys.getcwd () in
  let fname = Filename.concat dir (bname ^ ".gwf") in
  if Sys.file_exists fname then ()
  else
    let oc = open_out fname in
    List.iter (fun s -> Printf.fprintf oc "%s\n" s) gwf; close_out oc

let simple conf =
  let ged =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let ged =
    if Filename.check_suffix (String.lowercase_ascii ged) ".ged" then ged
    else ""
  in
  let out_file =
    match p_getenv conf.env "o" with
      Some f -> strip_spaces f
    | _ -> ""
  in
  let out_file =
    if ged = "" then out_file
    else if out_file = "" then out_name_of_ged ged
    else out_file
  in
  let env = ("f", "on") :: conf.env in
  let env = list_replace "anon" ged env in
  let conf =
    {comm = if ged = "" then "gwc" else "ged2gwb";
     env = list_replace "o" out_file env; lang = conf.lang;
     request = conf.request; lexicon = conf.lexicon}
  in
  if ged <> "" && not (Sys.file_exists ged) then
    print_file conf "err_unkn.htm"
  else if out_file = "" then print_file conf "err_miss.htm"
  else if not (good_name out_file) then print_file conf "err_name.htm"
  else print_file conf "bso.htm"

let simple2 conf =
  let ged =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let ged =
    if Filename.check_suffix (String.lowercase_ascii ged) ".ged" then ged
    else ""
  in
  let out_file =
    match p_getenv conf.env "o" with
      Some f -> strip_spaces f
    | _ -> ""
  in
  let out_file =
    if ged = "" then out_file
    else if out_file = "" then out_name_of_ged ged
    else out_file
  in
  let env = ("f", "on") :: conf.env in
  let env = list_replace "anon" ged env in
  let conf =
    {comm = if ged = "" then "gwc2" else "ged2gwb2";
     env = list_replace "o" out_file env; lang = conf.lang;
     request = conf.request; lexicon = conf.lexicon}
  in
  if ged <> "" && not (Sys.file_exists ged) then
    print_file conf "err_unkn.htm"
  else if out_file = "" then print_file conf "err_miss.htm"
  else if not (good_name out_file) then print_file conf "err_name.htm"
  else print_file conf "bso.htm"

let gwc_or_ged2gwb out_name_of_in_name conf =
  let fname =
    match p_getenv conf.env "fname" with
    | Some f -> strip_spaces f
    | None -> ""
  in
  let in_file =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let in_file =
    if fname = "" then in_file
    else in_file ^ ( if Sys.unix then "/" else "\\" ) ^ fname
  in
  let conf = conf_with_env conf "anon" in_file in
  let out_file =
    match p_getenv conf.env "o" with
      Some f -> strip_spaces f
    | _ -> ""
  in
  let out_file =
    if out_file = "" then out_name_of_in_name in_file else out_file
  in
  (* clean up env *)
  let conf = conf_with_env conf "body_prop" "" in
  let conf = conf_with_env conf "fname" "" in
  let conf = conf_with_env conf "o" out_file in
  if in_file = "" || out_file = "" then print_file conf "err_miss.htm"
  else if not (Sys.file_exists in_file) && not (String.contains fname '*')
  then print_file conf "err_unkn.htm"
  else if not (good_name out_file) then print_file conf "err_name.htm"
  else print_file conf "bso.htm"

let gwc2_or_ged2gwb2 out_name_of_in_name conf =
  let fname =
    match p_getenv conf.env "fname" with
    | Some f -> strip_spaces f
    | None -> ""
  in
  let in_file =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let in_file =
    if fname = "" then in_file
    else in_file ^ (if Sys.unix then "/" else "\\") ^ fname
  in
  let conf = conf_with_env conf "anon" in_file in
  let out_file =
    match p_getenv conf.env "o" with
      Some f -> strip_spaces f
    | _ -> ""
  in
  let out_file =
    if out_file = "" then out_name_of_in_name in_file else out_file
  in
  (* clean up env *)
  let conf = conf_with_env conf "body_prop" "" in
  let conf = conf_with_env conf "fname" "" in
  let conf = conf_with_env conf "o" out_file in
  if in_file = "" || out_file = "" then print_file conf "err_miss.htm"
  else if not (Sys.file_exists in_file) && not (String.contains fname '*')
  then print_file conf "err_unkn.htm"
  else if not (good_name out_file) then print_file conf "err_name.htm"
  else print_file conf "bso.htm"

let gwc_check conf =
  let conf = {conf with env = ("nofail", "on") :: ("f", "on") :: conf.env} in
  gwc_or_ged2gwb out_name_of_gw conf

let gwc2_check conf =
  let conf = {conf with env = ("nofail", "on") :: ("f", "on") :: conf.env} in
  gwc2_or_ged2gwb2 out_name_of_gw conf

let ged2gwb_check conf =
  let conf = {conf with env = ("f", "on") :: conf.env} in
  gwc_or_ged2gwb out_name_of_ged conf

let ged2gwb2_check conf =
  let conf = {conf with env = ("f", "on") :: conf.env} in
  gwc2_or_ged2gwb2 out_name_of_ged conf

(*ifdef WINDOWS then*)
let infer_rc conf rc =
  if rc > 0 then rc
  else
    match p_getenv conf.env "o" with
      Some out_file -> if Sys.file_exists (out_file ^ ".gwb") then 0 else 2
    | _ -> 0

let gwc conf =
  let rc =
    let comm = stringify (Filename.concat !bin_dir "gwc") in
    exec_f (comm ^ parameters conf.env)
  in
  let rc = if Sys.unix then rc else infer_rc conf rc in
  let gwo = strip_spaces (s_getenv conf.env "anon") ^ "o" in
  (try Sys.remove gwo with Sys_error _ -> ());
  Printf.eprintf "\n";
  flush stderr;
  if rc > 1 then print_file conf "bso_err.htm"
  else begin print_default_gwf_file conf; print_file conf "bso_ok.htm" end

let gwc2 conf =
  let rc =
    let comm = stringify (Filename.concat !bin_dir "gwc2") in
    exec_f (comm ^ parameters conf.env)
  in
  let rc = if Sys.unix then rc else infer_rc conf rc in
  let gwo = strip_spaces (s_getenv conf.env "anon") ^ "o" in
  (try Sys.remove gwo with Sys_error _ -> ());
  Printf.eprintf "\n";
  flush stderr;
  if rc > 1 then print_file conf "bso_err.htm"
  else begin print_default_gwf_file conf; print_file conf "bso_ok.htm" end

let gwdiff_check conf =
  print_file conf "bsi_diff.htm"

let gwdiff ok_file conf =
  let rc =
    let comm = stringify (Filename.concat !bin_dir conf.comm) in
    exec_f (comm ^ parameters_2 conf.env)
  in
  Printf.eprintf "\n";
  flush stderr;
  if rc > 1 then print_file conf "bsi_err.htm"
  else
    let conf =
      conf_with_env conf "o" (Filename.basename (s_getenv conf.env "o"))
    in
    print_file conf ok_file

let connex_check conf =
  print_file conf "bsi_connex.htm"

let connex ok_file conf =
  let ic = Unix.open_process_in "uname" in
  let uname = input_line ic in
  let () = close_in ic in
  let rc =
    let commnd =
      "cd " ^ (Sys.getcwd ()) ^ "; tput bel;" ^
      (stringify (Filename.concat !bin_dir "connex")) ^ " " ^
      parameters_1 conf.env
    in
    if uname = "Darwin" then
      let launch = "tell application \"Terminal\" to do script " in
      Sys.command ("osascript -e '" ^ launch ^ " \" " ^ commnd ^ " \"' " )
    else if uname = "Linux" then
      (* non testé ! *)
      Sys.command ("xterm -e \" " ^ commnd ^ " \" ")
    else if Sys.win32 then
      (* à compléter et tester ! *)
      let commnd = (stringify (Filename.concat !bin_dir "connex")) ^ " " ^
                   parameters_1 conf.env in
      Sys.command (commnd)
    else begin
      Printf.eprintf "%s (%s) %s (%s)\n"
        "Unknown Os_type" Sys.os_type "or wrong uname response" uname;
      2
    end
  in
  flush stderr;
  if rc > 1 then print_file conf "bsi_err.htm" else print_file conf ok_file

let gwu_or_gwb2ged_check suffix conf =
  let in_file =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let od =
    match p_getenv conf.env "od" with
    | Some f -> Filename.basename (strip_spaces f)
    | None -> ""
  in
  let out_file =
    match p_getenv conf.env "o" with
      Some f -> Filename.basename (strip_spaces f)
    | None -> ""
  in
  let odir =
    if od = "odir" then
      match p_getenv conf.env "odir" with
      | Some f -> Filename.basename (strip_spaces f)
      | None -> ""
    else ""
  in
  let out_file =
    if out_file = "" || out_file = Filename.current_dir_name then
      in_file ^ suffix
    else if Filename.check_suffix out_file suffix then out_file
    else if
      Filename.check_suffix out_file (String.uppercase_ascii suffix)
    then
      out_file
    else out_file ^ suffix
  in
  let conf = conf_with_env conf "od" "" in
  let conf = conf_with_env conf "odir" odir in
  let conf = conf_with_env conf "o" out_file in
  if in_file = "" then print_file conf "err_miss.htm"
  else print_file conf "bsi.htm"

let gwu = gwu_or_gwb2ged_check ".gw"
let gwb2ged = gwu_or_gwb2ged_check ".ged"

let gwb2ged_or_gwu_1 ok_file conf =
  let rc =
    let comm = stringify (Filename.concat !bin_dir conf.comm) in
    exec_f (comm ^ parameters conf.env)
  in
  Printf.eprintf "\n";
  flush stderr;
  if rc > 1 then print_file conf "bsi_err.htm"
  else
    let conf =
      conf_with_env conf "o" (Filename.basename (s_getenv conf.env "o"))
    in
    print_file conf ok_file

let gwb2ged_1 = gwb2ged_or_gwu_1 "gw2gd_ok.htm"
let gwu_1 = gwb2ged_or_gwu_1 "gwu_ok.htm"

let consang_check conf =
  let in_f =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  if in_f = "" then print_file conf "err_miss.htm"
  else print_file conf "bsi.htm"

let update_nldb_check conf =
  let in_f =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  if in_f = "" then print_file conf "err_miss.htm"
  else print_file conf "bsi.htm"

let has_gwu dir =
  match
    try Some (Unix.opendir dir) with Unix.Unix_error (_, _, _) -> None
  with
    Some dh ->
      let gwu_found =
        try
          let rec loop () =
            let e = Unix.readdir dh in
            if Sys.unix then
              match e with
                "gwu" -> raise Exit
              | _ -> loop ()
            else
              match String.lowercase_ascii e with
                "gwu.exe" -> raise Exit
              | _ -> loop ()
          in
          loop ()
        with
          End_of_file -> false
        | Exit -> true
      in
      Unix.closedir dh; gwu_found
  | None -> false

let recover conf =
  let init_dir =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let (init_dir, dir_has_gwu) =
    if has_gwu init_dir then init_dir, true
    else
      let dir = init_dir in
      if has_gwu dir then dir, true
      else
        let dir = Filename.dirname init_dir in
        if has_gwu dir then dir, true
        else
          let dir = Filename.concat dir "gw" in
          if has_gwu dir then dir, true else init_dir, false
  in
  let conf = conf_with_env conf "anon" init_dir in
  let dest_dir = Sys.getcwd () in
  if init_dir = "" then print_file conf "err_miss.htm"
  else if init_dir = dest_dir then print_file conf "err_smdr.htm"
  else if not (Sys.file_exists init_dir) then print_file conf "err_ndir.htm"
  else if
    if Sys.unix then
      try
        (Unix.stat (Filename.concat init_dir ".")).Unix.st_ino =
          (Unix.stat (Filename.concat dest_dir ".")).Unix.st_ino
      with Unix.Unix_error (_, _, _) -> false
    else false
  then
    print_file conf "err_smdr.htm"
  else if not dir_has_gwu then print_file conf "err_ngw.htm"
  else print_file conf "recover1.htm"

let recover_1 conf =
  let in_file =
    match p_getenv conf.env "i" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let out_file =
    match p_getenv conf.env "o" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let by_gedcom =
    match p_getenv conf.env "ged" with
      Some "on" -> true
    | _ -> false
  in
  let out_file = if out_file = "" then in_file else out_file in
  let conf = conf_with_env conf "o" out_file in
  if in_file = "" then print_file conf "err_miss.htm"
  else if not (good_name out_file) then print_file conf "err_name.htm"
  else
    let (old_to_src, o_opt, tmp, src_to_new) =
      if not by_gedcom then "gwu", " > ", "tmp.gw", "gwc"
      else "gwb2ged", " -o ", "tmp.ged", "ged2gwb"
    in
    let conf =
      {conf with env =
        ("U", old_to_src) :: ("O", o_opt) :: ("T", tmp) ::
        ("src2new", src_to_new) :: conf.env}
    in
    print_file conf "recover2.htm"

let recover_2 conf =
  let init_dir =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let in_file =
    match p_getenv conf.env "i" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let out_file =
    match p_getenv conf.env "o" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let by_gedcom =
    match p_getenv conf.env "ged" with
      Some "on" -> true
    | _ -> false
  in
  let (old_to_src, o_opt, tmp, src_to_new) =
    if not by_gedcom then "gwu", " > ", "tmp.gw", "gwc"
    else "gwb2ged", " -o ", "tmp.ged", "ged2gwb"
  in
  let out_file = if out_file = "" then in_file else out_file in
  let conf = conf_with_env conf "o" out_file in
  let dir = Sys.getcwd () in
  let rc =
    try
      Printf.eprintf "$ cd \"%s\"\n" init_dir;
      flush stderr;
      Sys.chdir init_dir;
      let c =
        Filename.concat "." old_to_src ^ " " ^ in_file ^ o_opt ^
        stringify (Filename.concat dir tmp)
      in
      Printf.eprintf "$ %s\n" c; flush stderr; Sys.command c
    with e -> Sys.chdir dir; raise e
  in
  let rc =
    if rc = 0 then
      begin
        Printf.eprintf "$ cd \"%s\"\n" dir;
        flush stderr;
        Sys.chdir dir;
        let c =
          Filename.concat !bin_dir src_to_new ^ " " ^ tmp ^ " -f -o " ^
          out_file ^ " > " ^ "comm.log"
        in
        Printf.eprintf "$ %s\n" c;
        flush stderr;
        let rc = Sys.command c in
        let rc = if Sys.unix then rc else infer_rc conf rc in
        Printf.eprintf "\n"; flush stderr; rc
      end
    else rc
  in
  if rc > 1 then begin Sys.chdir dir; print_file conf "err_reco.htm" end
  else print_file conf "bso_ok.htm"

let cleanup conf =
  let in_base =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let conf = {conf with comm = "."} in
  if in_base = "" then print_file conf "err_miss.htm"
  else print_file conf "cleanup1.htm"

let cleanup_1 conf =
  let in_base =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let in_base_dir = in_base ^ ".gwb" in
  Printf.eprintf "$ cd \"%s\"\n" (Sys.getcwd ());
  flush stderr;
  let c = Filename.concat !bin_dir "gwu" ^ " " ^ in_base ^ " -o tmp.gw" in
  Printf.eprintf "$ %s\n" c;
  flush stderr;
  let _ = Sys.command c in
  Printf.eprintf "$ mkdir old\n";
  (try Unix.mkdir "old" 0o755 with Unix.Unix_error (_, _, _) -> ());
  if Sys.unix then Printf.eprintf "$ rm -rf old/%s\n" in_base_dir
  else
    begin
      Printf.eprintf "$ del old\\%s\\*.*\n" in_base_dir;
      Printf.eprintf "$ rmdir old\\%s\n" in_base_dir
    end;
  flush stderr;
  Util.rm_rf (Filename.concat "old" in_base_dir);
  if Sys.unix then Printf.eprintf "$ mv %s old/.\n" in_base_dir
  else Printf.eprintf "$ move %s old\\.\n" in_base_dir;
  flush stderr;
  Sys.rename in_base_dir (Filename.concat "old" in_base_dir);
  let c =
    Filename.concat !bin_dir "gwc" ^ " tmp.gw -nofail -o " ^ in_base ^
    " > comm.log 2>&1"
  in
  Printf.eprintf "$ %s\n" c;
  flush stderr;
  let rc = Sys.command c in
  let rc = if Sys.unix then rc else infer_rc conf rc in
  Printf.eprintf "\n";
  flush stderr;
  if rc > 1 then
    let conf = {conf with comm = "gwc"} in print_file conf "bsi_err.htm"
  else print_file conf "clean_ok.htm"

let rec check_new_names conf l1 l2 =
  match l1, l2 with
    (k, v) :: l, x :: m ->
      if k <> x then begin print_file conf "err_outd.htm"; raise Exit end
      else if not (good_name v) then
        let conf = {conf with env = ("o", v) :: conf.env} in
        print_file conf "err_name.htm"; raise Exit
      else check_new_names conf l m
  | [], [] -> ()
  | _ -> print_file conf "err_outd.htm"; raise Exit

let rec check_rename_conflict conf =
  function
    x :: l ->
      if List.mem x l then
        let conf = {conf with env = ("o", x) :: conf.env} in
        print_file conf "err_cnfl.htm"; raise Exit
      else check_rename_conflict conf l
  | [] -> ()

let rename conf =
  let rename_list =
    List.map (fun (k, v) -> k, strip_spaces (decode_varenv v)) conf.env
  in
  try
    check_new_names conf rename_list (all_db ".");
    check_rename_conflict conf (snd (List.split rename_list));
    List.iter
      (fun (k, v) ->
         if k <> v then Sys.rename (k ^ ".gwb") ("_" ^ k ^ ".gwb"))
      rename_list;
    List.iter
      (fun (k, v) ->
         if k <> v then Sys.rename ("_" ^ k ^ ".gwb") (v ^ ".gwb"))
      rename_list;
    print_file conf "ren_ok.htm"
  with Exit -> ()

let delete conf = print_file conf "delete_1.htm"

let delete_1 conf =
  List.iter (fun (k, v) -> if v = "del" then Util.rm_rf (k ^ ".gwb")) conf.env;
  print_file conf "del_ok.htm"

let merge conf =
  let out_file =
    match p_getenv conf.env "o" with
      Some f -> strip_spaces f
    | _ -> ""
  in
  let conf = {conf with comm = "."} in
  let bases = selected conf.env in
  if out_file = "" || List.length bases < 2 then
    print_file conf "err_miss.htm"
  else if not (good_name out_file) then print_file conf "err_name.htm"
  else print_file conf "merge_1.htm"

let merge_1 conf =
  let out_file =
    match p_getenv conf.env "o" with
      Some f -> strip_spaces f
    | _ -> ""
  in
  let bases = selected conf.env in
  let dir = Sys.getcwd () in
  Printf.eprintf "$ cd \"%s\"\n" dir;
  flush stderr;
  Sys.chdir dir;
  let rc =
    let rec loop =
      function
        [] -> 0
      | b :: bases ->
          let c =
            Filename.concat !bin_dir "gwu" ^ " " ^ b ^ " -o " ^ b ^ ".gw"
          in
          Printf.eprintf "$ %s\n" c;
          flush stderr;
          let r = Sys.command c in if r = 0 then loop bases else r
    in
    loop bases
  in
  let rc =
    if rc <> 0 then rc
    else
      let c =
        Filename.concat !bin_dir "gwc" ^
        List.fold_left
          (fun s b ->
             if s = "" then " " ^ b ^ ".gw" else s ^ " -sep " ^ b ^ ".gw")
          "" bases ^
        " -f -o " ^ out_file ^ " > comm.log 2>&1"
      in
      Printf.eprintf "$ %s\n" c; flush stderr; Sys.command c
  in
  if rc > 1 then print_file conf "bso_err.htm"
  else print_file conf "bso_ok.htm"

let read_gwd_arg () =
  let fname = Filename.concat !setup_dir "gwd.arg" in
  match try Some (open_in fname) with Sys_error _ -> None with
    Some ic ->
      let list =
        let rec loop list =
          match try Some (input_line ic) with End_of_file -> None with
            Some "" -> loop list
          | Some s -> loop (s :: list)
          | None -> list
        in
        loop []
      in
      close_in ic;
      let rec loop env =
        function
          x :: l ->
            if x.[0] = '-' then
              let x = String.sub x 1 (String.length x - 1) in
              match l with
                y :: l when y.[0] <> '-' -> loop ((x, y) :: env) l
              | _ -> loop ((x, "") :: env) l
            else loop env l
        | [] -> List.rev env
      in
      loop [] (List.rev list)
  | None -> []

let gwf conf =
  let in_base =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  if in_base = "" then print_file conf "err_miss.htm"
  else
    let benv = read_base_env in_base in
    let trailer =
      Util.quote_escaped
        (file_contents (Filename.concat "lang" (in_base ^ ".trl")))
    in
    let conf = { conf with env = benv @ ("trailer", trailer) :: conf.env } in
    print_file conf "gwf_1.htm"

let gwf_1 conf =
  let in_base =
    match p_getenv conf.env "anon" with
      Some f -> strip_spaces f
    | None -> ""
  in
  let benv = read_base_env in_base in
  let (vars, _) = variables "gwf_1.htm" in
  let oc = open_out (in_base ^ ".gwf") in
  let body_prop =
    match p_getenv conf.env "proposed_body_prop" with
      Some "" | None -> s_getenv conf.env "body_prop"
    | Some x -> x
  in
  Printf.fprintf oc "# File generated by \"setup\"\n\n";
  List.iter
    (fun k ->
       match k with
         "body_prop" ->
           if body_prop = "" then ()
           else Printf.fprintf oc "body_prop=%s\n" body_prop
       | _ -> Printf.fprintf oc "%s=%s\n" k (s_getenv conf.env k))
    vars;
  List.iter
    (fun (k, v) -> if List.mem k vars then () else Printf.fprintf oc "%s=%s\n" k v)
    benv;
  close_out oc;
  let trl = strip_spaces (strip_control_m (s_getenv conf.env "trailer")) in
  let trl_file = Filename.concat "lang" (in_base ^ ".trl") in
  (try Unix.mkdir "lang" 0o755 with Unix.Unix_error (_, _, _) -> ());
  begin try
    if trl = "" then Sys.remove trl_file
    else
      let oc = open_out trl_file in
      output_string oc trl; output_string oc "\n"; close_out oc
  with Sys_error _ -> ()
  end;
  print_file conf "gwf_ok.htm"

let gwd conf =
  let aenv = read_gwd_arg () in
  let get v = try List.assoc v aenv with Not_found -> "" in
  let conf =
    {conf with env =
      ("default_lang", get "lang") :: ("only", get "only") ::
      ("log", Filename.basename (get "log")) :: conf.env}
  in
  print_file conf "gwd.htm"

let gwd_1 conf =
  let oc = open_out (Filename.concat !setup_dir "gwd.arg") in
  let print_param k =
    match p_getenv conf.env k with
      Some v when v <> "" -> Printf.fprintf oc "-%s\n%s\n" k v
    | _ -> ()
  in
  if  p_getenv conf.env "setup_link" <> None
  then Printf.fprintf oc "-setup_link\n" ;
  print_param "only";
  begin match p_getenv conf.env "default_lang" with
    Some v when v <> "" -> Printf.fprintf oc "-lang\n%s\n" v
  | _ -> ()
  end;
  print_param "log";
  close_out oc;
  print_file conf "gwd_ok.htm"

let ged2gwb conf =
  let rc =
    let comm = stringify (Filename.concat !bin_dir conf.comm) in
    exec_f (comm ^ " -fne '\"\"'" ^ parameters conf.env)
  in
  let rc = if Sys.unix then rc else infer_rc conf rc in
  Printf.eprintf "\n";
  flush stderr;
  if rc > 1 then print_file conf "bso_err.htm"
  else begin print_default_gwf_file conf; print_file conf "bso_ok.htm" end

let ged2gwb2 conf =
  let rc =
    let comm = stringify (Filename.concat !bin_dir conf.comm) in
    exec_f (comm ^ " -fne '\"\"'" ^ parameters conf.env)
  in
  let rc = if Sys.unix then rc else infer_rc conf rc in
  Printf.eprintf "\n";
  flush stderr;
  if rc > 1 then print_file conf "bso_err.htm"
  else begin print_default_gwf_file conf; print_file conf "bso_ok.htm" end

let consang conf ok_file =
  let rc =
    let comm = stringify (Filename.concat !bin_dir conf.comm) in
    exec_f (comm ^ parameters conf.env)
  in
  Printf.eprintf "\n";
  flush stderr;
  if rc > 1 then print_file conf "bsi_err.htm" else print_file conf ok_file

let update_nldb conf ok_file =
  let rc =
    let comm = stringify (Filename.concat !bin_dir conf.comm) in
    exec_f (comm ^ parameters conf.env)
  in
  Printf.eprintf "\n";
  flush stderr;
  if rc > 1 then print_file conf "bsi_err.htm" else print_file conf ok_file

let separate_slashed_filename s =
  let rec loop i =
    match try Some (String.index_from s i '/') with Not_found -> None with
      Some j ->
        if j > i then String.sub s i (j - i) :: loop (j + 1) else loop (j + 1)
    | None ->
        if i >= String.length s then []
        else [String.sub s i (String.length s - i)]
  in
  loop 0

let end_with s x =
  let slen = String.length s in
  let xlen = String.length x in
  slen >= xlen && String.sub s (slen - xlen) xlen = x

let print_typed_file conf typ fname =
  let ic_opt = try Some (open_in_bin fname) with Sys_error _ -> None in
  match ic_opt with
    Some ic ->
      Wserver.http HttpStatus.OK;
      Wserver.header "Content-type: %s" typ;
      Wserver.header "Content-length: %d" (in_channel_length ic);
      begin try
        while true do let c = input_char ic in Wserver.printf "%c" c done
      with End_of_file -> ()
      end;
      close_in ic
  | None ->
      let title _ = Wserver.printf "Error" in
      header conf title;
      Wserver.printf "<ul><li>\n";
      Wserver.printf "Cannot access file \"%s\".\n" fname;
      Wserver.printf "</ul>\n";
      trailer conf;
      raise Exit

let raw_file conf s =
  let fname =
    List.fold_left Filename.concat !setup_dir (separate_slashed_filename s)
  in
  let typ =
    if end_with s ".png" then "image/png"
    else if end_with s ".jpg" then "image/jpeg"
    else if end_with s ".gif" then "image/gif"
    else if end_with s ".css" then "text/css"
    else "text/html"
  in
  print_typed_file conf typ fname

let has_gwb_directories dh =
  try
    let rec loop () =
      let e = Unix.readdir dh in
      if Filename.check_suffix e ".gwb" then true else loop ()
    in
    loop ()
  with End_of_file -> Unix.closedir dh; false

let setup_comm_ok conf =
  function
    "gwsetup" -> setup_gen conf
  | "simple" -> simple conf
  | "simple2" -> simple2 conf
  | "recover" -> recover conf
  | "recover_1" -> recover_1 conf
  | "recover_2" -> recover_2 conf
  | "cleanup" -> cleanup conf
  | "cleanup_1" -> cleanup_1 conf
  | "rename" -> rename conf
  | "delete" -> delete conf
  | "delete_1" -> delete_1 conf
  | "merge" -> merge conf
  | "merge_1" -> merge_1 conf
  | "gwc" ->
      begin match p_getenv conf.env "opt" with
        Some "check" -> gwc_check conf
      | _ -> gwc conf
      end
  | "gwc2" ->
      begin match p_getenv conf.env "opt" with
        Some "check" -> gwc2_check conf
      | _ -> gwc2 conf
      end
  | "gwu" ->
      begin match p_getenv conf.env "opt" with
        Some "check" -> gwu conf
      | _ -> gwu_1 conf
      end
  | "ged2gwb" ->
      begin match p_getenv conf.env "opt" with
        Some "check" -> ged2gwb_check conf
      | _ -> ged2gwb conf
      end
  | "ged2gwb2" ->
      begin match p_getenv conf.env "opt" with
        Some "check" -> ged2gwb2_check conf
      | _ -> ged2gwb2 conf
      end
  | "gwb2ged" ->
      begin match p_getenv conf.env "opt" with
        Some "check" -> gwb2ged conf
      | _ -> gwb2ged_1 conf
      end
  | "consang" ->
      begin match p_getenv conf.env "opt" with
        Some "check" -> consang_check conf
      | _ -> consang conf "consg_ok.htm"
      end
  | "update_nldb" ->
      begin match p_getenv conf.env "opt" with
        Some "check" -> update_nldb_check conf
      | _ -> update_nldb conf "update_nldb_ok.htm"
      end
  | "gwf" -> gwf conf
  | "gwf_1" -> gwf_1 conf
  | "gwd" -> gwd conf
  | "gwd_1" -> gwd_1 conf
  | "connex" ->
       begin match p_getenv conf.env "opt" with
      | Some "check" -> connex_check conf
      | _ -> connex "connex_ok.htm" conf
      end
  | "gwdiff" ->
       begin match p_getenv conf.env "opt" with
      | Some "check" -> gwdiff_check conf
      | _ -> gwdiff "gwdiff_ok.htm" conf
      end

  | x ->
      if Mutil.start_with "doc/" 0 x
      || Mutil.start_with "images/" 0 x
      || Mutil.start_with "css/" 0 x
      then
        raw_file conf x
      else error conf ("bad command: \"" ^ x ^ "\"")

let setup_comm conf comm =
  match p_getenv conf.env "cancel" with
    Some _ -> setup_gen {conf with env = ["lang", conf.lang; "v", "main.htm"]}
  | None -> setup_comm_ok conf comm

let string_of_sockaddr =
  function
    Unix.ADDR_UNIX s -> s
  | Unix.ADDR_INET (a, _) -> Unix.string_of_inet_addr a

let local_addr = "127.0.0.1"

let only_addr () =
  let fname = only_file_name () in
  match try Some (open_in fname) with Sys_error _ -> None with
    Some ic ->
      let v = try input_line ic with End_of_file -> local_addr in
      close_in ic; v
  | None -> local_addr

let lindex s c =
  let rec pos i =
    if i = String.length s then None
    else if s.[i] = c then Some i
    else pos (i + 1)
  in
  pos 0

let input_lexicon lang =
  let t = Hashtbl.create 501 in
  try
    let ic =
      open_in
        (List.fold_right Filename.concat [!setup_dir; "setup"; "lang"]
           "lexicon.txt")
    in
    let derived_lang =
      match lindex lang '-' with
        Some i -> String.sub lang 0 i
      | _ -> ""
    in
    try
      begin try
        while true do
          let k =
            let rec find_key line =
              if String.length line < 4 then find_key (input_line ic)
              else if String.sub line 0 4 <> "    " then
                find_key (input_line ic)
              else line
            in
            find_key (input_line ic)
          in
          let k = String.sub k 4 (String.length k - 4) in
          let rec loop line =
            match lindex line ':' with
              Some i ->
                let line_lang = String.sub line 0 i in
                if line_lang = lang ||
                   line_lang = derived_lang && not (Hashtbl.mem t k)
                then
                  begin let v =
                    if i + 1 = String.length line then ""
                    else String.sub line (i + 2) (String.length line - i - 2)
                  in
                    Hashtbl.add t k v
                  end;
                loop (input_line ic)
            | None -> ()
          in
          loop (input_line ic)
        done
      with End_of_file -> ()
      end;
      close_in ic;
      t
    with e -> close_in ic; raise e
  with Sys_error _ -> t

let setup (addr, req) comm env_str =
  let conf =
    let env = create_env env_str in
    if env = [] && (comm = "" || String.length comm = 2) then
      let lang =
        if comm = "" then !default_lang else String.lowercase_ascii comm
      in
      let lexicon = input_lexicon lang in
      {lang = lang; comm = ""; env = env; request = req; lexicon = lexicon}
    else
      let (lang, env) =
        match p_getenv env "lang" with
          Some x -> x, list_remove_assoc "lang" env
        | _ -> !default_lang, env
      in
      let lexicon = input_lexicon lang in
      {lang = lang; comm = comm; env = env; request = req; lexicon = lexicon}
  in
  let saddr = string_of_sockaddr addr in
  let s = only_addr () in
  if s <> saddr then
    let conf = {conf with env = ["anon", saddr; "o", s]} in
    Printf.eprintf "Invalid request from \"%s\"; only \"%s\" accepted.\n" saddr s;
    flush stderr;
    print_file conf "err_acc.htm"
  else if conf.comm = "" then print_file conf "welcome.htm"
  else setup_comm conf comm

let wrap_setup a b c =
  if Sys.unix then ()
  else
    begin
      (* another process have been launched, therefore we lost variables;
         and we cannot parse the arg list again, because of possible spaces
         in arguments which may appear as separators *)
      (try default_lang := Sys.getenv "GWLANG" with Not_found -> ());
      (try setup_dir := Sys.getenv "GWGD" with Not_found -> ());
      try bin_dir := Sys.getenv "GWGD" with Not_found -> ()
    end;
  try setup a b c with Exit -> ()

let copy_text lang fname =
  let dir = Filename.concat !setup_dir "setup" in
  let fname = Filename.concat dir fname in
  match try Some (open_in fname) with Sys_error _ -> None with
    Some ic ->
      let conf =
        {lang = lang; comm = ""; env = []; request = [];
         lexicon = Hashtbl.create 1}
      in
      copy_from_stream conf print_string (Stream.of_channel ic);
      flush stdout;
      close_in ic
  | _ ->
      Printf.printf "\nCannot access file \"%s\".\n" fname;
      Printf.printf "Type \"Enter\" to exit\n? ";
      flush stdout;
      let _ = input_line stdin in (); exit 2

let set_gwd_default_language_if_absent lang =
  let env = read_gwd_arg () in
  let fname = Filename.concat !setup_dir "gwd.arg" in
  match try Some (open_out fname) with Sys_error _ -> None with
    Some oc ->
      let lang_found = ref false in
      List.iter
        (fun (k, v) ->
           Printf.fprintf oc "-%s\n" k;
           if k = "lang" then lang_found := true;
           if v <> "" then Printf.fprintf oc "%s\n" v)
        env;
      if not !lang_found then Printf.fprintf oc "-lang\n%s\n" lang;
      close_out oc
  | None -> ()

let daemon = ref false

let usage =
  "Usage: " ^ Filename.basename Sys.argv.(0) ^ " [options] where options are:"
let speclist =
  [("-bd", Arg.String (fun x -> base_dir := x),
    "<dir>: Directory where the databases are installed.");
   ("-gwd_p", Arg.Int (fun x -> gwd_port := x),
    "<number>: Specify the port number of gwd (default = " ^
      string_of_int !gwd_port ^ "); > 1024 for normal users.");
   ("-lang", Arg.String (fun x -> lang_param := x), "<string>: default lang");
   ("-daemon", Arg.Set daemon, ": Unix daemon mode.");
   ("-p", Arg.Int (fun x -> port := x),
    "<number>: Select a port number (default = " ^ string_of_int !port ^
    "); > 1024 for normal users.");
   ("-only", Arg.String (fun s -> only_file := s),
    "<file>: File containing the only authorized address");
   ("-gd", Arg.String (fun x -> setup_dir := x), "<string>: gwsetup directory");
   ("-bindir", Arg.String (fun x -> bin_dir := x),
    "<string>: binary directory (default = value of option -gd)")]
let anonfun s = raise (Arg.Bad ("don't know what to do with " ^ s))

let null_reopen flags fd =
  if Sys.unix then
    let fd2 = Unix.openfile "/dev/null" flags 0 in
    Unix.dup2 fd2 fd; Unix.close fd2

let setup_available_languages = ["de"; "en"; "es"; "fr"; "it"; "lv"; "sv"]

let intro () =
  let (default_gwd_lang, default_setup_lang) =
    if Sys.unix then
      let s = try Sys.getenv "LANG" with Not_found -> "" in
      if List.mem s Version.available_languages then
        s, (if List.mem s setup_available_languages then s else "en")
      else
        let s = try Sys.getenv "LC_CTYPE" with Not_found -> "" in
        if String.length s >= 2 then
          let s = String.sub s 0 2 in
          if List.mem s Version.available_languages then
            s, (if List.mem s setup_available_languages then s else "en")
          else !default_lang, !default_lang
        else !default_lang, !default_lang
    else !default_lang, !default_lang
  in
  Argl.parse speclist anonfun usage;
  if !bin_dir = "" then bin_dir := !setup_dir;
  default_lang := default_setup_lang;
  let (gwd_lang, setup_lang) =
    if !daemon then
      if Sys.unix then
        let setup_lang =
          if String.length !lang_param < 2 then default_setup_lang
          else !lang_param
        in
        Printf.printf "To start, open location http://localhost:%d/\n" !port;
        flush stdout;
        if Unix.fork () = 0 then
          begin
            Unix.close Unix.stdin;
            null_reopen [Unix.O_WRONLY] Unix.stdout
          end
        else exit 0;
        default_gwd_lang, setup_lang
      else default_gwd_lang, default_setup_lang
    else
      let (gwd_lang, setup_lang) =
        if String.length !lang_param < 2 then
          begin
            copy_text "" "intro.txt";
            let x = String.lowercase_ascii (input_line stdin) in
            if String.length x < 2 then default_gwd_lang, default_setup_lang
            else let x = String.sub x 0 2 in x, x
          end
        else !lang_param, !lang_param
      in
      copy_text setup_lang (Filename.concat "lang" "intro.txt");
      gwd_lang, setup_lang
  in
  set_gwd_default_language_if_absent gwd_lang;
  default_lang := setup_lang;
  if Sys.unix then ()
  else
    begin Unix.putenv "GWLANG" setup_lang; Unix.putenv "GWGD" !setup_dir end;
  Printf.printf "\n";
  flush stdout

let main () =
  if Sys.unix then intro ()
  else (try (let _ = Sys.getenv "WSERVER" in ()) with Not_found -> intro ());
  Wserver.f None !port 0 None wrap_setup

let _ = main ()