(**************************************************************************)
(*                                                                        *)
(*      whitelister : a Whitelister Policy Daemon for Postfix             *)
(*      ~~~~~~~~~~~                                                       *)
(*                                                                        *)
(*  Copyright (C) 2005 AAEGE.org                                          *)
(*  Author : Pierre Habouzit <pierre.habouzit@m4x.org>                    *)
(*  ____________________________________________________________________  *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 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 General Public License for more details.                          *)
(*                                                                        *)
(*  You should have received a copy of the GNU 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 Unix

let string_of_sockaddr = function
  | ADDR_UNIX u     -> "unix:"^u
  | ADDR_INET (a,p) -> Printf.sprintf "inet:%s:%i" (string_of_inet_addr a) p

let rec unix_do f x =
  try f x
  with Unix_error(EINTR, _, _) -> unix_do f x

(* pid file stuff *)

let pidfile_fd = ref None

let pidfile_close () =
  match !pidfile_fd with
    | Some f -> close f; pidfile_fd := None
    | None -> ()

let pidfile_open file =
  try
    pidfile_close ();
    pidfile_fd := Some (openfile file [O_WRONLY;O_CREAT;O_TRUNC] 0o644)
  with Sys_error _ ->
        prerr_endline ("Cannot write my pid in the pidfile "^file);
        exit 1

let pidfile_write () =
  match !pidfile_fd with
    | None ->
        prerr_endline ("pidfile is not open, call pidfile_open before pidfile_write");
        exit 1
    | Some fd ->
        ignore (lseek fd 0 SEEK_SET);
        ftruncate fd 0;
        let pid = Printf.sprintf "%i\n" (getpid()) in
        ignore (unix_do (single_write fd pid 0) (String.length pid))

(* server stuff *)

let drop_privs ( user, group ) =
  if geteuid () = 0 then (
    setgid (getgrnam group).gr_gid;
    setuid (getpwnam user).pw_uid
  )

let bind_to_sock sockaddr =
  (match sockaddr with ADDR_UNIX u -> (try unlink u with _ -> ()) | _ -> ());
  let mask = umask 0o111 in
  let sock = socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
  setsockopt sock SO_REUSEADDR true;
  bind sock sockaddr;
  listen sock 0;
  let _ = umask mask in
  sock

let double_fork f x =
  match fork () with
    | 0  -> if fork () <> 0 then exit 0; f x
    | id -> ignore (waitpid [] id)

let daemonize runas server_loop arg =
  drop_privs runas;
  let dev_null = openfile "/dev/null" [O_WRONLY] 0o666 in
  close stdin;
  dup2 dev_null stdout;
  dup2 dev_null stderr;
  close dev_null;
  double_fork server_loop arg