#!/usr/bin/perl -w
# This is a pwcheck daemon for checking Cyrus IMAP with SASL logins against
#   a database.
#
# You need a table with a User name column (constant USERFLD) and a
#   password column (constant PASSWORDFLD).
#
# Passwords can be inserted using MySQL's PASSWORD() function to encrypt them,
# or using builtin MD5 (see constant USE_MD5 below).
#
# You need to put 3 params in a file called /etc/authcheck.conf:
#   databasename user password tablename
# Note that each param should be on a separate line (not like here!)
# The 1st param is a DBI connection string, eg. dbi:mysql:dbname:host
#
# Also see the comments with constant USE_MD5 (below).
#
# This is loosely based on code attributed as:
#   authcheck, (C) Vladimir Ivaschenko <vi@maks.net>, GPL2 license
#   http://www.hazard.maks.net/~hazard
#
# The preforking server code is from The Perl Cookbook (O'Reilly), Recipe 17.12.
#
# The remaining code is (C) Jeremy Howard <jhoward@fastmail.fm>, GPL2 license
#   http://www.fastmail.fm
#
# Mon 10 Jul 2000 11:51:44 AM EEST: Vladimir Ivaschenko <vi@maks.net>
# - some changes to backward compatibility with old authcheck
# - daemonize
#
# TODO:
# --Add POD documentation
# --Deal with clients timing out better

use strict;
use IO::Socket;
use Symbol;
use DBI;
use Digest::MD5 qw(md5_base64);
use Unix::Syslog qw(:macros :subs);
use POSIX;
use constant PATH=>'/var/pwcheck/pwcheck';
use constant PIDPATH=>'/var/lock/authcheck.pid';
use constant PASSWORDFLD=>'password';
use constant USERFLD=>'login';
use constant CONFIGFILE=>'/etc/authcheck.conf';
# USE_MD5 is 1 if passwords are scrambled with md5_base64 (perl function), or
#   0 (zero) if passwords are scrambled with MySQL's PASSWORD() function.
use constant USE_MD5=>1;

#------------------------------------------------------------
# global variables
my $PREFORK                = 5;        # number of children to maintain
my $MAX_CLIENTS_PER_CHILD  = 100;      # number of clients each child should process
my %children               = ();       # keys are current child process IDs
my $children               = 0;        # current number of children

#------------------------------------------------------------
# Grab login params from command line
open (CONFIG, '<'.CONFIGFILE);
chomp (my ($D_DSN, $D_LOGIN, $D_PASSWORD, $D_TABLE) = <CONFIG>);
close CONFIG;

#------------------------------------------------------------
# Create database and statement handlers if not already done
my ($dbh,$sth) = undef;
sub dbConnect {
  # Create connection to database.
  #   This doesn't do anything if already connected.
  if (!$dbh || $DBI::errstr || !$dbh->{Active}) {
    Unix::Syslog::syslog LOG_INFO, "Connecting to database", 0;
    $sth->finish() if $sth;
    $dbh->disconnect() if $dbh;
    $dbh = undef; # Some drivers (e.g. DBD::Sybase) need this
    $dbh = DBI->connect ($D_DSN, $D_LOGIN, $D_PASSWORD);
    # Create statement handle
    # The SQL gets the encrypted version of user's claimed password, and
    #   the actual encrypted version stored in database. If the user doesn't
    #   exist, no rows will be returned.
    $sth = $dbh->prepare(
      'SELECT PASSWORD(?), '.PASSWORDFLD.' FROM '.$D_TABLE.' WHERE '.USERFLD.'=?'
    ) if $dbh;
  }
  # If anything didn't work, wait a while and try again
  if ($DBI::errstr) {
    Unix::Syslog::syslog LOG_ERR, "No DB connection--reconnecting", 0;
    sleep 10;
    # Avoids recursion with a 'goto' (I think)--avoid filling up stack space
    goto &dbConnect;
  }
}

#------------------------------------------------------------
# Get the password corresponding with this user
sub GetRows {
  my $username=$_[0];
  my $password=$_[1];
  my @rows=undef;
  dbConnect();
  # Try and exec the query. If we can't, we've probably lost our DB connection...
  while (!$sth->execute($username, $password)) {
   #  ... so wait a while and get it back.
    sleep 10;
    dbConnect();
  }
  if (defined $DBI::errstr) {
    Unix::Syslog::syslog LOG_ERR, $DBI::errstr;
    return ();
  }
  @rows=$sth->fetchrow_array;
  return @rows;
}

