#!@l_prefix@/bin/perl

##
##  Copyright (c) 2004  Klaraelvdalens Datakonsult AB
##
##    Writen by Steffen Hansen <steffen@klaralvdalens-datakonsult.se>
##
##  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, 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 can view the  GNU General Public License, online, at the GNU
##  Project's homepage; see <http://www.gnu.org/licenses/gpl.html>.
##

use Fcntl;
use Sys::Syslog qw(:DEFAULT setlogsock);
use URI;
use Net::LDAP qw(LDAP_NO_SUCH_OBJECT);
use Net::LDAP::Entry;
use Net::hostent;
use Socket;
use Kolab::Util;

my %conf;

#
# Usage: kolab_smtpd_policy.pl [-v]
#
# kolabdelegated Postfix SMTPD policy server for Kolab. This server implements
# various policies for Kolab:
#
# 1) Only authenticated users can use From addresses <username>@$domain
# 2) Some distribution lists are only available to authenticated users
#
# Logging is sent to syslogd.
#
# How it works: each time a Postfix SMTP server process is started
# it connects to the policy service socket, and Postfix runs one
# instance of this PERL script.  By default, a Postfix SMTP server
# process terminates after 100 seconds of idle time, or after serving
# 100 clients. Thus, the cost of starting this PERL script is smoothed
# out over time.
#
# To run this from /etc/postfix/master.cf:
#
#    policy  unix  -       n       n       -       -       spawn
#      user=kolab-n argv=/usr/bin/perl /usr/libexec/postfix/kolab_smtpd_policy.pl
#
# To use this from Postfix SMTPD, use in /etc/postfix/main.cf:
#
#    smtpd_recipient_restrictions =
#	...
#	reject_unauth_destination
#	check_policy_service unix:private/policy
#	...
#
# NOTE: specify check_policy_service AFTER reject_unauth_destination
# or else your system can become an open relay.
#
# To test this script by hand, execute:
#
#    % perl kolab_smtpd_policy.pl
#
# Each query is a bunch of attributes. Order does not matter, and
# the demo script uses only a few of all the attributes shown below:
#
#    request=smtpd_access_policy
#    protocol_state=RCPT
#    protocol_name=SMTP
#    helo_name=some.domain.tld
#    queue_id=8045F2AB23
#    sender=foo@bar.tld
#    recipient=bar@foo.tld
#    client_address=1.2.3.4
#    client_name=another.domain.tld
#    instance=123.456.7
#    sasl_method=plain
#    sasl_username=you
#    sasl_sender=
#    size=12345
#    [empty line]
#
# The policy server script will answer in the same style, with an
# attribute list followed by a empty line:
#
#    action=dunno
#    [empty line]
#

#
# Syslogging options for verbose mode and for fatal errors.
# NOTE: comment out the $syslog_socktype line if syslogging does not
# work on your system.
#
$syslog_socktype = 'unix'; # inet, unix, stream, console
$syslog_facility="mail";
$syslog_options="pid";
$syslog_priority="info";

$ldap_max_tries = 5;

sub mylog {
  my $prio = shift;
  my $fmt = shift;

  my $text = sprintf( $fmt, @_ );

  #Kolab::log( 'P', $text );
  syslog $prio, $text;
}

sub contains {
  my $needle = lc(shift);
  my $haystack = shift;
  map { return 1 if $needle eq lc($_) } @$haystack;
  return 0;
}

sub ldap_connect {
    my $ldapuri = URI->new($conf_ldapuri) || fatal_exit("error: could not parse given uri $conf_ldapuri");
    $ldap = Net::LDAP->new($conf_ldapuri) || fatal_exit("could not connect to ldap server $conf_ldapuri: $@");
    if ($ldap) {
	if( $conf_binddn ) {
	    $ldap->bind( $conf_binddn, password => $conf_bindpw ) || fatal_exit( "could not bind as $conf_binddn: $@" );
	} else {
	    $ldap->bind || fatal_exit("could not bind: $@");
	}
    } else {
	fatal_exit( "Could not contact LDAP server" );
    }
}

