#!/usr/bin/perl -w

#  Sample External Authenticaton program for CommuniGate Pro 
#  that employs LDAP "bind", supports the account creation
#  via NEW command and supports SASL authentication. For SASL 
#  to work the script must be able to retrieve account password
#  in plain text from the LDAP server.
#
#  See for more info:
#  <http://www.stalker.com/CommuniGatePro/Security.html#External>


#  You may need to install the following modules:
#  ASN1 from <http://www.cpan.org/modules/by-module/Convert/>
#  LDAP from <http://www.cpan.org/modules/by-module/Net/>
use Net::LDAP;

#  Take the CLI.pm module from <http://www.stalker.com/CGPerl/>
use CLI;

#
# You should redefine these values
#

my @ldap_servers=(  # you can specify multiple LDAP servers here
{ address=>'127.0.0.1',     # the address or IP of LDAP server
  port=>389,                # LDAP port, 389 by default
  timeout=>5,               # timeout in seconds, 20 by default
  adminDN=>'uid=admin,cn=host',  # the DN for admin bind
  adminPassword=>'pass',
  searchBase=>'cn=<domain>',  # search base for NEW and SASL commands
  searchFilter=>'(&(uid=<user>)(objectclass=*))',
  bindDN=>'uid=<user>,cn=<domain>', # the account DN for direct bind for VRFY command
},
{ address=>'127.0.0.2',
  adminDN=>'postmaster',
  adminPassword=>'pass',
  searchBase=>'cn=<domain>',
  searchFilter=>'(&(uid=<user>)(objectclass=*))',
  bindDN=>'uid=<user>,cn=<domain>',
},
);


my $CGServerAddress =  '127.0.0.1';   # You should redefine these values
my $CLILogin = 'postmaster';
my $CLIPassword = 'pass';
#
# END of user customiseable parameters 
#


$| = 1;     #force STDOUT autoflush after each write

print "* authLDAPNew.pl started\n";

my ($ldapServerID,$ldapServerTried)=(0,0);
   
while(<STDIN>) {
  chomp;    # remove \n from the end of line
  my ($prefix,$method,@eargs) = split(/ /);

  if($method eq 'VRFY') {
    unless($prefix && $method && $eargs[0] && $eargs[1]) {  
      print "$prefix ERROR Expected: nnn VRFY (mode) user\@domain password\n";    
    } else {
      if($eargs[0] =~ /^\(.*\)$/) {
        shift @eargs;  
      }
      my $errorMsg=vrfy_command($prefix,$eargs[0],$eargs[1]);   
      if(defined $errorMsg) {
        print "$prefix ERROR $errorMsg\n";
      }
    }    
  } elsif($method =~ /^SASL/) {
    unless($prefix && $method && $eargs[0] && $eargs[1]) {  
      print "$prefix ERROR Expected: nnn SASL(method) (mode) user\@domain key\n";    
    } else {
      if($eargs[0] =~ /^\(.*\)$/) {
        shift @eargs;  
      }
      my $errorMsg=sasl_command($prefix,$eargs[0]);   
      if(defined $errorMsg) {
        print "$prefix ERROR $errorMsg\n";
      }
    }
  } elsif($method =~ /^READPLAIN/) {
    unless($prefix && $method && $eargs[0]) {  
      print "$prefix ERROR Expected: nnn READPLAIN user\@domain\n";    
    } else {
      my $errorMsg=sasl_command($prefix,$eargs[0]); #same for sasl and readplain  
      if(defined $errorMsg) {
        print "$prefix FAILURE $errorMsg\n";
      }
    }    
        
  } elsif($method eq 'NEW') {
    unless($prefix && $method && $eargs[0]) {  
      print "$prefix ERROR Expected: nnn NEW user\@domain\n";    
    } else {
      my $errorMsg=new_command($prefix,$eargs[0]);
      if(defined $errorMsg) {
        print "$prefix ERROR $errorMsg\n";
      }     
    }
  } elsif($method eq 'INTF') {
    print "$prefix INTF 7\n";

  } elsif($method eq 'QUIT') {
    print "$prefix OK\n";
    last;
  } else {
    print "$prefix ERROR Only INTF, VRFY, SASL, READPLAIN and NEW commands supported\n";    
  }   
}
print "* authLDAPNew.pl done\n";
exit(0);