#------------------------------------------------------------
# Set up socket
Unix::Syslog::openlog("authcheck", LOG_PID | LOG_CONS, LOG_DAEMON);
unlink (PATH);
# Save current default permissions for this process, and remove default 
#   permissions before creating socket
my $oldumask = umask(0);
my $listen = undef;
# Try and listen on socket defined by PATH
if (!($listen = IO::Socket::UNIX->new(
  Type=>SOCK_STREAM, Local=>PATH, Listen=>0))) { 
  Unix::Syslog::syslog LOG_ERR, "Could not open listen socket.", 0;
  die "Could not open listen socket."; 
}
# Restore this process's permissions
umask($oldumask);
# Record separator = empty lines (see perldoc perlvar)
$/ = "\000";

#------------------------------------------------------------
# takes care of dead children
sub REAPER {                        
  $SIG{CHLD} = \&REAPER;
  my $pid = wait;
  $children --;
  delete $children{$pid};
  $sth->finish() if $sth;
  $dbh->disconnect() if $dbh;
}

#------------------------------------------------------------
# signal handler for SIGINT
sub HUNTSMAN {                      
  local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
  unlink (PATH);
  unlink (PIDPATH);
  syslog LOG_ERR, "Exiting on INT signal.";
  kill 'INT' => keys %children;
  exit;                           # clean up with dignity
}

# daemonize
if (fork()) { exit(0); }

open STDIN,  '/dev/null' or die "Can't read /dev/null: $!";
open STDOUT, '>/dev/null';
open STDERR, '>/dev/null';
# Change to root dir to avoid locking a mounted file system
chdir '/'                 or die "Can't chdir to /: $!";
# Turn process into session leader, and ensure no controlling terminal
POSIX::setsid();

# Fork off our children.
for (1 .. $PREFORK) {
  make_new_child();
}

# Install signal handlers.
$SIG{CHLD} = \&REAPER;
$SIG{INT}  = \&HUNTSMAN;


# And maintain the population.
while (1) {
  sleep;                          # wait for a signal (i.e., child's death)
  for (my $i = $children; $i < $PREFORK; $i++) {
    make_new_child();           # top up the child pool
  }
}

sub make_new_child {
  my $pid;
  my $sigset;
  
  # block signal for fork
  $sigset = POSIX::SigSet->new(SIGINT);
  sigprocmask(SIG_BLOCK, $sigset)
      or die "Can't block SIGINT for fork: $!\n";
  
  die "fork: $!" unless defined ($pid = fork);
  
  if ($pid) {
    # Parent records the child's birth and returns.
    sigprocmask(SIG_UNBLOCK, $sigset)
        or die "Can't unblock SIGINT for fork: $!\n";
    $children{$pid} = 1;
    $children++;
    return;
  } else {
    # Child can *not* return from this subroutine.
    $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before

    # unblock signals
    sigprocmask(SIG_UNBLOCK, $sigset)
      or die "Can't unblock SIGINT for fork: $!\n";

    # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
    for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
      my $sock = $listen->accept()     or last;
      # do the actual work!
      CheckPassword($sock);
    }

    # tidy up gracefully and finish

    # this exit is VERY important, otherwise the child will become
    # a producer of more and more children, forking yourself into
    # process death.
    exit;
  }
}

sub CheckPassword {
  my ($sock) = @_;
  my $username=$sock->getline || return undef;
  chop $username;
  my $password=$sock->getline || return undef;
  chop $password;
  my @rows = GetRows($password, $username);
  # @rows now contains (Encrypted ver of curr password, encrypted
  #   version of actual password), or is empty if the user doesn't exist.
  if ($#rows>=0 && (USE_MD5 
    ? $rows[1] eq md5_base64($password) # Use md5_base64 scrambled pass
    : $rows[1] eq $rows[0])) {          # Use MySQL PASSWORD()
#	    syslog LOG_INFO, "success $username $password";
    $sock->printflush("OK\000"); 
  } else { 
#	    syslog LOG_INFO, "fail $username $password";
    $sock->printflush("Incorrect password\000"); 
  }
  # Do we need to close the socket? Perl Cookbook doesn't...
  $sock->close;
}