#!/usr/bin/perl -wT

#*****************************************************************************
#*                                                                           *
#* AUTHOR      : Chris Pile - cpile@snoogans.co.uk
#*                                                                           *
#* DESCRIPTION : This is an example Perl script that uses the new
#*                auth/check method in 1.4.2.
#*
#*               See "perldoc xdb_auth_cpile.pl" for more info.
#*                                                                           *
#*****************************************************************************
#*                                                                           *
#* $Source: /usr/local/cvsroot/jabber/xdb_auth_cpile/xdb_auth_cpile.pl,v $
#* $State: Exp $
#* Tag $Name:  $
#*                                                                           *
#*****************************************************************************
#*                                                                           *
#* $Log: xdb_auth_cpile.pl,v $
#* Revision 1.7  2002/07/11 16:08:24  chris
#* - Added notes for mysql module
#* - Added catchall code if xdb packet isn't a "get", "action" or a "set"
#*
#* Revision 1.6  2002/05/10 14:41:34  chris
#* - forced commit to bump up version number ;)
#*
#* Revision 1.5  2002/05/10 14:14:23  chris
#* - BUG fix. Script used to crash when user tried to change their password, added routine to catch 'set' types with no action.
#* - check if 'action' attr. is defined
#* - password changes now theoretically possible (depends on auth. method)
#*
#* Revision 1.4  2002/05/08 15:22:22  chris
#* - Simplified insertTag command
#* - Need experimental Jabber-Connection-0.04 to avoid a memory leak
#*
#* Revision 1.3  2002/05/01 11:04:51  chris
#* - remove some tags from return node
#* - changed some debug output
#* - updated POD
#*
#* Revision 1.2  2002/04/24 11:50:04  chris
#* - updated POD
#*
#* Revision 1.1  2002/04/24 11:32:26  chris
#* - Initial add to CVS
#* - This version of xdb_auth_cpile.pl makes it very easy to extend the authentication method
#* - mv xdb_auth_cpile.pm.XXX xdb_auth_cpile.pm
#* - update "use lib" line in xdb_auth_cpile.pl
#*
#* Revision 1.2  2002/04/24 08:38:53  chris
#* - Improved config file path handling
#*
#* Revision 1.1.1.1  2002/04/23 14:24:42  chris
#* - initial import into CVS
#*
#*****************************************************************************

package xdb_auth_cpile;

####

use strict;
use lib qw(/usr/local/jabber/xdb_auth_cpile);
# There is a memory leak in Jabber::Connection 0.03
use Jabber::Connection 0.04;
use Jabber::NodeFactory;
use Jabber::NS qw(:all);
use XML::Simple;
use POSIX qw(strftime);
use xdb_auth_cpile;

####

# Clean path whenever you use taint checks (Make %ENV safer)
$ENV{'PATH'} = "";
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};

# Set up vars
my $file = $ARGV[0];
my $configdir = ".";
my $config;

####

# Check user input
if(defined $file)
{
  # Untaint by stripping any bad characters, see "perlsec" man page.
  $file =~ /^([-\w.\/]+)$/ or die "Bad characters found\n\n";
  $file = $1;
  $config = XMLin("$file");
}
else
{
  $config = XMLin("$configdir/xdb_auth_cpile.xml");
}

# Write pid to pidfile
open(PIDFILE, ">$config->{script}->{pidfile}");
print PIDFILE $$;
close(PIDFILE);

# Open a connection to the server
my $c = new Jabber::Connection(
  server => $config->{connection}->{ip}.":".$config->{connection}->{port},
  localname => $config->{connection}->{id},
  ns => 'jabber:component:accept'
  );

debug("connecting");
unless($c->connect()) {die "oops: ".$c->lastError;}

# Handle kill signals
$SIG{HUP} = $SIG{KILL} = $SIG{TERM} = $SIG{INT} = \&cleanup;

debug("registering xdb");
$c->register_handler('xdb', \&xdb);

# Authenticate against the server
debug("auth");
$c->auth($config->{connection}->{secret});

# Start processing packets
debug("start");
$c->start;

####
# Functions below
####