sub tryConnectServer {
  my $theServer=$ldap_servers[$ldapServerID];
  print "* trying to connect to $theServer->{address}\n";
  my $ldap = Net::LDAP->new($theServer->{address},port=>($theServer->{port} || 389),timeout=>($theServer->{timeout} || 20) )
   || return undef;
  return $ldap;
}

sub tryConnect {
  my $nServers=scalar(@ldap_servers);
  for(my $nTried=0;$nTried<$nServers;$nTried++) {
    if($ldapServerID>=$nServers) { $ldapServerID=0;}
    my $ldap=tryConnectServer();
    return $ldap if($ldap);
    ++$ldapServerID;
  }  
  return undef;
}

sub vrfy_command {
  my ($prefix,$user,$password)=@_;

  my ($name,$domain)=("",""); 
  if($user =~ /(.+)\@(.+)/) {  
    $name=$1;
    $domain=$2;
  } else {
    return "Full account name with \@ and domain part expected";
  }

  my $ldap = tryConnect();
  unless($ldap) {
    return "Failed to connect to all LDAP servers";
  }
  my $bindDN=$ldap_servers[$ldapServerID]->{bindDN};
  $bindDN=~s/<user>/$name/;
  $bindDN=~s/<domain>/$domain/;
  $password=decodeString($password);
  print "* binding $bindDN with password=$password\n";
  my $result=$ldap->bind($bindDN,password=>$password)
    || return "Can't bind: ".$result->error;

  $ldap->unbind();                        # unbind & disconnect
  #$ldap->disconnect();
  
  $result->code && return $result->error; # return error message if failed

  print "$prefix OK\n";
  return undef;                           # return "undef" on success
}




sub new_command {
  my ($prefix,$user)=@_;

  my ($name,$domain)=("",""); 
  if($user =~ /(.+)\@(.+)/) {  
    $name=$1;
    $domain=$2;
  } else {
    return "Full account name with \@ and domain part expected";
  }
  my $ldap = tryConnect();
  unless($ldap) {
    return "Failed to connect to all LDAP servers";
  }
  
  my $adminDN=$ldap_servers[$ldapServerID]->{adminDN};
  my $adminPassword=$ldap_servers[$ldapServerID]->{adminPassword};
 
  my $result=$ldap->bind($adminDN,password=>$adminPassword)
    || return "Can't bind as admin: ".$result->error;
  $result->code && return "Can't bind as admin: ".$result->error;

  my $searchBase=$ldap_servers[$ldapServerID]->{searchBase};
  $searchBase=~s/<user>/$name/;
  $searchBase=~s/<domain>/$domain/;
  my $searchFilter=$ldap_servers[$ldapServerID]->{searchFilter};
  $searchFilter=~s/<user>/$name/;
  $searchFilter=~s/<domain>/$domain/;
  print "* searching $searchBase for $searchFilter\n";
 
  my $mesg = $ldap->search (  # perform a search
               base   => $searchBase,
               filter => $searchFilter
             );


  $ldap->unbind();                        # unbind & disconnect

  unless(defined $mesg) {
    return "LDAP search failed";   
  } 
  if($mesg->all_entries() eq 0) {
    return "LDAP: nothing found for $searchFilter";
  }
  my ($realName,$password);  
  foreach $entry ($mesg->all_entries) {
    my $ref1=@$entry{'asn'};
    my $attrs=@$ref1{'attributes'};
    foreach $atrRef (@$attrs) {
      my $type=@$atrRef{'type'};
      my $vals=@$atrRef{'vals'};
      $realName=@$vals[0] if($type eq 'cn');
      $password=@$vals[0] if($type eq 'userPassword');
    }
    last; # we need only 1 entry
  }
  my %userData;
  $userData{'RealName'}=$realName if(defined $realName); 
  $userData{'Password'}=$password if(defined $password); 

  my $cli = new CGP::CLI( { PeerAddr => $CGServerAddress,
                          PeerPort => 106,
                          login    => $CLILogin,
                          password => $CLIPassword
                        } )  
   || return "Can't login to CGPro via CLI: ".$CGP::ERR_STRING;

  $cli->CreateAccount(accountName=>"$user",settings=>\%userData)
    || return "Can't create account via CLI:".$cli->getErrMessage;
  $cli->Logout();
  print "$prefix OK\n";
  return undef;
}