#
# SMTPD access policy routine. The result is an action just like
# it would be specified on the right-hand side of a Postfix access
# table.  Request attributes are available via the %attr hash.
#
sub smtpd_access_policy {

  # Get relevant attributes
  my $sender      = $attr{'sender'};
  my $recip       = $attr{'recipient'};
  my $username    = $attr{'sasl_username'};
  my $client_addr = $attr{'client_address'};

  mylog($syslog_priority, "Checking sender=\"$sender\", recipient=\"$recip\", username=\"$username\", domains=".join(',',@conf_domain)." permithosts=".join(',',@conf_permithosts).", conf_allowunauth=$conf_allowunauth") if $verbose;

  #### This should probably be simplifed to
  #### reject sender <anything>@domain.tld if the user is
  #### not authenticated

 CHECKPERMITHOSTS:
  # First check if the sender is a privileged kolabhost
  # Kolab hosts use un-authenticated smtp currently
  if( !$username ) {
      for my $host (@conf_permithosts) {
	  unless ($h = gethost($host)) {
	      mylog($syslog_priority,"No such host $host\n");
	      next;
	  }
	  for my $addr ( @{$h->addr_list} ) {
	      return "DUNNO" if inet_ntoa($addr) eq $client_addr;
	  }
      }
  }

  # Translate uid to mail:
  my $tries = 0;
 LOOKUPUID:
  my $mesg = $ldap->search( base=> $conf_basedn,
			    scope=> 'sub',
			    filter=> "(&(objectClass=kolabinetorgperson)(|(mail=$username)(uid=$username)))");
  if( !$mesg->code && $mesg->count() > 0 ) {
      mylog($syslog_priority, "LDAP search returned ".$mesg->count()." objects") if $verbose;
      my $ldapobject = $mesg->entry(0);
      $username = lc($ldapobject->get_value('mail'));
      mylog($syslog_priority, "Translated username to $username") if $verbose;
  } elsif( $mesg->code && $mesg->code != LDAP_NO_SUCH_OBJECT ) {
      if( $tries++ <= $ldap_max_tries ) {
	  mylog($syslog_priority, "LDAP Connection error during LOOKUPUID: ".$mesg->error.". trying to reconnect" );
	  ldap_connect;
	  goto LOOKUPUID;
      } else {
	  mylog($syslog_priority, "LDAP Connection error during LOOKUPUID: ".$mesg->error.", giving up!" );
	  return "DEFER_IF_PERMIT LDAP Error during LOOKUPUID:: ".$mesg->error;
      }
  }
  # Check for allowed sender
  $tries = 0;
 CHECKSENDER:

  $mesg = $ldap->search( base=> $conf_basedn,
			    scope=> 'sub', 
			    filter=> "(&(objectClass=kolabinetorgperson)(|(mail=$sender)(alias=$sender)))");
  if( !$mesg->code ) {
    mylog($syslog_priority, "LDAP search returned ".$mesg->count()." objects") if $verbose;
    foreach $ldapobject ($mesg->entries) {
      mylog($syslog_priority, "Got object ".$ldapobject->get_value('uid') ) if $verbose;
      mylog($syslog_priority, "Got delegates ".join(", ", @{$ldapobject->get_value('kolabdelegate', asref => 1 )})) if $verbose;
      if( $username && ( lc($username) eq lc($ldapobject->get_value('uid'))  ||
                         lc($username) eq lc($ldapobject->get_value('mail')) ||
	                 contains( $username, $ldapobject->get_value('kolabdelegate', asref => 1 )))  ) {
	# All OK, user is sending as herself or as kolabdelegate
	mylog($syslog_priority, "$username using valid from address $sender") if $verbose;	
	goto CHECKDISTLIST;
      }
    }
  } else {
      # LDAP error?
      if( $mesg->code != LDAP_NO_SUCH_OBJECT && $tries++ <= $ldap_max_tries ) {
	  mylog($syslog_priority, "LDAP Connection error during CHECKSENDER: ".$mesg->error.", trying to reconnect" );
	  ldap_connect;
	  goto CHECKSENDER;
      } else {
	  mylog($syslog_priority, "Query returned error during CHECKSENDER: ".$mesg->error ) if $verbose;	
	  return "DEFER_IF_PERMIT Temporary LDAP error during CHECKSENDER: ".$mesg->error;
      }
  }
  if( $conf_allowunauth && !$username ) {
    # Dont reject mail from other domains
    $sender =~ /(.*)@(.*)/;
    my $domain = $2;
    mylog($syslog_priority, "sender=$sender, domain=$domain") if $verbose;
    if( !contains( $domain, \@conf_domain ) ) {
      # Ok
      mylog($syslog_priority, "sending from other domains OK") if $verbose;
      goto CHECKDISTLIST;
    }
  }
  # UPS, fake sender
  mylog($syslog_priority, "Attempt to fake address $sender") if $verbose;	
  return "REJECT Invalid sender";
  
  # Check for valid access to restricted distribution lists
  $tries = 0;
 CHECKDISTLIST:
  if( !$username or $username eq '' ) {
    $recip =~ /(.*)@(.*)/;
    my $cn = $1;
    my $domain = $2;
    if( contains($domain,\@conf_domain ) ) {
      $mesg = $ldap->search( base=> "cn=internal,".$conf_basedn,
                             scope=> 'one', filter=> "(&(cn=$cn)(objectClass=kolabgroupofnames))");
      if( !$mesg->code && $mesg->count() > 0 ) {
	# Ups, recipient is a restricted list, reject
	mylog( $syslog_priority, "Attempt from $sender to access restricted list $recip" ) if $verbose;	
	return "REJECT Access denied";
      } elsif( $mesg->code && $mesg->code != LDAP_NO_SUCH_OBJECT && $tries++ <= $ldap_max_tries ) {
	  mylog($syslog_priority, "LDAP Connection error during CHECKDISTLIST: ".$mesg->error.", trying to reconnect" );
	  ldap_connect;
	  goto CHECKDISTLIST;
      } elsif( $mesg->code ) {
	mylog( $syslog_priority, "LDAP Error during CHECKDISTLIST: ".$mesg->error ) if $verbose;
	# Just fall through and accept the message in case there was an LDAP problem.
      }
    }
  }

  # The result can be any action that is allowed in a Postfix access(5) map.
  #
  # To label mail, return ``PREPEND'' headername: headertext
  #
  # In case of success, return ``DUNNO'' instead of ``OK'' so that the
  # check_policy_service restriction can be followed by other restrictions.
  #
  # In case of failure, specify ``DEFER_IF_PERMIT optional text...''
  # so that mail can still be blocked by other access restrictions.

  mylog($syslog_priority, "sender $sender, recipient $recip seems ok") if $verbose;

  return "DUNNO";
}

