Merge pull request geneweb#1763 from lefessan/z-2024-04-05-gdb-enabled

Add option -no-fork to be able to debug with gdb under Unix

bin/gwd/gwd.ml

@@ -269,22 +269,42 @@ let strip_trailing_spaces s =
   String.sub s 0 len
 
 let read_base_env bname =
-  let fname = Util.bpath (bname ^ ".gwf") in
-  try
-    let ic = Secure.open_in fname in
-    let env =
-      let rec loop env =
-        match input_line ic with
-        | s ->
-          let s = strip_trailing_spaces s in
-          if s = "" || s.[0] = '#' then loop env
-          else loop (cut_at_equal 0 s :: env)
-        | exception End_of_file -> env
+  let load_file fname =
+    try
+      Printf.eprintf "read_base_env %S...\n%!" fname;
+      let ic = Secure.open_in fname in
+      let env =
+        let rec loop env =
+          match input_line ic with
+          | s ->
+            let s = strip_trailing_spaces s in
+            if s = "" || s.[0] = '#' then loop env
+            else loop (cut_at_equal 0 s :: env)
+          | exception End_of_file -> env
+        in
+        loop []
       in
-      loop []
-    in
-    close_in ic; env
-  with Sys_error _ -> []
+      close_in ic;
+      env
+    with Sys_error error ->
+        GwdLog.syslog `LOG_WARNING @@
+        Printf.sprintf "Error %s while loading %s, using empty config" error fname;
+      []
+  in
+  let fname1 = Util.bpath (bname ^ ".gwf") in
+    if Sys.file_exists fname1 then
+      load_file fname1
+    else
+      let fname2 = Filename.concat !gw_prefix "etc/a.gwf" in
+      if Sys.file_exists fname2 then begin
+        GwdLog.syslog `LOG_WARNING @@
+        Printf.sprintf "Using configuration from %s" fname2;
+        load_file fname2
+      end else begin
+        GwdLog.syslog `LOG_WARNING @@
+        Printf.sprintf "No config file found in either %s or %s" fname1 fname2;
+        []
+      end
 
 let print_renamed conf new_n =
   let link =
@@ -1065,7 +1085,7 @@ let string_to_char_list s =
 
 let make_conf from_addr request script_name env =
   if !allowed_tags_file <> "" && not (Sys.file_exists !allowed_tags_file) then (
-    let str = 
+    let str =
      Printf.sprintf
        "Requested allowed_tags file (%s) absent" !allowed_tags_file
     in
@@ -1175,7 +1195,7 @@ let make_conf from_addr request script_name env =
     with Not_found -> false
   in
   let wizard_just_friend = if manitou then false else wizard_just_friend in
-  let private_years = 
+  let private_years =
     try int_of_string (List.assoc "private_years" base_env) with
     Not_found | Failure _ -> 150
   in
@@ -1414,7 +1434,7 @@ let log_and_robot_check conf auth from request script_name contents =
         end;
         log tm conf from auth request script_name contents
       end
-  
+
 let conf_and_connection =
   let slow_query_threshold =
     match Sys.getenv_opt "GWD_SLOW_QUERY_THRESHOLD" with
@@ -2015,7 +2035,7 @@ let main () =
     ; ("-no_host_address", Arg.Set no_host_address, " Force no reverse host by address.")
     ; ("-digest", Arg.Set use_auth_digest_scheme, " Use Digest authorization scheme (more secure on passwords)")
     ; ("-add_lexicon", Arg.String (Mutil.list_ref_append lexicon_list), "<FILE> Add file as lexicon.")
-    ; ("-log", Arg.String (fun x -> GwdLog.oc := Some (match x with "-" | "<stdout>" -> stdout | "<stderr>" -> stderr | _ -> open_out x)), {|<FILE> Log trace to this file. Use "-" or "<stdout>" to redirect output to stdout or "<stderr>" to output log to stderr.|})
+    ; ("-log", Arg.String (fun x -> GwdLog.oc := Some (match x with "-" | "<stdout>" -> stdout | "2" | "<stderr>" -> stderr | _ -> open_out x)), {|<FILE> Log trace to this file. Use "-" or "<stdout>" to redirect output to stdout or "<stderr>" to output log to stderr.|})
     ; ("-log_level", Arg.Set_int GwdLog.verbosity, {|<N> Send messages with severity <= <N> to syslog (default: |} ^ string_of_int !GwdLog.verbosity ^ {|).|})
     ; ("-robot_xcl", Arg.String robot_exclude_arg, "<CNT>,<SEC> Exclude connections when more than <CNT> requests in <SEC> seconds.")
     ; ("-min_disp_req", Arg.Int (fun x -> Robot.min_disp_req := x), " Minimum number of requests in robot trace (default: " ^ string_of_int !(Robot.min_disp_req) ^ ").")
@@ -2031,6 +2051,7 @@ let main () =
     ; ("-max_clients", Arg.Int (fun x -> max_clients := Some x), "<NUM> Max number of clients treated at the same time (default: no limit) (not cgi).")
     ; ("-conn_tmout", Arg.Int (fun x -> conn_timeout := x), "<SEC> Connection timeout (default " ^ string_of_int !conn_timeout ^ "s; 0 means no limit)." )
     ; ("-daemon", Arg.Set daemon, " Unix daemon mode.")
+    ; ("-no-fork", Arg.Set Wserver.no_fork, " Prevent forking processes")
 #endif
     ]
   in

bin/gwd/gwdLog.ml

@@ -2,11 +2,16 @@ let verbosity = ref 7
 let debug = ref false
 
 let oc : out_channel option ref = ref None
+let warning_printed = ref false
 
 let log fn =
   match !oc with
   | Some oc -> fn oc
-  | None -> ()
+  | None ->
+    if not !warning_printed then begin
+      Printf.eprintf "Warning: logging not enabled. Use '-log 2' to log on stderr\n%!";
+      warning_printed := true
+      end
 
 type level =
   [ `LOG_ALERT