sub sasl_command {
  my ($prefix,$user)=@_;

  my ($name,$domain)=("",""); 
  if($user =~ /(.+)\@(.+)/) {  
    $name=$1;
    $domain=$2;
  } else {
    return "Full account name with \@ and domain part expected";
  }
  my $ldap = tryConnect();
  unless($ldap) {
    return "Failed to connect to all LDAP servers";
  }
  
  my $adminDN=$ldap_servers[$ldapServerID]->{adminDN};
  my $adminPassword=$ldap_servers[$ldapServerID]->{adminPassword};
 
  my $result=$ldap->bind($adminDN,password=>$adminPassword)
    || return "Can't bind as admin: ".$result->error;
  $result->code && return "Can't bind as admin: ".$result->error;

  my $searchBase=$ldap_servers[$ldapServerID]->{searchBase};
  $searchBase=~s/<user>/$name/;
  $searchBase=~s/<domain>/$domain/;
  my $searchFilter=$ldap_servers[$ldapServerID]->{searchFilter};
  $searchFilter=~s/<user>/$name/;
  $searchFilter=~s/<domain>/$domain/;
  print "* searching $searchBase for $searchFilter\n";
 
  my $mesg = $ldap->search (  # perform a search
               base   => $searchBase,
               filter => $searchFilter
             );


  $ldap->unbind();                        # unbind & disconnect

  unless(defined $mesg) {
    return "LDAP search failed";   
  } 
  if($mesg->all_entries() eq 0) {
    return "LDAP: nothing found for $searchFilter";
  }
  my ($realName,$password);  
  foreach $entry ($mesg->all_entries) {
    my $ref1=@$entry{'asn'};
    my $attrs=@$ref1{'attributes'};
    foreach $atrRef (@$attrs) {
      my $type=@$atrRef{'type'};
      my $vals=@$atrRef{'vals'};
      $realName=@$vals[0] if($type eq 'cn');
      $password=@$vals[0] if($type eq 'userPassword');
    }
    last; # we need only 1 entry
  }
  unless($password) {
    return "no plain text password was found";
  }
  print "$prefix PLAIN ".encodeString($password)."\n";
  
  return undef;
}

sub encodeString {
  my ($data)=@_;
  if($data =~ /\W/) {
    $data =~ s/\\/\\\\/g;
    $data =~ s/\"/\\\"/g;
    $data =~ s/([\x00-\x1F\x7F])/'\\'.('0'x(3-length(ord($1)))).ord($1)/ge;
  }
  return '"' . $data . '"';
}

sub decodeString {
  my ($data)=@_;
  my $isQuoted=0;

  unless($data=~/^\"(.*)\"$/) { # check "'s
    return $data;
  }
  $data=$1;

  my $result="";
  my $span=0;
  my $len=length($data);

  while($span < $len) {
    my $ch=substr($data,$span,1);
    if($ch eq '\\') {
      $span++;
      if(substr($data,$span,3) =~ /^(\d\d\d)/) { 
        $ch=chr($1); $span+=3;
      }else {
        $ch=substr($data,$span,1);
      }  
    }
    $result .= $ch;
    ++$span;
  }
  return $result;
}


__END__