Source file ocsigen_server.ml

(* Ocsigen
 * http://www.ocsigen.org
 * Copyright (C) 2005
 * Vincent Balat, Denis Berthod, Nataliya Guts, Jérôme Vouillon
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)

open Lwt.Infix

let () = Random.self_init ()

(* Without the following line, it stops with "Broken Pipe" without
   raising an exception ... *)
let _ = Sys.set_signal Sys.sigpipe Sys.Signal_ignore

(* Exit gracefully on SIGINT so that profiling will work *)
let _ = Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> exit 0))
let section = Lwt_log.Section.make "ocsigen:main"

(* Initialize exception handler for Lwt timeouts: *)
let _ =
  Lwt_timeout.set_exn_handler (fun e ->
      Lwt_log.ign_error ~section ~exn:e "Uncaught Exception after lwt timeout")

let _warn sockaddr s =
  Lwt_log.ign_warning_f ~section "While talking to %a:%s"
    (fun () sockaddr ->
      Unix.string_of_inet_addr (Ocsigen_lib.Ip_address.of_sockaddr sockaddr))
    sockaddr s

let _dbg sockaddr s =
  Lwt_log.ign_info_f ~section "While talking to %a:%s"
    (fun () sockaddr ->
      Unix.string_of_inet_addr (Ocsigen_lib.Ip_address.of_sockaddr sockaddr))
    sockaddr s

(* fatal errors messages *)
let errmsg = function
  | Dynlink_wrapper.Error e ->
      "Fatal - Dynamic linking error: " ^ Dynlink_wrapper.error_message e, 6
  | Unix.Unix_error _ as e -> "Fatal - " ^ Printexc.to_string e, 9
  | Ssl.Private_key_error msg -> "Fatal - bad password: " ^ msg, 10
  | Ocsigen_config.Config_file_error msg
  | Ocsigen_extensions.Error_in_config_file msg ->
      "Fatal - Error in configuration file: " ^ msg, 50
  | Xml.Error (s, loc) ->
      let begin_char, end_char = Xml.range loc and line = Xml.line loc in
      ( Printf.sprintf
          "Fatal - Error in configuration file, line %d, characters %d-%d: %s"
          line begin_char end_char (Xml.error_msg s)
      , 51 )
  | Ocsigen_loader.Dynlink_error (s, Dynlink.Error err) ->
      "Fatal - While loading " ^ s ^ ": " ^ Dynlink.error_message err, 52
  | Ocsigen_loader.Dynlink_error (s, exn) ->
      "Fatal - While loading " ^ s ^ ": " ^ Printexc.to_string exn, 52
  | Ocsigen_loader.Findlib_error _ as e -> "Fatal - " ^ Printexc.to_string e, 53
  | exn -> (
    try Ocsigen_extensions.get_init_exn_handler () exn, 20
    with exn -> "Fatal - Uncaught exception: " ^ Printexc.to_string exn, 100)

(* loading new configuration *)
let reload_conf s =
  try
    Ocsigen_extensions.start_initialisation ();
    Ocsigen_parseconfig.later_pass s;
    Ocsigen_extensions.end_initialisation ()
  with e ->
    Ocsigen_extensions.end_initialisation ();
    Lwt_log.ign_error ~section (fst (errmsg e))

(* reloading the config file *)
let reload ?file () =
  (* That function cannot be interrupted??? *)
  Lwt_log.ign_warning ~section "Reloading config file";
  (try
     match Ocsigen_parseconfig.parse_config ?file () with
     | [] -> ()
     | s :: _ -> reload_conf s
   with e -> Ocsigen_messages.errlog (fst (errmsg e)));
  (try
     match Ocsigen_parseconfig.parse_config ?file () with
     | [] -> ()
     | s :: _ -> reload_conf s
   with e -> Lwt_log.ign_error ~section (fst (errmsg e)));
  Lwt_log.ign_warning ~section "Config file reloaded"

let _ =
  let f _s = function
    | ["reopen_logs"] ->
        Ocsigen_messages.open_files () >>= fun () ->
        Lwt_log.ign_warning ~section "Log files reopened";
        Lwt.return ()
    | ["reload"] -> reload (); Lwt.return ()
    | ["reload"; file] -> reload ~file (); Lwt.return ()
    | ["shutdown"] ->
        Ocsigen_cohttp.shutdown None;
        Lwt.return ()
    | ["shutdown"; f] ->
        Ocsigen_cohttp.shutdown (Some (float_of_string f));
        Lwt.return ()
    | ["gc"] ->
        Gc.compact ();
        Lwt_log.ign_warning ~section "Heap compaction requested by user";
        Lwt.return ()
    | ["clearcache"] ->
        Ocsigen_cache.clear_all_caches ();
        Lwt.return ()
    | _ -> Lwt.fail Ocsigen_command.Unknown_command
  in
  Ocsigen_command.register_command_function f