#
# Log an error and abort.
#
sub fatal_exit {
    my($first) = shift(@_);
    mylog("err", "fatal: $first", @_);
    print STDOUT "action=DEFER_IF_PERMIT $first\n\n";
    exit 1;
}

#
# Signal 11 means that we have crashed perl
#
sub sigsegv_handler {
    fatal_exit "Caught signal 11;";
}

$SIG{'SEGV'} = 'sigsegv_handler';

#
# This process runs as a daemon, so it can't log to a terminal. Use
# syslog so that people can actually see our messages.
#
setlogsock $syslog_socktype;
openlog $0, $syslog_options, $syslog_facility;

#
# Read options from config-file
#
$conf_allowunauth = 0;
%conf = readConfig( %conf, "@l_prefix@/etc/kolab/kolab_smtpdpolicy.conf" );
$conf_ldapuri = $conf{'ldap_uri'};
$conf_basedn  = $conf{'basedn'};
$conf_binddn  = $conf{'binddn'};
$conf_bindpw  = $conf{'bindpw'};
$conf_domain  = $conf{'domain'};
$conf_allowunauth = 1 if( $conf{'allow_unauth'} );
@conf_permithosts = split /\s*,\s*/, $conf{'permithosts'};

#
# Allow user to override on commandline
#
while ($option = shift(@ARGV)) {
  if ($option eq "-v") {
    $verbose = 1;
  } elsif ($option eq '-ldap') {
    $conf_ldapuri = shift(@ARGV);
  } elsif ($option eq '-basedn') {
    $conf_basedn = shift(@ARGV);
  } elsif ($option eq '-binddn' ) {
    $conf_binddn = shift(@ARGV);
  } elsif ($option eq '-bindpw' ) {
    $conf_bindpw = shift(@ARGV);
  } elsif ($option eq '-domain') {
    push @conf_domain, shift(@ARGV);
  } elsif ($option eq '-allow-unauth') {
    $conf_allowunauth = 1;
  } elsif ($option eq '-permithosts') {
    @conf_permithosts = ();
    for my $h (split /\s*,\s*/, shift(@ARGV)) {
      push @conf_permithosts, $h;
    }
  } else {
    mylog( $syslog_priority, "Invalid option: %s. Usage: %s [-v] -ldap <uri> -basedn <base_dn> [-binddn <bind_dn> -bindpw <bind_pw>] [-domain <domain>] [-permithosts <host,host,...>]",
	   $option, $0);
    exit 1;
  }
}

#
# Unbuffer standard output.
#
select((select(STDOUT), $| = 1)[0]);

if( $verbose ) {
  mylog( $syslog_priority, "ldap=$conf_ldapuri, basedn=$conf_basedn, binddn=$conf_binddn");
}

ldap_connect;

#
# Receive a bunch of attributes, evaluate the policy, send the result.
#
while (<STDIN>) {
    if (/([^=]+)=(.*)\n/) {
	$attr{substr($1, 0, 512)} = substr($2, 0, 512);
    } elsif ($_ eq "\n") {
	if ($verbose) {
	    for (keys %attr) {
		mylog( $syslog_priority, "Attribute: %s=%s", $_, $attr{$_});
	    }
	}
	fatal_exit "unrecognized request type: '%s'", $attr{'request'}
	    unless $attr{'request'} eq "smtpd_access_policy";
	$action = smtpd_access_policy();
	mylog( $syslog_priority, "Action: %s", $action) if $verbose;
	print STDOUT "action=$action\n\n";
	%attr = ();
    } else {
	chop;
	mylog( $syslog_priority, "warning: ignoring garbage: %.100s", $_);
    }
}
