[PATCH] refactored Qpsmtpd::Auth::SASL

refactored Qpsmtpd::Auth::SASL

unit tests for new methods are in t/auth.t

added PLAIN and LOGIN tests in auth_flat_file

Most tests are disabled unless an interactive terminal is detected and $ENV{QPSMTPD_DEVELOPER} is set.
---
lib/Qpsmtpd/Auth.pm         |  165 ++++++++++++++++++++++++++-----------------
plugins/auth/auth_flat_file |   38 +++++-----
t/auth.t                    |  143 +++++++++++++++++++++++++++++++++++++
3 files changed, 266 insertions(+), 80 deletions(-)
create mode 100644 t/auth.t

diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm
index 422c3f4..af53c48 100644
--- a/lib/Qpsmtpd/Auth.pm
+++ b/lib/Qpsmtpd/Auth.pm
@@ -1,11 +1,13 @@
+package Qpsmtpd::Auth;
# See the documentation in 'perldoc README.authentication' 

-package Qpsmtpd::Auth;
-use Qpsmtpd::Constants;
+use strict;
+use warnings;
+
use MIME::Base64;
+use Qpsmtpd::Constants;

-sub e64
-{
+sub e64 {
  my ($arg) = @_;
  my $res = encode_base64($arg);
  chomp($res);
@@ -18,61 +20,17 @@ sub SASL {
    my ( $session, $mechanism, $prekey ) = @_;
    my ( $user, $passClear, $passHash, $ticket, $loginas );

-    if ( $mechanism eq "plain" ) {
-        if (!$prekey) {
-          $session->respond( 334, " " );
-          $prekey= <STDIN>;
-        }
-        ( $loginas, $user, $passClear ) = split /\x0/,
-          decode_base64($prekey);
-          
-        # Authorization ID must not be different from
-        # Authentication ID
-        if ( $loginas ne '' && $loginas ne $user ) {
-          $session->respond(535, "Authentication invalid");
-          return DECLINED;
-        }
+    if ( $mechanism eq 'plain' ) {
+        ($loginas, $user, $passClear) = get_auth_details_plain($session,$prekey);
+        return DECLINED if ! $user || ! $passClear;
    }
-    elsif ($mechanism eq "login") {
-
-        if ( $prekey ) {
-          $user = decode_base64($prekey);
-        }
-        else {
-          $session->respond(334, e64("Username:"));
-          $user = decode_base64(<STDIN>);
-          if ($user eq '*') {
-            $session->respond(501, "Authentication canceled");
-            return DECLINED;
-          }
-        }
-    
-        $session->respond(334, e64("Password:"));
-        $passClear = <STDIN>;
-        $passClear = decode_base64($passClear);
-        if ($passClear eq '*') {
-          $session->respond(501, "Authentication canceled");
-          return DECLINED;
-        }
+    elsif ( $mechanism eq 'login' ) {
+        ($user, $passClear) = get_auth_details_login($session,$prekey);
+        return DECLINED if ! $user || ! $passClear;
    }
-    elsif ( $mechanism eq "cram-md5" ) {
-
-        # rand() is not cryptographic, but we only need to generate a globally
-        # unique number.  The rand() is there in case the user logs in more than
-        # once in the same second, of if the clock is skewed.
-        $ticket = sprintf( '<%x.%x@%s>',
-            rand(1000000), time(), $session->config("me") );
-
-        # We send the ticket encoded in Base64
-        $session->respond( 334, encode_base64( $ticket, "" ) );
-        my $line = <STDIN>;
-
-        if ( $line eq '*' ) {
-            $session->respond( 501, "Authentication canceled" );
-            return DECLINED;
-        }
-
-        ( $user, $passHash ) = split( ' ', decode_base64($line) );
+    elsif ( $mechanism eq 'cram-md5' ) {
+        ( $ticket, $user, $passHash ) = get_auth_details_cram_md5($session);
+        return DECLINED if ! $user || ! $passHash;
    }
    else {
        #this error is now caught in SMTP.pm's sub auth
@@ -80,12 +38,6 @@ sub SASL {
        return DECLINED;
    }

-    # Make sure that we have enough information to proceed
-    unless ( $user && ($passClear || $passHash) ) {
-      $session->respond(504, "Invalid authentication string");
-      return DECLINED;
-    }
-
    # try running the specific hooks first
    my ( $rc, $msg ) =
      $session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear,
@@ -120,6 +72,93 @@ sub SASL {
    }
}

+sub get_auth_details_plain {
+    my ( $session, $prekey ) = @_;
+
+    if ( ! $prekey) {
+        $session->respond( 334, ' ' );
+        $prekey= <STDIN>;
+    }
+
+    my ( $loginas, $user, $passClear ) = split /\x0/, decode_base64($prekey);
+
+    if ( ! $user ) {
+        if ( $loginas ) {
+            $session->respond(535, "Authentication invalid ($loginas)");
+        }
+        else {
+            $session->respond(535, "Authentication invalid");
+        }
+        return;
+    };
+
+    # Authorization ID must not be different from Authentication ID
+    if ( $loginas ne '' && $loginas ne $user ) {
+        $session->respond(535, "Authentication invalid for $user");
+        return;
+    }
+
+    return ($loginas, $user, $passClear);
+};
+
+sub get_auth_details_login {
+    my ( $session, $prekey ) = @_;
+
+    my $user;
+
+    if ( $prekey ) {
+        $user = decode_base64($prekey);
+    }
+    else {
+        $user = get_base64_response($session,'Username:') or return;
+    }
+
+    my $passClear = get_base64_response($session,'Password:') or return;
+
+    return ($user, $passClear);
+};
+
+sub get_auth_details_cram_md5 {
+    my ( $session, $ticket ) = @_;
+
+    if ( ! $ticket ) {  # ticket is only passed in during testing
+    # rand() is not cryptographic, but we only need to generate a globally
+    # unique number.  The rand() is there in case the user logs in more than
+    # once in the same second, or if the clock is skewed.
+        $ticket = sprintf( '<%x.%x@%s>',
+            rand(1000000), time(), $session->config('me') );
+    };
+
+    # send the base64 encoded ticket
+    $session->respond( 334, encode_base64( $ticket, '' ) );
+    my $line = <STDIN>;
+
+    if ( $line eq '*' ) {
+        $session->respond( 501, "Authentication canceled" );
+        return;
+    };
+
+    my ( $user, $passHash ) = split( ' ', decode_base64($line) );
+    unless ( $user && $passHash ) {
+        $session->respond(504, "Invalid authentication string");
+        return;
+    }
+
+    return ($ticket, $user, $passHash);
+};
+
+sub get_base64_response {
+    my ($session, $question) = @_;
+
+    $session->respond(334, e64($question));
+    my $answer = decode_base64( <STDIN> );
+    if ($answer eq '*') {
+        $session->respond(501, "Authentication canceled");
+        return;
+    }
+    return $answer;
+};
+
# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authentifies

1;
diff --git a/plugins/auth/auth_flat_file b/plugins/auth/auth_flat_file
index 2e74f5a..4d0abbc 100644
--- a/plugins/auth/auth_flat_file
+++ b/plugins/auth/auth_flat_file
@@ -35,41 +35,45 @@ use Digest::HMAC_MD5 qw(hmac_md5_hex);
sub register {
    my ( $self, $qp ) = @_;

-    $self->register_hook("auth-cram-md5", "auth_flat_file");
+    $self->register_hook('auth-plain',    'auth_flat_file');
+    $self->register_hook('auth-login',    'auth_flat_file');
+    $self->register_hook('auth-cram-md5', 'auth_flat_file');
}

sub auth_flat_file {
    my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
      @_;

-    my ( $pw_name, $pw_domain ) = split "@", lc($user);
+    if ( ! defined $passClear && ! defined $passHash ) {
+        return ( DENY, "authflat - missing password" );
+    }
+
+    my ( $pw_name, $pw_domain ) = split '@', lc($user);

    unless ( defined $pw_domain ) {
        return DECLINED;
    }

-    $self->log(LOGINFO, "Authentication for: $pw_name\@$pw_domain");
-
    my ($auth_line) = grep {/^$pw_name\@$pw_domain:/} $self->qp->config('flat_auth_pw');

-    unless (defined $auth_line) {
+    if ( ! defined $auth_line) {
+        $self->log(LOGINFO, "User not found: $pw_name\@$pw_domain");
        return DECLINED;
    }

+    $self->log(LOGINFO, "Authentication for: $pw_name\@$pw_domain");
+
    my ($auth_user, $auth_pass) = split(/:/, $auth_line, 2);

    # at this point we can assume the user name matched
-    if (
-        ( defined $passClear
-            and $auth_pass eq $passClear ) or
-        ( defined $passHash
-            and $passHash eq hmac_md5_hex($ticket, $auth_pass) )
-      )
-    {
-        return ( OK, "authflat/$method" );
-    }
-    else {
-        return ( DENY, "authflat/$method - wrong password" );
-    }
+    if ( defined $passClear && $auth_pass eq $passClear ) {
+        return ( OK, "authflat" );
+    };
+
+    if ( defined $passHash && $passHash eq hmac_md5_hex($ticket, $auth_pass) ) {
+        return ( OK, "authflat" );
+    };
+
+    return ( DENY, "authflat - wrong password" );
}

diff --git a/t/auth.t b/t/auth.t
new file mode 100644
index 0000000..d6e23b4
--- /dev/null
+++ b/t/auth.t
@@ -0,0 +1,143 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+
+use lib 't';
+use lib 'lib';
+
+use Data::Dumper;
+use Digest::HMAC_MD5 qw(hmac_md5_hex);
+use English qw/ -no_match_vars /;
+use File::Path;
+
+use Qpsmtpd::Constants;
+use Scalar::Util qw( openhandle );
+use Test::More qw(no_plan);
+
+use_ok('Test::Qpsmtpd');
+use_ok('Qpsmtpd::Auth');
+
+my ($smtpd, $conn) = Test::Qpsmtpd->new_conn();
+
+ok( $smtpd, "get new connection ($smtpd)");
+isa_ok( $conn, 'Qpsmtpd::Connection', "get new connection");
+
+#warn Dumper($smtpd) and exit;
+#my $hooks = $smtpd->hooks;
+#warn Dumper($hooks) and exit;
+
+my $r;
+my $user     = '[email protected]';
+my $pass     = 'good_pass';
+my $enc_plain= Qpsmtpd::Auth::e64( join("\0", '', $user, $pass ) );
+
+# get_auth_details_plain: plain auth method handles credentials properly
+my ($loginas,$ruser,$passClear) = Qpsmtpd::Auth::get_auth_details_plain($smtpd, $enc_plain);
+cmp_ok( $user, 'eq', $user, "get_auth_details_plain, user");
+cmp_ok( $passClear, 'eq', $pass, "get_auth_details_plain, password");
+
+my $bad_auth = Qpsmtpd::Auth::e64( join("\0", 'loginas', 'user@foo', 'passer') );
+($loginas,$ruser,$passClear) = Qpsmtpd::Auth::get_auth_details_plain($smtpd, $bad_auth );
+ok( ! $loginas, "get_auth_details_plain, loginas -");
+ok( !$ruser, "get_auth_details_plain, user -");
+ok( !$passClear, "get_auth_details_plain, pass -");
+
+# these plugins test against whicever loaded plugin provides their selected
+# auth type. Right now, they end up testing against auth_flat_file.
+
+# PLAIN
+$r = Qpsmtpd::Auth::SASL($smtpd, 'plain', $enc_plain);
+cmp_ok( OK, '==', $r, "plain auth");
+
+if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) {
+# same thing, but must be entered interactively
+    print "answer: $enc_plain\n";
+    $r = Qpsmtpd::Auth::SASL($smtpd, 'plain', '');
+    cmp_ok( OK, '==', $r, "SASL, plain");
+};
+
+
+# LOGIN
+
+if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) {
+
+    my $enc_user = Qpsmtpd::Auth::e64( $user );
+    my $enc_pass = Qpsmtpd::Auth::e64( $pass );
+
+# get_base64_response
+    print "answer: $enc_user\n";
+    $r = Qpsmtpd::Auth::get_base64_response( $smtpd, 'Username' );
+    cmp_ok( $r, 'eq', $user, "get_base64_response +");
+
+# get_auth_details_login
+    print "answer: $enc_pass\n";
+    ($ruser,$passClear) = Qpsmtpd::Auth::get_auth_details_login( $smtpd, $enc_user );
+    cmp_ok( $ruser, 'eq', $user, "get_auth_details_login, user +");
+    cmp_ok( $passClear, 'eq', $pass, "get_auth_details_login, pass +");
+
+    print "encoded pass: $enc_pass\n";
+    $r = Qpsmtpd::Auth::SASL($smtpd, 'login', $enc_user);
+    cmp_ok( OK, '==', $r, "SASL, login"); 
+};
+
+
+# CRAM-MD5
+
+if ( $ENV{QPSMTPD_DEVELOPER} && is_interactive() ) {
+    print "starting SASL\n";
+
+# since we don't have bidirection communication here, we pre-generate a ticket
+    my $ticket = sprintf( '<%x.%x@%s>', rand(1000000), time(), $smtpd->config('me') );
+    my $hash_pass = hmac_md5_hex( $ticket, $pass );
+    my $enc_answer = Qpsmtpd::Auth::e64( join(' ', $user, $hash_pass ) );
+    print "answer: $enc_answer\n";
+    my (@r) = Qpsmtpd::Auth::get_auth_details_cram_md5( $smtpd, $ticket );
+    cmp_ok( $r[0], 'eq', $ticket, "get_auth_details_cram_md5, ticket" );
+    cmp_ok( $r[1], 'eq', $user,    "get_auth_details_cram_md5, user" );
+    cmp_ok( $r[2], 'eq', $hash_pass, "get_auth_details_cram_md5, passHash" );
+#warn Data::Dumper::Dumper(\@r);
+
+# this isn't going to work without bidirection communication to get the ticket
+    #$r = Qpsmtpd::Auth::SASL($smtpd, 'cram-md5' );
+    #cmp_ok( OK, '==', $r, "login auth");
+};
+
+
+sub is_interactive {
+
+## no critic
+# borrowed from IO::Interactive
+    my ($out_handle) = ( @_, select );    # Default to default output handle
+
+# Not interactive if output is not to terminal...
+    return if not -t $out_handle;
+
+# If *ARGV is opened, we're interactive if...
+    if ( openhandle * ARGV ) {
+
+# ...it's currently opened to the magic '-' file
+        return -t *STDIN if defined $ARGV && $ARGV eq '-';
+
+# ...it's at end-of-file and the next file is the magic '-' file
+        return @ARGV > 0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV;
+
+# ...it's directly attached to the terminal
+        return -t *ARGV;
+    };
+
+# If *ARGV isn't opened, it will be interactive if *STDIN is attached
+# to a terminal and either there are no files specified on the command line
+# or if there are files and the first is the magic '-' file
+    return -t *STDIN && ( @ARGV == 0 || $ARGV[0] eq '-' );
+}
+
+
+__END__
+
+if ( ref $r ) {
+} else {
+    warn $r;
+}
+#print Data::Dumper::Dumper($conn);
+#print Data::Dumper::Dumper($smtpd);
+
-- 
1.7.9.6