type accessor = {accessor : 'a. ('a -> 'a) option * 'a Hmap.key -> 'a option}

module type Hmap_wrapped = sig
  type t

  val get : t -> Hmap.t
  val do_ : t -> (Hmap.t -> Hmap.t) -> unit
end

module type Config_nested = sig
  type t
  type 'a key

  val key : ?preprocess:('a -> 'a) -> unit -> 'a key
  val find : t -> 'a key -> 'a option
  val set : t -> 'a key -> 'a -> unit
  val unset : t -> 'a key -> unit

  type accessor = {accessor : 'a. 'a key -> 'a option}
end

module Make_config_nested (W : Hmap_wrapped) = struct
  type 'a key = ('a -> 'a) option * 'a Hmap.key
  type nonrec accessor = accessor = {accessor : 'a. 'a key -> 'a option}

  let key ?preprocess () = preprocess, Hmap.Key.create ()
  let find w (_, k) = Hmap.find k (W.get w)

  let set w (f, k) v =
    let v = match f with Some f -> f v | None -> v in
    W.do_ w (Hmap.add k v)

  let unset w (_, k) = W.do_ w (Hmap.rem k)
end

module Site = struct
  type extension_simple = accessor -> Ocsigen_extensions.extension

  type extension =
    [ `Simple of extension_simple
    | `Intrusive of
      Ocsigen_extensions.virtual_hosts
      -> Ocsigen_extensions.config_info
      -> Ocsigen_lib.Url.path
      -> extension_simple ]

  let registered_extensions = ref []

  let create_extension f =
    let v = `Simple f in
    registered_extensions := v :: !registered_extensions;
    v

  let create_extension_intrusive f =
    let v = `Intrusive f in
    registered_extensions := v :: !registered_extensions;
    v

  type t =
    { s_id :
        [ `Host of Ocsigen_extensions.virtual_hosts
        | `Attach of t * Ocsigen_lib.Url.path ]
    ; s_config_info : Ocsigen_extensions.config_info
    ; s_charset : Ocsigen_charset_mime.charset option
    ; mutable s_config_map : Hmap.t
    ; mutable s_children_l : [`Extension of extension_simple | `Child of t] list
    }

  let l = ref []
  let default_re_string = ".*"
  let default_re = Ocsigen_lib.Netstring_pcre.regexp default_re_string

  let rec path_and_hosts {s_id; _} =
    match s_id with
    | `Host hosts -> [], hosts
    | `Attach (s, path') ->
        let path, hosts = path_and_hosts s in
        path @ path', hosts

  let register ({s_config_info; s_children_l; _} as s) = function
    | `Simple f -> s.s_children_l <- `Extension f :: s_children_l
    | `Intrusive f ->
        let path, hosts = path_and_hosts s in
        s.s_children_l <-
          `Extension (f hosts s_config_info path) :: s_children_l

  let create ?(config_info = Ocsigen_extensions.default_config_info ())
      ?(id = `Host (default_re_string, None)) ?charset
      ?(auto_load_extensions = false) ()
    =
    let s_id =
      match id with
      | `Host (host_regexp, port) when host_regexp = default_re_string ->
          `Host [default_re_string, default_re, port]
      | `Host (host_regexp, port) ->
          `Host
            [host_regexp, Ocsigen_lib.Netstring_pcre.regexp host_regexp, port]
      | `Attach (parent, path) ->
          `Attach (parent, Ocsigen_extensions.preprocess_site_path path)
    in
    let s =
      { s_id
      ; s_charset = charset
      ; s_config_info = config_info
      ; s_config_map = Hmap.empty
      ; s_children_l = [] }
    in
    (match s_id with
    | `Host _ -> l := s :: !l
    | `Attach (parent, _) ->
        parent.s_children_l <- `Child s :: parent.s_children_l);
    if auto_load_extensions
    then List.iter (register s) (List.rev !registered_extensions);
    s

  let rec dump_host path {s_config_map; s_children_l; _} =
    let f = function
      | `Extension f -> f {accessor = (fun (_, k) -> Hmap.find k s_config_map)}
      | `Child ({s_charset; s_id = `Attach (_, path'); _} as s) ->
          let path = path @ path' in
          Ocsigen_extensions.site_ext (dump_host path s) s_charset path
      | `Child _ -> failwith "Ocsigen_server.dump_host"
    in
    Ocsigen_extensions.compose (List.map f s_children_l)

  let dump () =
    let f acc = function
      | {s_config_info; s_id = `Host l; s_children_l = _ :: _; _} as s ->
          (l, s_config_info, dump_host [] s) :: acc
      | _ -> acc
    in
    Ocsigen_extensions.set_hosts (List.fold_left f [] !l)

  module Config = Make_config_nested (struct
    type nonrec t = t

    let get {s_config_map; _} = s_config_map
    let do_ ({s_config_map; _} as vh) f = vh.s_config_map <- f s_config_map
  end)
end

let start ?config () =
  try
    (* initialization functions for modules (Ocsigen extensions or application
       code) loaded from now on will be executed directly. *)
    Ocsigen_loader.set_init_on_load true;
    (match config with
    | Some (_ :: _ :: _) ->
        Lwt_log.ign_warning ~section "Multiple servers not supported anymore"
    | _ -> ());
    let ask_for_passwd sslports _ =
      print_string
        "Please enter the password for the HTTPS server listening on port(s) ";
      print_string
        (String.concat ", " (List.map (fun (_, p) -> string_of_int p) sslports));
      print_string ": ";
      let old_term = Unix.tcgetattr Unix.stdin in
      let old_echo = old_term.Unix.c_echo in
      old_term.Unix.c_echo <- false;
      Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term;
      try
        let r = read_line () in
        print_newline ();
        old_term.Unix.c_echo <- old_echo;
        Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term;
        r
      with exn ->
        old_term.Unix.c_echo <- old_echo;
        Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term;
        raise exn
    in
    let extensions_connector = Ocsigen_extensions.compute_result in
    let run s =
      let user = Ocsigen_config.get_user ()
      and group = Ocsigen_config.get_group () in
      Lwt_main.run (Ocsigen_messages.open_files ~user ~group ());
      let ports = Ocsigen_config.get_ports ()
      and ssl_ports = Ocsigen_config.get_ssl_ports () in
      let connection = match ports with [] -> [`All, 80] | l -> l in
      let ssl_connection =
        let ssl =
          match Ocsigen_config.get_ssl_info () with
          | None
          | Some
              { Ocsigen_config.ssl_certificate = None
              ; Ocsigen_config.ssl_privatekey = None
              ; _ } ->
              None
          | Some
              { Ocsigen_config.ssl_certificate = Some crt
              ; Ocsigen_config.ssl_privatekey = Some key
              ; _ } ->
              Some (crt, key)
          | Some {Ocsigen_config.ssl_privatekey = None; _} ->
              raise (Ocsigen_config.Config_file_error "SSL key is missing")
          | Some {Ocsigen_config.ssl_certificate = None; _} ->
              raise
                (Ocsigen_config.Config_file_error "SSL certificate is missing")
        in
        match ssl_ports, ssl with
        | [], Some (crt, key) -> [`All, 443, (crt, key)]
        | l, Some (crt, key) -> List.map (fun (a, p) -> a, p, (crt, key)) l
        | _ -> []
      in
      let current_uid = Unix.getuid () in
      let gid =
        match group with
        | None -> Unix.getgid ()
        | Some group -> (
          try (Unix.getgrnam group).Unix.gr_gid
          with Not_found as e ->
            Ocsigen_messages.errlog "Error: Wrong group";
            raise e)
      in
      let uid =
        match user with
        | None -> current_uid
        | Some user -> (
          try (Unix.getpwnam user).Unix.pw_uid
          with Not_found as e ->
            Ocsigen_messages.errlog "Error: Wrong user";
            raise e)
      in
      (* A pipe to communicate with the server *)
      let commandpipe = Ocsigen_config.get_command_pipe () in
      (try ignore (Unix.stat commandpipe)
       with Unix.Unix_error _ -> (
         try
           let umask = Unix.umask 0 in
           Unix.mkfifo commandpipe 0o660;
           Unix.chown commandpipe uid gid;
           ignore (Unix.umask umask);
           Lwt_log.ign_warning ~section "Command pipe created"
         with e ->
           Lwt_log.ign_error ~section ~exn:e "Cannot create the command pipe"));
      (* I change the user for the process *)
      (try
         (if current_uid = 0
         then
           match user with None -> () | Some user -> Unix.initgroups user gid);
         Unix.setgid gid; Unix.setuid uid
       with (Unix.Unix_error _ | Failure _) as e ->
         Lwt_log.ign_error ~section "Error: Wrong user or group";
         raise e);
      let minthreads = Ocsigen_config.get_minthreads ()
      and maxthreads = Ocsigen_config.get_maxthreads () in
      if minthreads > maxthreads
      then
        raise
          (Ocsigen_config.Config_file_error
             "maxthreads should be greater than minthreads");
      ignore
        (Lwt_preemptive.init minthreads maxthreads (fun s ->
             Lwt_log.ign_error ~section s));
      (Lwt.async_exception_hook :=
         fun e ->
           (* replace the default "exit 2" behaviour *)
           match e with
           | Unix.Unix_error (Unix.EPIPE, _, _) -> ()
           | _ -> Lwt_log.ign_error ~section ~exn:e "Uncaught Exception");
      (match s with
      | Some s ->
          (* Now I can load the modules *)
          Dynlink_wrapper.allow_unsafe_modules true;
          Ocsigen_extensions.start_initialisation ();
          Ocsigen_parseconfig.later_pass s;
          (* As libraries are reloaded each time the config file is
            read, we do not allow to register extensions in
            libraries. Seems it does not work :-/ *)
          Dynlink_wrapper.prohibit ["Ocsigen_extensions.R"]
      | None ->
          Ocsigen_extensions.start_initialisation ();
          Site.dump ());
      if Ocsigen_config.get_silent ()
      then (
        (* Close stderr, stdout stdin if silent *)
        (* redirect stdout and stderr to /dev/null *)
        let devnull = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0 in
        Unix.dup2 devnull Unix.stdout;
        Unix.dup2 devnull Unix.stderr;
        Unix.close devnull;
        Unix.close Unix.stdin);
      (* detach from the terminal *)
      if Ocsigen_config.get_daemon () then ignore (Unix.setsid ());
      Ocsigen_extensions.end_initialisation ();
      let pipe =
        Unix.(openfile commandpipe [O_RDWR; O_NONBLOCK; O_APPEND]) 0o660
        |> Lwt_unix.of_unix_file_descr
        |> Lwt_io.(of_fd ~mode:input)
      in
      let rec f () =
        Lwt_io.read_line pipe >>= fun s ->
        Ocsigen_messages.warning ("Command received: " ^ s);
        Lwt.catch
          (fun () ->
            let prefix, c =
              match Ocsigen_lib.String.split ~multisep:true ' ' s with
              | [] -> raise Ocsigen_command.Unknown_command
              | a :: l -> (
                try
                  let aa, ab = Ocsigen_lib.String.sep ':' a in
                  Some aa, ab :: l
                with Not_found -> None, a :: l)
            in
            Ocsigen_command.get_command_function () ?prefix s c)
          (function
            | Ocsigen_command.Unknown_command ->
                Lwt_log.ign_warning ~section "Unknown command";
                Lwt.return ()
            | e ->
                Lwt_log.ign_error ~section ~exn:e
                  "Uncaught Exception after command";
                Lwt.fail e)
        >>= f
      in
      ignore (f ());
      Lwt_main.run
      @@ Lwt.join
           (List.map
              (fun (address, port) ->
                Ocsigen_cohttp.service ~address ~port
                  ~connector:extensions_connector ())
              connection
           @ (List.map (fun (address, port, (crt, key)) ->
                  Ocsigen_cohttp.service
                    ~ssl:(crt, key, Some (ask_for_passwd [address, port]))
                    ~address ~port ~connector:extensions_connector ()))
               ssl_connection)
      (*
         Ocsigen_messages.warning "Ocsigen has been launched (initialisations ok)";

       fst (Lwt.wait ())
       *)
    in
    (*
  let set_passwd_if_needed (ssl, ports, sslports) =
    if sslports <> []
    then
      match ssl with
      | None
      | Some (None, None) -> ()
      | Some (None, _) -> raise (Ocsigen_config.Config_file_error
                                   "SSL certificate is missing")
      | Some (_, None) -> raise (Ocsigen_config.Config_file_error
                                   "SSL key is missing")
      | Some ((Some c), (Some k)) ->
        Ssl.set_password_callback !Server.ssl_context (ask_for_passwd sslports);
        Ssl.use_certificate !Server.ssl_context c k
  in
  *)
    let write_pid pid =
      match Ocsigen_config.get_pidfile () with
      | None -> ()
      | Some p ->
          let spid = string_of_int pid ^ "\n" in
          let len = String.length spid in
          let f =
            Unix.openfile p [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o640
          in
          ignore (Unix.write_substring f spid 0 len);
          Unix.close f
    in
    let launch h =
      Ocsigen_lib.Option.iter Ocsigen_parseconfig.first_pass h;
      (* set_passwd_if_needed sslinfo; *)
      if Ocsigen_config.get_daemon ()
      then
        let pid = Unix.fork () in
        if pid = 0
        then run h
        else (
          Ocsigen_messages.console (fun () ->
              "Process " ^ string_of_int pid ^ " detached");
          write_pid pid)
      else (
        write_pid (Unix.getpid ());
        run h)
    in
    let launch = function
      | Some [] -> ()
      | Some [h] -> launch (Some h)
      | None -> launch None
      | Some (_ :: _ :: _) -> ()
      (* Multiple servers not supported any more *)
    in
    launch config
  with e ->
    let msg, errno = errmsg e in
    Ocsigen_messages.errlog msg;
    exit errno