whitelister/whitelister.ml

(**************************************************************************)
(*                                                                        *)
(*      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               *)
(*                                                                        *)
(**************************************************************************)

(* types *)

type config = {
  mutable pidf:        string;
  mutable sock:        Unix.sockaddr;
  mutable user:        string;
  mutable group:       string;
  mutable verb:        int;

  mutable rbl:         string list;
  mutable rhbl_client: string list;
  mutable rhbl_rcpt:   string list;
  mutable rhbl_sender: string list;
  mutable rhbl_helo:   string list;
 
  mutable dns_client:  bool;
  mutable dns_rev_client: bool;
}

(* Checker *)

let log msg =
  let lg = Syslog.openlog ~facility:`LOG_MAIL ~flags:[`LOG_PID] "whitelister" in
  Syslog.syslog lg `LOG_INFO msg;
  Syslog.closelog lg

let log_event level answer pcy =
  log (Policy.log_format level answer pcy)

let checker cfg s =
  let oc  = Unix.out_channel_of_descr s in
  try
    while true do
      let pcy = Policy.read (Unix.in_channel_of_descr s) in
      let ans = (
        try
          Rules.check_rbl cfg.rbl pcy;
          Rules.check_rhbl Rules.Helo   cfg.rhbl_helo   pcy;
          Rules.check_rhbl Rules.Sender cfg.rhbl_sender pcy;
          Rules.check_rhbl Rules.Rcpt   cfg.rhbl_rcpt   pcy;
          Rules.check_rhbl Rules.Client cfg.rhbl_client pcy;
          Rules.check_dns_client 	cfg.dns_client	pcy;
          Rules.check_dns_rev_client 	cfg.dns_rev_client pcy;
          if cfg.verb > 0 then log_event "Clean" "OK" pcy;
          "OK"
        with
          | Rules.Dirty  s ->
              log_event "Dirty" (Printf.sprintf "DUNNO (%s)" s) pcy;
              "DUNNO"
          | Rules.Reject s ->
              let s' = "REJECT "^s in
              log_event "Reject" s' pcy;
              s'
      ) in
      Printf.fprintf oc "action=%s\n\n" ans;
      flush oc;
      Policy.clear pcy (* not needed, but can help the GC *)
    done
  with _ -> Unix.shutdown s Unix.SHUTDOWN_ALL

(* Configuration *)

let empty_config () = {
  pidf        = "/var/run/whitelister.pid" ;
  sock        = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 10000) ;
  user        = "nobody" ;
  group       = "nogroup" ;
  verb        = 0 ;

  rbl         = [] ;
  rhbl_client = [] ;
  rhbl_rcpt   = [] ;
  rhbl_sender = [] ;
  rhbl_helo   = [] ;

  dns_client = false;
  dns_rev_client = false;
}

let to_bool s =
  function
    | "0" | "off" | "no" -> false
    | "1" | "yes" | "on" -> true
    | _ -> prerr_endline ("cannot read a boolean value for `"^s^"', possible values are on/off, yes/no, 1/0"); exit 1

let update_config cfg file =
  let ic  = open_in file in
  try
    while true do
      let line = input_line ic in
      if String.length line > 0 && line.[0] <> '#' then
        match Str.split (Str.regexp "[ \t:]+") line with
          | [] -> ()

          | ["pidf"; f]        -> cfg.pidf        <- f
          | ["sock"; s]        -> cfg.sock        <- Unix.ADDR_UNIX s
          | ["sock"; ip; p]    -> cfg.sock        <- Unix.ADDR_INET (Unix.inet_addr_of_string ip, int_of_string p)
          | ["user"; u]        -> cfg.user        <- u
          | ["group"; g]       -> cfg.group       <- g
          | ["verb"; "0"]      -> cfg.verb        <- 0
          | ["verb"; "1"]      -> cfg.verb        <- 1

          | ["rbl";  h]        -> cfg.rbl         <- h::cfg.rbl
          | ["rhbl_client"; h] -> cfg.rhbl_client <- h::cfg.rhbl_client
          | ["rhbl_helo"; h]   -> cfg.rhbl_helo   <- h::cfg.rhbl_helo
          | ["rhbl_rcpt"; h]   -> cfg.rhbl_rcpt   <- h::cfg.rhbl_rcpt
          | ["rhbl_sender"; h] -> cfg.rhbl_sender <- h::cfg.rhbl_sender

          | ["dns_client"; d]     -> cfg.dns_client     <- to_bool "dns_client" d
          | ["dns_rev_client"; e] -> cfg.dns_rev_client <- to_bool "dns_rev_client" e

        (* deprecated settings *)
          | ["rhbl"; h]        -> prerr_endline "rhbl is deprecated, it defaults to rhbl_client which may not be what you want.";
                                  cfg.rhbl_client <- h::cfg.rhbl_client
          | _ -> prerr_string (Printf.sprintf "`%s' is not a valid config line\n" line)
    done;
    assert false
  with End_of_file -> close_in ic; cfg

let read_config () =
  let found_files = List.filter Sys.file_exists ["/etc/whitelister.conf" ; "whitelister.conf"] in
  List.fold_left update_config (empty_config ()) found_files

(* Server thingies *)

open Server

let my_server_loop cfg sock =
  pidfile_write ();
  pidfile_close ();
  log ("started, listening to " ^ (string_of_sockaddr cfg.sock));
  while true do
    let s = fst (unix_do Unix.accept sock) in
    double_fork (fun s -> Unix.close sock; checker cfg s ; exit 0) s;
    Unix.close s
  done

(* Main LOOP *)

let _ =
  let cfg = read_config () in
  pidfile_open cfg.pidf;
  pidfile_write ();
  daemonize (cfg.user,cfg.group) (my_server_loop cfg) (bind_to_sock cfg.sock)