sub xdb
{
  my $node = shift;
  debug("[xdb]");
  return unless($node->attr('ns') eq NS_AUTH);
  debug("--> auth request");

  my $user = getUserID($node->attr('to'));
  $node = toFrom($node);
  $node->attr('from', $config->{connection}->{id});

  # For 'get's, we return an empty namespace, flagging that they exist but a check action must be used
  if($node->attr('type') eq "get")
  {
    debug(" --> get");
    $node->attr('type', IQ_RESULT);

    $node->insertTag('query', NS_AUTH);
  }

  # check there is an action attr, otherwise we may get a perl warning
  elsif( defined($node->attr('action')) )
  {
    # If it's a set with a check action, this is where we check the authentication
    if($node->attr('type') eq "set" && $node->attr('action') eq "check")
    {
      debug(" --> set/check");
      my $pass = $node->getTag('password')->data;

      debug("  checking authentication for user: ".$user);

      # This is the bit you change when extending the authentication
      my $res = auth_check($user, $pass);
      if($res)
      {
        debug("  ".$res);
        $node->attr('type', IQ_ERROR);
      }
      else
      {
        $node->attr('type', IQ_RESULT);
      }

      # remove the action attr
      $node->attr('action', '');

      # remove the password tag
      $node->getTag('password')->hide;
    }
  }

  # If it's just a 'set', then user is trying to change their password
  elsif($node->attr('type') eq "set")
  {
    debug(" --> set");
    my $pass = $node->getTag('password')->data;

    # Add your password change code here
    my $res = auth_change($user, $pass);
    if($res)
    {
      debug("  ".$res);
      $node->attr('type', IQ_ERROR);
    }
    else
    {
      $node->attr('type', IQ_RESULT);
    }
  }

  # Catchall
  else
  {
    debug("  Catchall");
    $node->attr('type', IQ_ERROR);
  }

  $c->send($node);
  return(r_HANDLED);
}

# Disconnect from the Jabber server, remove PID file
sub cleanup
{
  debug("Cleaning up");
  $c->disconnect;
  unlink($config->{script}->{pidfile});
  exit;
}

# Swap around the to/from attributes
sub toFrom
{
  my $node = shift;
  my $to = $node->attr('to');
  $node->attr('to', $node->attr('from'));
  $node->attr('from', $to);
  return($node);
}

# Just return the userid from the full JID
sub getUserID
{
  my $user = shift;
  $user =~ s|@.*$||;
  return($user);
}

# Write to log file
sub debug
{
  return unless($config->{script}->{debug});

  my $date = POSIX::strftime("%Y%m%d-%H%M%S", localtime);

  open(LOGFILE, ">>$config->{script}->{logfile}") or die("Could not open $config->{script}->{logfile}: $!\n");
  print LOGFILE "$date - debug: ", @_, "\n";
  close(LOGFILE);
}

__END__

=head1 NAME

xdb_auth_cpile.pl - Uses the XDB "check" and Authentication Modules in Jabber-1.4.2 to extend authentication.

=head1 SYNOPSIS

B<xdb_auth_cpile.pl> B<E<lt>config_fileE<gt>>

=head1 DESCRIPTION

Overview at:
http://www.snoogans.co.uk/jabber/index.htm#xdb_auth_cpile

Please read "xdb_auth_cpile.README" for more information.

I have included a few examples of how to extend the authentication method.  You will need to rename the file you wish to use:
E.g. 
rename xdb_auth_cpile.pm.mysql to xdb_auth_cpile.pm
OR
rename xdb_auth_cpile.pm.pam to xdb_auth_cpile.pm
OR
rename xdb_auth_cpile.pm.pop3 to xdb_auth_cpile.pm
OR
rename xdb_auth_cpile.pm.radius to xdb_auth_cpile.pm 
OR 
rename xdb_auth_cpile.pm.smb to xdb_auth_cpile.pm 
OR 
rename xdb_auth_cpile.pm.test to xdb_auth_cpile.pm 

You will probably need to edit the "use lib qw(/usr/local/jabber/xdb_auth_cpile);" line to reflect the location of your xdb_auth_cpile.pm file.

=head1 BUGS

No known bugs.

=head1 SEE ALSO

http://www.snoogans.co.uk/jabber/index.htm#xdb_auth_cpile
http://www.snoogans.co.uk/jabber/files/xdb_auth_cpile.tar.gz
http://jabberd.jabberstudio.org/1.4/142changelog.html

L<perlsec>, L<perlpod>, L<perlsyn>, L<strftime>

=head1 AUTHOR

  Chris Pile
  <cpile@snoogans.co.uk>
  http://www.snoogans.co.uk/

  $Id: xdb_auth_cpile.pl,v 1.7 2002/07/11 16:08:24 chris Exp $

=cut