#!/usr/bin/perl

##########################################################################
# rbld - Daemon that reads and serves IP based blacklists and whitelists
# Copyright 2006, Bluehost, Inc.
#
# Authors and Contributers:
#
# Spencer Candland  <spencer@bluehost.com>
# Ryan Chaudhry     <rchaudhry@bluehost.com>
# Erick Cantwell    <erick@bluehost.com>
#
# http://www.bluehost.com
# https://github.com/bluehost/rbld
#
##########################################################################
#
# This file is part of rbld
#
# Rbld 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, MA02111-1307, USA.
#
##########################################################################

use strict;
use warnings;

use IO::File;
use IO::Socket;
use Fcntl qw(F_SETFD);
use Proc::Daemon;
use Proc::PID::File;
use Data::Dumper;
use Getopt::Long;
use YAML::Syck qw(LoadFile);
use Time::HiRes qw(gettimeofday tv_interval);
use POSIX;

my $config   = {};
my $settings = {};

my $defaults = {
    rbld_conf  => '/etc/rbld.conf',
    log        => '/var/log/rbld.log',
    infile     => '/etc/inrbld',
    listconf   => '/etc/rbld.d/rbldlists.conf',
    run_path   => '/usr/sbin/rbld',
    sock_path  => '/var/tmp/rbld.sock',
    sock_owner => 'mailnull',
    sock_group => 'nobody',
    debug      => 0,
};

# Get cli options
GetOptions (
    'c|config=s'      => \$config->{rbld_conf},
    'o|log=s'         => \$config->{log},
    'i|infile=s'      => \$config->{infile},
    'l|listconf=s'    => \$config->{listconf},
    'r|runpath=s'     => \$config->{run_path},
    's|socketpath=s'  => \$config->{sock_path},
    'u|socketowner=s' => \$config->{sock_owner},
    'g|socketgroup=s' => \$config->{sock_group},
    'd|debug'         => \$config->{debug},
    'h|help'          => \&help,
) || &help;

# Start
my @start = gettimeofday();
my $DEBUG = 0;
my ($dfh, $in_pid);
my %lists;
my %all;
my %info = (
  blacklist         => {},
  infile	    => {},
  metastats	    => {},
  starttime         => time(),
  stats		    => {},
  whitelist         => {},
);

my %run = (
  DEBUG                   => sub { $DEBUG = shift; return; },
  DUMP                    => sub { return Dumper (%info, %lists); },
  LOAD_CONF		  => \&load_conf,
  LOAD_LIST		  => \&load_list,
  CIDR			  => \&check_cidr,
  IP			  => \&check_ip,
  TRIE			  => \&check_trie,
  META			  => \&check_meta,
  ALL			  => \&check_all,
  WHITELIST		  => \&check_whitelist, 
  STAT			  => \&give_stats,
  STATS			  => \&give_stats,
);

my %load = (
  CIDR			  => \&load_cidr,
  IP			  => \&load_ip,
  TRIE			  => \&load_trie,
  META			  => \&load_meta,
);

sub debug {
  return unless $DEBUG;
  warn scalar(localtime).": [$$] @_";
}