@@ -19,12 +24,9 @@ type level =
   | `LOG_WARNING
   ]
 
-#ifdef SYSLOG
 let syslog (level : level) msg =
-  let flags = if !debug then [`LOG_PERROR] else [] in
-  if !verbosity
-     >=
-     match level with
+  let verbosity_level =
+    match level with
      | `LOG_EMERG -> 0
      | `LOG_ALERT -> 1
      | `LOG_CRIT -> 2
@@ -33,27 +35,19 @@ let syslog (level : level) msg =
      | `LOG_NOTICE -> 5
      | `LOG_INFO -> 6
      | `LOG_DEBUG -> 7
+  in
+#ifdef SYSLOG
+  let flags = if !debug then [`LOG_PERROR] else [] in
+  if !verbosity >= verbosity_level
   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
+#else
+  let () = () in
+  if !verbosity >= verbosity_level
   then begin
     let tm = Unix.(time () |> localtime) in
     let level =
@@ -67,7 +61,8 @@ let syslog (level : level) msg =
       | `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
+    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

lib/wserver/wserver.ml

@@ -1,14 +1,21 @@
 (* Copyright (c) 1998-2007 INRIA *)
 
-let connection_closed = ref false
 let eprintf = Printf.eprintf
 let sock_in = ref "wserver.sin"
 let sock_out = ref "wserver.sou"
+
+(* global parameters set by command arguments *)
 let stop_server = ref "STOP_SERVER"
 let cgi = ref false
+let no_fork = ref false
+
+(* state of a connection request *)
+let connection_closed = ref false
 let wserver_sock = ref Unix.stdout
-let wsocket () = !wserver_sock
 let wserver_oc = ref stdout
+
+(* functions to access the connection state *)
+let wsocket () = !wserver_sock
 let woc () = !wserver_oc
 let wflush () = flush !wserver_oc
 
@@ -257,29 +264,36 @@ let accept_connection tmout max_clients callback s =
   check_stopping ();
   Unix.setsockopt t Unix.SO_KEEPALIVE true;
   if Sys.unix then (
-    match try Some (Unix.fork ()) with _ -> None with
-    | Some 0 -> (
-        try
-          if max_clients = None && Unix.fork () <> 0 then exit 0;
-          Unix.close s;
-          wserver_sock := t;
-          wserver_oc := Unix.out_channel_of_descr t;
-          treat_connection tmout callback addr t;
-          close_connection ();
-          exit 0
-        with
-        | Unix.Unix_error (Unix.ECONNRESET, "read", _) -> exit 0
-        | e -> raise e)
-    | Some id ->
-        Unix.close t;
-        if max_clients = None then
-          let _ = Unix.waitpid [] id in
-          ()
-        else pids := id :: !pids
-    | None ->
-        Unix.close t;
-        eprintf "Fork failed\n";
-        flush stderr)
+    if !no_fork then (
+      connection_closed := false;
+      wserver_sock := t;
+      wserver_oc := Unix.out_channel_of_descr t;
+      treat_connection tmout callback addr t;
+      close_connection ())
+    else
+      match try Some (Unix.fork ()) with _ -> None with
+      | Some 0 -> (
+          try
+            if max_clients = None && Unix.fork () <> 0 then exit 0;
+            Unix.close s;
+            wserver_sock := t;
+            wserver_oc := Unix.out_channel_of_descr t;
+            treat_connection tmout callback addr t;
+            close_connection ();
+            exit 0
+          with
+          | Unix.Unix_error (Unix.ECONNRESET, "read", _) -> exit 0
+          | e -> raise e)
+      | Some id ->
+          Unix.close t;
+          if max_clients = None then
+            let _ = Unix.waitpid [] id in
+            ()
+          else pids := id :: !pids
+      | None ->
+          Unix.close t;
+          eprintf "Fork failed\n";
+          flush stderr)
   else
     let oc = open_out_bin !sock_in in
     let cleanup () = try close_out oc with _ -> () in
@@ -367,6 +381,7 @@ let f syslog addr_opt port tmout max_clients g =
         (1900 + tm.Unix.tm_year) (succ tm.Unix.tm_mon) tm.Unix.tm_mday
         tm.Unix.tm_hour tm.Unix.tm_min port;
       flush stderr;
+      if !no_fork then ignore @@ Sys.signal Sys.sigpipe Sys.Signal_ignore;
       while true do
         try accept_connection tmout max_clients g s with
         | Unix.Unix_error (Unix.ECONNRESET, "accept", _) as e ->

lib/wserver/wserver.mli

@@ -90,6 +90,9 @@ val stop_server : string ref
 val cgi : bool ref
 (** CGI (Common Gateway Interface) mode (default false). *)
 
+val no_fork : bool ref
+(** Do not fork processes at every request (default: false) *)
+
 (* Example:
 
     - Source program "foo.ml":