sub main {
  # Load default or cli specified configuration file
  if ($config->{rbld_conf}) {
      $settings = LoadFile($config->{rbld_conf});
  } else {
      $settings = LoadFile($defaults->{rbld_conf});
  }

  # Merge to config hash
  # These/this should be moved to a subroutine
  my @vals = ('log', 'infile', 'listconf', 'run_path', 'sock_path', 'sock_owner', 'sock_group', 'debug');

  # First, merge conf file to cli
  foreach (@vals) {
      my $val = $_;
      unless ($config->{$val}) {
          if ($settings->{$val}) {
              $config->{$val} = $settings->{$val};
          }
      }
  }

  # Next merge defaults into the config
  foreach (@vals) {
      my $val = $_;
      unless ($config->{$val}) {
          if ($defaults->{$val}) {
              $config->{$val} = $defaults->{$val};
          }
      }
  }

  $DEBUG = 1 if $config->{debug};
  $0 = "rbld";

  Proc::Daemon::Init() unless $ENV{BIND_FD};
  umask 0117;
  exit 1 if Proc::PID::File->running();

  open_log();

  $SIG{TERM} = $SIG{INT} = sub { exit 0 };
  $SIG{PIPE} = sub { die "PIPE" };
  my $sigset = POSIX::SigSet->new();
  POSIX::sigaction(&POSIX::SIGUSR2, POSIX::SigAction->new('open_log',
     $sigset, &POSIX::SA_NODEFER));
  POSIX::sigaction(&POSIX::SIGHUP, POSIX::SigAction->new('reload',
     $sigset, &POSIX::SA_NODEFER));

  reset_infile();
  my @rblstart = gettimeofday();
  warn scalar(localtime).": [$$] Loading Conf and Lists...\n";
  load_conf($config->{listconf});
  &link_meta;
  warn scalar(localtime).": [$$] load completed in (".tv_interval (\@rblstart).").\n";

  my $listen;
  if (exists $ENV{BIND_FD} and $ENV{BIND_FD} =~ /^(\d+)$/) {
    my $bind_fd = $1;
    debug "Reusing fd($bind_fd)\n";
    $listen = IO::Socket::UNIX->new();
    $listen->fdopen($bind_fd, "r") or die "Socket: $!";
  }
  else {
    unlink $config->{sock_path};
    $listen = IO::Socket::UNIX->new(
      Local  => $config->{sock_path},
      Listen => SOMAXCONN,
    ) or die "Socket: $!";

    chown ( ((getpwnam("$config->{sock_owner}"))[2]), ((getgrnam("$config->{sock_group}"))[2]),  $config->{sock_path}) || warn "Could not chown socket: $!";
  }

  warn scalar(localtime).": [$$] $0 startup completed in (".tv_interval (\@start).").  Now Listening.\n";
  my ($conn, $req, $bvec, $rw, $timeleft, $nfound, $buffer, $data, $msg);
  while (1) {
    eval {
      $conn = $listen->accept() or die "Accept error: $!\n";
      $req = $bvec = '';
      vec($bvec, $conn->fileno, 1) = 1;
      $timeleft = 0.2;
      while ($timeleft > 0) {
        ($nfound, $timeleft) = select($rw=$bvec, undef, undef, $timeleft);
        $buffer = '';
        if ($nfound != 0) {
          sysread($conn, $buffer, 8192) or die "EOF on connection\n";
        }
        $req .= $buffer;
        last if index($buffer, "\n") > 0;
      }
      die "Timed out on request\n" if $timeleft == 0;
      $req =~ s/\n.*//;
    };
    if ($@) {
      debug $@;
      $conn->shutdown(2) if $conn;
      next;
    }

    $info{requests}++;

    my ($cmd, $args) = split (/\s+/, $req, 2);
    $msg = '';
    if ($run{$cmd}) {
      debug "Running command [$req]\n";
      $msg = &{$run{$cmd}}($args);
    } else {
      debug "Unknown command [$req]\n";
    }


    eval {
      $timeleft = 0.5;
      $buffer = 0;
      if ($msg) {
        do {
          ($nfound, $timeleft) = select(undef, $rw=$bvec, undef, $timeleft);
          if ($nfound != 0) {
            $buffer += syswrite($conn, $msg, length($msg));
          }
        } until ($timeleft == 0 or $buffer == length($msg));
      }
      $conn->shutdown(2);
    };
  }
}

# NAME  TYPE [whitelist|blacklist]  FILE  FILE_FORMAT[IP|CIDR|TRIE|META]:[EXPIRE|TRIE_SPLIT|LIST]  [STAT_ONLY]
sub load_conf {

  my $cfile = shift;
  debug "Loading config file $cfile\n";
  my %nlists;
  if (-e $cfile) {
    # read the config
    open (CF, "<$cfile");
    flock (CF, 2);
    while (<CF>) {
      chomp($_);
      next unless ($_);
      next if (substr($_, 0, 1) eq "#");
      my @tmp = split (/\s+/, $_);
      my $file = $tmp[2];
      # Make sure we have a valid type
      my $type = $tmp[1];
      next unless (($type eq "whitelist") or ($type eq "blacklist"));
      # Make sure we have a valid format
      my @split = split (/:/, $tmp[3]);
      my $format = $split[0];
      next unless (exists ($load{$format}));

      $nlists{$file}{"file"} = $file;
      $nlists{$file}{"name"} = $tmp[0];
      $nlists{$file}{"type"} = $type;
      $nlists{$file}{"format"} = $format;
      $nlists{$file}{"split"} = $split[1] || 0;
      $nlists{$file}{"stat_only"} = $tmp[4] || 0;
      $nlists{$file}{"cfile"} = $cfile;
      # So we can get at data through name as well, which
      # is how queries to the list actually come through
      $nlists{$tmp[0]} = \%{$nlists{$file}};
    }
    flock (CF, 8);
    close (CF);

    foreach my $file (keys %nlists) {
      # See if conf changed    
      if (exists $lists{$file}) {
        my $diff = 0;
        foreach (keys %{$nlists{$file}}) {
          $diff = 1 if ($nlists{$file}{$_} ne $lists{$file}{$_});
        }
        next unless ($diff == 1);
      }

      my $name = $nlists{$file}{"name"};
      $lists{$file} = $nlists{$file};
      load_list ($file);
      # Create our inwatch watches
      my $realfile = $lists{$file}{"file"};
      add_to_infile ($realfile, "LOAD_LIST") unless (exists $nlists{$name}{"meta"});
      # Create a run command for the list
      $run{$name} = sub { return check_list($name, shift); },
    }

    # Find and delete options that were removed
    foreach my $file (keys %lists) {
      next unless ($lists{$file}{"cfile"} eq $cfile);
      unless (exists $nlists{$file}) {
        debug "$file was removed from conf $cfile, removing\n";
        my $type = $lists{$file}{"type"};
        my $name = $lists{$file}{"name"};
        delete ($info{$type}{$name});
        delete ($info{"stats"}{$name});
        delete ($lists{$file});
        delete ($run{$name});
      }
    }
  }
  # Even if it doesn't exist we want to add it, that way
  # we can create it and then watch it.  Mainly useful
  # for things like our local whitelists, which may not
  # exist yet on new servers
  add_to_infile ($cfile, "LOAD_CONF");
}

# Take any list, and call correct routine based on format
sub load_list {
  my $file = shift;
  debug "Caught load_list on $file\n";
  my $format = $lists{$file}{"format"};
  if ($load{$format}) {
    my $name = $lists{$file}{"name"};
    warn scalar(localtime).": [$$] Loading $name $file (".$lists{$file}{"type"}." $format)\n";
    return &{$load{$format}}($file);
  }
}

sub load_cidr {
  my $file = shift;
  if (-e $file) {
    open (LST, "<$file");
    flock (LST, 2);
    my $type = $lists{$file}{"type"};
    my $name = $lists{$file}{"name"};
    my $split = $lists{$file}{"split"};
    my $expire = 0;
    delete ($info{$type}{$name});
    while (<LST>) {
      chomp($_);
      next unless ($_);
      next if (substr($_, 0, 1) eq "#");
      my $line = $_;
      if ($split) {
        my @tmp = split (/\s+/, $_);
        if (time >= $tmp[0]) {
          $expire = 1;
          next;
        }
        $line = $tmp[1];
      }
      my ($ip, $mask) = split (/\//, $line);
      if ($mask < 8) {
        warn scalar(localtime).": [$$] CIDR range is too large ($ip/$mask), skipping.\n";
        next;
      }
      # Handle ranges bigger then 16
      my $range = 0;
      if ($mask < 16) {
        $range = ((2 ** (16 - $mask)) - 1);
      }
      foreach (0 .. $range) {
        my $adjm = (32 - $mask);
        my @oct = split (/\./, $ip);
        $oct[1] += $_;

        # Make sure we have some minimum and maximum values
        $info{$type}{$name}{$oct[0]}{$oct[1]}{min} = $adjm unless (exists $info{$type}{$name}{$oct[0]}{$oct[1]}{min});
        $info{$type}{$name}{$oct[0]}{$oct[1]}{max} = $adjm unless (exists $info{$type}{$name}{$oct[0]}{$oct[1]}{max});

        $info{$type}{$name}{$oct[0]}{$oct[1]}{min} = $adjm if ($adjm < $info{$type}{$name}{$oct[0]}{$oct[1]}{min});
        $info{$type}{$name}{$oct[0]}{$oct[1]}{max} = $adjm if ($adjm > $info{$type}{$name}{$oct[0]}{$oct[1]}{max});

        my $pack = unpack("N", pack("C4", @oct)) >> $adjm;
        $info{$type}{$name}{$oct[0]}{$oct[1]}{$adjm}{$pack} = 1;
      }
    }
    if ($expire == 1) {
      seek (LST, 0, 0);
      foreach (keys %{$info{$type}{$name}}) {
        print LST "$info{$type}{$name}{$_} $_\n";
      }
      truncate LBT, tell(LBT);
    }
    flock (LST, 8);
    close (LST);
    $all{$name} = 1;
  }
}

sub load_ip {
  my $file = shift;
  if (-e $file) {
    open (LST, "+<$file");
    flock (LST, 2);
    my $type = $lists{$file}{"type"};
    my $name = $lists{$file}{"name"};
    my $split = $lists{$file}{"split"};
    my $expire = 0;
    delete ($info{$type}{$name});
    while (<LST>) {
      chomp($_);
      next unless ($_);
      next if (substr($_, 0, 1) eq "#");
      if ($split) {
        my @tmp = split (/\s+/, $_);
        if (time >= $tmp[0]) {
          $expire = 1;
          next;
        }
        $info{$type}{$name}{$tmp[1]} = $tmp[0];
      } else {
        $info{$type}{$name}{$_} = 1;
      }
    }
    if ($expire == 1) {
      seek (LST, 0, 0);
      foreach (keys %{$info{$type}{$name}}) {
        print LST "$info{$type}{$name}{$_} $_\n";
      }
      truncate LBT, tell(LBT);
    }
    flock (LST, 8);
    close (LST);
    $all{$name} = 1;
  }
}

sub load_meta {
  my $file = shift;
  @{$lists{$file}{"meta"}} = split (/,/, $lists{$file}{"split"});
}

sub load_trie {
  my $file = shift;
  if (-e $file) {
    open (LST, "<$file");
    flock (LST, 2);
    my $type = $lists{$file}{"type"};
    my $name = $lists{$file}{"name"};
    delete ($info{$type}{$name});
    while (<LST>) {
      chomp($_);
      next unless ($_);
      next if (substr($_, 0, 1) eq "#");
      my ($key, $value) = split (/\s+/);
      $info{$type}{$name}{$key} = $value;
    }
    flock (LST, 8);
    close (LST);
    $all{$name} = 1;
  }
}

# Make fake meta_list masquarade as a real list, primarily for stats
sub link_meta {
  foreach (keys %lists) {
    if ($lists{$_}{"format"} eq "META") {
      my $meta_name = $lists{$_}{"name"};
      foreach my $list_name (@{$lists{$meta_name}{"meta"}}) {
        $lists{$meta_name."_".$list_name} = \%{$lists{$list_name}};
      }
    }
  }
}

# Whitelists are global, so checks all whitelists.
sub check_whitelist {
  my $ip = shift;
  foreach my $name (keys %{$info{whitelist}}) {
    $info{"stats"}{$name}{"requests"}++;
    my $format = $lists{$name}{"format"};
    if (&{$run{$format}}($name, $ip)) {
      $info{"stats"}{$name}{"rejections"}++;
      return 1;
    }
  }
  return 0;
}

# Check any list, will call correct routine based on format
sub check_list {
  my $name = shift;
  my $ip = shift;
  my $format = $lists{$name}{"format"};

  # Increment requests
  $info{"stats"}{$name}{"requests"}++;

  my $ret = &{$run{$format}}($name, $ip);
  if ($ret) {
    my $type = $lists{$name}{"type"};
    # If type is not a blacklist we don't need to check whitelist
    if ($type ne "blacklist") {
      $info{"stats"}{$name}{"rejections"}++;
      # Don't block if we are setup as stats only
      return 0 if ($lists{$name}{"stat_only"});
      return 1;
    }

    # If we were on a blacklist, check the whitelist.
    # We do it in this order to get good whitelist stats.
    return 0 if (check_whitelist($ip));
    $info{"stats"}{$name}{"rejections"}++;
    if ($ret ne 1) {
      $info{"stats"}{$ret}{"rejections"}++ if ($ret ne 1);
      return 0 if ($lists{$ret}{"stat_only"});
    }
    # Don't block if we are setup as stats only
    return 0 if ($lists{$name}{"stat_only"});
    return 1;
  }
  return 0
}

sub check_all {
  # TODO, gather stats, requests and rejections, on
  # the exact lists inside the "all" list.
  # TODO, make it so you can specify a "all" list
  # in the conf
  my $ip = shift;
  my $hits = "";
  foreach my $list_name (keys %all) {
    my $format = $lists{$list_name}{"format"};
    $hits .= "$list_name " if (&{$run{$format}}($list_name, $ip));
  }
  return 0 if (check_whitelist($ip));
  return $hits;
}

sub check_cidr {
  my $name = shift;
  my $ip = shift;
  my $type = $lists{$name}{"type"};

  my @oct = split (/\./, $ip);
  return 0 unless (exists $info{$type}{$name}{$oct[0]});
  return 0 unless (exists $info{$type}{$name}{$oct[0]}{$oct[1]});
  # bitshift from my min mask to max to do the check
  foreach ($info{$type}{$name}{$oct[0]}{$oct[1]}{min} .. $info{$type}{$name}{$oct[0]}{$oct[1]}{max}) {
    my $pack = unpack("N", pack("C4", @oct)) >> $_;
    return 1 if ($info{$type}{$name}{$oct[0]}{$oct[1]}{$_}{$pack});
  }
  return 0;
}

sub check_ip {
  my $name = shift;
  my $ip = shift;
  my $type = $lists{$name}{"type"};
  return 1 if ($info{$type}{$name}{$ip});
  return 0;
}

sub check_meta {
  my $name = shift;
  my $ip = shift;
  foreach my $list_name (@{$lists{$name}{"meta"}}) {
    # Make sure list actually exists
    next unless (exists $lists{$list_name});
    my $format = $lists{$list_name}{"format"};
    $info{"stats"}{$name."_".$list_name}{"requests"}++;
    return $name."_".$list_name if (&{$run{$format}}($list_name, $ip));
  }
  return 0;
}

sub check_trie {
  my $name = shift;
  my $ip = shift;
  my $type = $lists{$name}{"type"};
  my $split = $lists{$name}{"split"};

  my @oct = split (/\./, $ip);
  my $data = unpack("N", pack("C4", @oct));
  my $key = substr $data, 0, $split;
  my $value = substr $data, $split;

  return 0 unless (exists $info{$type}{$name}{$key});
  return 1 if (1+index( $info{$type}{$name}{$key}, ":$value:" ));
  return 0;
}

sub give_stats {
  my $running = time - $info{"starttime"};
  return unless ($running);
  my (@time) = gmtime($running);
  my $stats .= sprintf ("\n%30s:\t%d Days %d Hours %d Min %d Sec\n",
    "Uptime", $time[7], $time[2], $time[1], $time[0], $running);
  $stats .= sprintf ("%30s:\t%d\n", "Total Requests", $info{"requests"});
  $stats .= sprintf ("%30s:\t%.2f\n", "Requests Per Second", ($info{"requests"} / $running));
  foreach my $name (sort keys %{$info{"stats"}}) {
    my $wording = "Rejections";
    $stats .= sprintf ("\n%30s:\t%d (%.2f%%)", "$name Requests",
      $info{"stats"}{$name}{"requests"},
      (($info{"stats"}{$name}{"requests"} / $info{"requests"})*100));
    # It is kind of awkward to call a whitelist save a "rejection"
    # so we update the wording as appropriate
    $wording = "Saves" if ($lists{$name}{"type"} eq "whitelist");
    # Avoid uninitialized errors
    if (exists $info{"stats"}{$name}{"rejections"}) {
      $stats .= sprintf ("\n%30s:\t%d (%.2f%%)\n", "$name $wording",
        $info{"stats"}{$name}{"rejections"},
        (($info{"stats"}{$name}{"rejections"} / $info{"stats"}{$name}{"requests"}) * 100));
    } else {
      $stats .= sprintf ("\n%30s:\t%d\n", "$name $wording", 0);
    }
    $stats .= sprintf ("%30s:\t%.2f\n", "$name RPS", ($info{"stats"}{$name}{"requests"} / $running));
  }
  return $stats;
}

# Add a watch on a file via inwatch
sub add_to_infile {
  my $file = shift;
  return if ($info{"infile"}{$file});
  my $cmd = shift;
  open (INF, ">>$config->{infile}");
  print INF "$file IN_MODIFY|IN_CREATE_SELF SOCK RBLD $cmd $file\n";
  close (INF);
  $info{"infile"}{$file} = 1;
  return;
}

sub reset_infile {
  delete $info{"infile"};
  open (INF, ">$config->{infile}");
  close (INF);
}

sub open_log {
  warn scalar(localtime).": [$$] $0 Reseting log file...\n";
  close (STDERR);
  open STDERR, ">>$config->{log}";
  chmod 0600, $config->{log};
  warn scalar(localtime).": [$$] $0 Log file open.\n";
  # TODO, Make this reload on the next request after
  # something expires instead of once a day.
  # Reload lists with entries that expire.
  foreach my $file (keys %lists) {
    next unless ($lists{$file}{"split"});
    next if ($lists{$file}{"format"} eq "TRIE");
    load_list ($file);
  }
}

sub reload {
  warn scalar(localtime).": [$$] $0 reloading...\n";
  exit if fork;
  sleep 2;
  exec "$config->{run_path}" or die "exec: $!";
}

# HELP ME!!!
sub help {
    print <<EOF;
        -c|--config      Path to rbld daemon configuration file
        -o|--log=s       Path to rbld log
        -i|--infile      Path to rbld infile
        -l|--listconf    Path to rbld list configuration file
        -r|--runpath     Path to run path of script (/usr/sbin/rbld)
        -s|--socketpath  Path to rbld socket
        -u|--socketowner Who the rbld socket owner will be set to
        -g|--socketgroup Which group the rbld socket will be set to
        -d|--debug       Debug output
        -h|--help        This lovely help message
EOF
    exit 0;
}

END {
  debug "Exiting...\n";
  $dfh->close if defined $dfh;
  exit 0;
}


main();