Separate authentication-related methods in a new module Fripost::Schema::Auth.

6 files changed, 372 insertions, 135 deletions

diff --git a/config.in b/config.in
index 05ea35c..1d2e9f8 100644
--- a/config.in
+++ b/config.in
@@ -14,7 +14,7 @@ ldap_suffix = ou=virtual,o=mailHosting,dc=fripost,dc=dev
 
 # The kerberos service instance (probably the fqdn of the machine
 # running slapd).
-krb5_service_instance = gnu.friprogramvarusyndikatet.se
+ldap_SASL_service_instance = gnu.friprogramvarusyndikatet.se
 
 # The minimum password length.
 password_min_length = 12
diff --git a/lib/Fripost/Panel/Login.pm b/lib/Fripost/Panel/Login.pm
index e0ee02f..00fff72 100644
--- a/lib/Fripost/Panel/Login.pm
+++ b/lib/Fripost/Panel/Login.pm
@@ -192,7 +192,7 @@ sub error_rm : ErrorRunmode {
     my $self = shift;
     my $error = shift;
 
-    if ($error =~ /^\d+$/) {
+    if ($error =~ /^4\d+$/) {
         # HTTP client error.
         chomp $error;
         $self->header_props ( -status => $error );
diff --git a/lib/Fripost/Schema.pm b/lib/Fripost/Schema.pm
index 2e1cbef..7526077 100644
--- a/lib/Fripost/Schema.pm
+++ b/lib/Fripost/Schema.pm
@@ -18,6 +18,7 @@ use strict;
 use warnings;
 use utf8;
 
+use parent 'Fripost::Schema::Auth';
 use Net::LDAP;
 use Authen::SASL;
 use Fripost::Schema::Util qw/canonical_dn ldap_explode_dn split_addr/;
@@ -33,122 +34,6 @@ use Net::IDN::Encode 'email_to_ascii';
 
 =over 4
 
-=item B<SASLauth> (I<username>, I<CFG>)
-
-Start a LDAP connection, and SASL-authenticate (with the GSSAPI
-mechanism) using proxy authentication for the given (fully-qualified)
-user. I<CFG> should contain definitions for the LDAP suffix and the
-authentication ID.
-
-=cut
-
-sub SASLauth {
-    my $class = shift;
-    my ($l,$d) = split_addr(shift);
-    my %cfg = @_;
-
-    return unless defined $cfg{ldap_SASL_mechanism};
-    my $self = bless {}, $class;
-
-    $self->suffix( ldap_explode_dn(@{$cfg{ldap_suffix}}) );
-    $self->whoami( canonical_dn( {fvu => $l}, {fvd => $d}, @{$self->suffix} ));
-    $self->ldap( Net::LDAP::->new( $cfg{ldap_uri} // 'ldap://127.0.0.1:389/'
-                                 , async => 0 ));
-
-    my $callback;
-    if ($cfg{ldap_SASL_mechanism} eq 'DIGEST-MD5') {
-        $callback = { user => $cfg{ldap_authcID}
-                    , pass => $cfg{ldap_authcPW}
-                    , authname => 'dn:'.$self->whoami
-                    };
-    }
-    elsif ($cfg{ldap_SASL_mechanism} eq 'GSSAPI') {
-        $callback = { user => 'dn:'.$self->whoami };
-    }
-    else {
-        die "Unknown SASL mechanism: ".$cfg{ldap_SASL_mechanism};
-    }
-
-    my $sasl = Authen::SASL::->new( mechanism => $cfg{ldap_SASL_mechanism}
-                                  , callback => $callback );
-    my $host = $cfg{krb5_service_instance} // 'localhost';
-    my $conn = $sasl->client_new( 'ldap', $host );
-    die $conn->error if $conn->code;
-
-    my $mesg = $self->ldap->bind( undef, sasl => $conn );
-    # This is not supposed to happen.
-    die $mesg->error if $mesg->code;
-
-    return $self;
-}
-
-
-=item B<auth> (I<username>, I<password>, I<CFG>)
-
-Start a LDAP connection, and (simple-) binds the given user.
-I<CFG> should contain definitions for the LDAP suffix and URI.
-
-=cut
-
-sub auth {
-    my $class = shift;
-    my $id = shift;
-    my $pw = shift;
-    my %cfg = @_;
-
-    my $self = bless {}, $class;
-    $self->suffix( ldap_explode_dn(@{$cfg{ldap_suffix}}) );
-
-    if (not (defined $id) or defined $cfg{ldap_bind_dn}) {
-        $self->whoami( join ',', @{$cfg{ldap_bind_dn}} );
-    }
-    else {
-        my ($l,$d) = split_addr($id);
-        $self->whoami( canonical_dn( {fvu => $l}, {fvd => $d}, @{$self->suffix} ));
-    }
-
-    $self->ldap( Net::LDAP::->new( $cfg{ldap_uri} // 'ldap://127.0.0.1:389/'
-                                 , async => 0 ) );
-
-    my $mesg = $self->ldap->bind( $self->whoami, password => $pw );
-    if ($mesg->code) {
-        if (defined $cfg{'-die'}) {
-            return unless $cfg{'-die'};
-            die $cfg{'-die'}."\n";
-        }
-        die $mesg->error;
-    }
-    return $self;
-}
-
-
-
-# The DN of the authorization ID
-sub whoami { shift->_set_or_get('_whoami',@_); }
-
-# The LDAP object (of class Net::LDAP)
-sub ldap { shift->_set_or_get('_ldap',@_); }
-
-# The suffix under which virtual domains are.
-sub suffix { shift->_set_or_get('_suffix',@_); }
-
-
-# Set or get a key (the first argument), depending on whether a second
-# argument is given or not.
-sub _set_or_get {
-    my $self = shift;
-    my $what = shift;
-
-    if (@_) {
-        $self->{$what} = $_[0];
-    }
-    else {
-        return $self->{$what};
-    }
-}
-
-
-
 =item B<domain>
 
 Bless the object to C<Fripost::Schema::Domain>, to access
@@ -199,19 +84,6 @@ local-specific (users, aliases and lists) methods.
 sub local { bless shift, 'Fripost::Schema::Local'; }
 
 
-
-=item B<done>
-
-Unbinds from the LDAP server.
-
-=cut
-
-sub done {
-    my $self = shift;
-    $self->ldap->unbind if defined $self and defined $self->ldap;
-}
-
-
 =back
 
 =head1 AUTHOR
diff --git a/lib/Fripost/Schema/Auth.pm b/lib/Fripost/Schema/Auth.pm
new file mode 100644
index 0000000..2df1a7e
--- /dev/null
+++ b/lib/Fripost/Schema/Auth.pm
@@ -0,0 +1,307 @@
+package Fripost::Schema::Auth;
+
+=head1 NAME
+
+Auth.pm - Authentication methods for the Fripost schema.
+
+=cut
+
+=head1 DESCRIPTION
+
+This module allows simple and SASL authentication against the Fripost
+LDAP schema. It is also possible for authenticated users to change their
+(or another user's) password.
+
+=cut
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+use Net::LDAP;
+use Net::LDAP::Extension::SetPassword;
+use Authen::SASL;
+use Fripost::Schema::Util qw/canonical_dn ldap_explode_dn ldap_error
+                             split_addr assert softdie/;
+
+
+=head1 METHODS
+
+=over 4
+
+=item B<SASLauth> (I<username>, I<OPTIONS>)
+
+Start a LDAP connection, and SASL-authenticate using proxy
+authentication for the given (fully qualified) user.
+The following keys in the hash I<OPTIONS> are considered:
+
+=over 4
+
+=item B<ldap_uri> => I<host>
+
+The host (or LDAP URI) to connect to. Defaults to
+I<ldap://127.0.0.1:389/>.
+
+=item B<ldap_SASL_mechanism> => I<mech>
+
+The SASL mechanism to use. This is mandatory.
+
+=item B<ldap_authcID> => I<user>
+
+The authentication ID for SASL binds. Its format and whether or not it
+is required depends on the used SASL mechanism.
+
+=item B<ldap_authcPW> => I<password>
+
+The password to use for the SASL authentication. It may or not be
+required, depending on the used SASL mechanism.
+
+=item B<ldap_SASL_service_instance> => I<service>
+
+The SASL service instance. Defaults to I<localhost>.
+
+=item B<ldap_suffix> => I<[RDN1,RDN2,...]>
+
+An array of the Relative Distinguished Name determining where to store
+the virtual entries.
+
+=back
+
+Errors can be caught with options B<-die> and B<-errors>, see
+B<Fripost::Schema::Util> for details.
+
+=cut
+
+sub SASLauth {
+    my $class = shift;
+    my $user = shift;
+    my %options = @_;
+
+    return unless defined $options{ldap_SASL_mechanism};
+    my $self = bless {}, $class;
+
+    $self->suffix( ldap_explode_dn(@{$options{ldap_suffix}}) );
+    $self->whoami( $self->mkdn($user) );
+    $self->ldap( Net::LDAP::->new( $options{ldap_uri} // 'ldap://127.0.0.1:389/'
+                                 , async => 0 ) );
+    assert( $self->ldap, -die => "Couldn't connect to the LDAP server." );
+
+    my $callback;
+    if ($options{ldap_SASL_mechanism} eq 'DIGEST-MD5') {
+        my ($id,$pw) = ($options{ldap_authcID}, $options{ldap_authcPW});
+        delete $options{ldap_authcID};
+        delete $options{ldap_authcPW}; # These are private options.
+        $callback = { user => $id
+                    , pass => $pw
+                    , authname => 'dn:'.$self->whoami
+                    };
+    }
+    elsif ($options{ldap_SASL_mechanism} eq 'GSSAPI') {
+        $callback = { user => 'dn:'.$self->whoami };
+    }
+    else {
+        softdie( "Unknown SASL mechanism: ".$options{ldap_SASL_mechanism},
+                 %options );
+    }
+
+    my $sasl = Authen::SASL::->new( mechanism => $options{ldap_SASL_mechanism}
+                                  , callback => $callback );
+    my $host = $options{ldap_SASL_service_instance} // 'localhost';
+    my $conn = $sasl->client_new( 'ldap', $host );
+    ldap_error ($conn, %options);
+
+    my $mesg = $self->ldap->bind( undef, sasl => $conn );
+    ldap_error ($mesg, %options) // return;
+
+    return $self;
+}
+
+
+
+=item B<auth> (I<username>, I<password>, I<OPTIONS>)
+
+Start a LDAP connection, and simple authenticate the given I<username>.
+An option B<ldap_bind_dn> may be given to override I<username>, which
+may then be left undefined.
+The following keys in the hash I<OPTIONS> are considered:
+
+=over 4
+
+=item B<ldap_uri> => I<host>
+
+The host (or LDAP URI) to connect to. Defaults to
+I<ldap://127.0.0.1:389/>.
+
+=item B<ldap_bind_dn> => I<[RDN1,RDN2,...]>
+
+Bind using the Distinguished Name formed by the concatenation of these
+RDNs instead.
+
+=item B<ldap_suffix> => I<[RDN1,RDN2,...]>
+
+An array of the Relative Distinguished Name determining where to store
+the virtual entries.
+
+=back
+
+Errors can be caught with options B<-die> and B<-errors>, see
+B<Fripost::Schema::Util> for details.
+
+=cut
+
+sub auth {
+    my $class = shift;
+    my $user = shift;
+    my $pw = shift // return;
+    my %options = @_;
+
+    my $self = bless {}, $class;
+    $self->suffix( ldap_explode_dn(@{$options{ldap_suffix}}) );
+
+    if (defined $options{ldap_bind_dn}) {
+        $self->whoami( join ',', @{$options{ldap_bind_dn}} );
+    }
+    else {
+        return unless defined $user;
+        $self->whoami( $self->mkdn($user) );
+    }
+
+    $self->ldap( Net::LDAP::->new( $options{ldap_uri} // 'ldap://127.0.0.1:389/'
+                                 , async => 0 ) );
+    assert( $self->ldap, -die => "Couldn't connect to the LDAP server." );
+
+    my $mesg = $self->ldap->bind( $self->whoami, password => $pw );
+    ldap_error ($mesg, %options) // return;
+
+    return $self;
+}
+
+
+
+=item B<passwd> (I<username>, I<oldpassword>, I<newpassword>, I<OPTIONS>)
+
+Change the password of the given I<username> (the current user is chosen
+when no I<username> is passed). The current user, whose current password
+is I<oldpassword>, must have write access on the C<< userPassword >>
+attribute of the DN associated with I<username>.
+
+If I<newpassword> is left undefined, the new password is generated at
+random, and returned upon success.
+
+Errors can be caught with options B<-die> and B<-errors>, see
+B<Fripost::Schema::Util> for details.
+
+=cut
+
+sub passwd {
+    my $self = shift;
+    my $user = $self->mkdn(shift) // $self->whoami;
+    my $oldpw = shift;
+    my $newpw = shift;
+    my %options = @_;
+
+    assert ($oldpw, %options); # Must give a password
+    my %args = (user => $user, password => $oldpw);
+    $args{newpasswd} = $newpw if defined $newpw;
+
+    my $mesg = $self->ldap->set_password( %args );
+    ldap_error ($mesg, %options) // return;
+
+    $self->ldap->gen_password unless defined $newpw;
+}
+
+
+=item B<whoami> ([I<DN>])
+
+Set or get the identity of the user that is currently associated with
+the LDAP session. I<DN> is given in string canonical form, defined in
+B<Net::LDAP::Util>.
+
+=cut
+
+sub whoami { shift->_set_or_get('_whoami',@_); }
+
+
+=item B<ldap> ([I<session>])
+
+Set or get the current LDAP I<session>, a B<Net::LDAP> object.
+
+=cut
+
+sub ldap { shift->_set_or_get('_ldap',@_); }
+
+
+=item B<suffix> ([I<DN>])
+
+Set or get the current Distinguished Name determining where to store the
+virtual entries. I<DN> must be given in exploded canonical form (array
+of hashes), defined in B<Net::LDAP::Util>.
+
+=cut
+
+sub suffix { shift->_set_or_get('_suffix',@_); }
+
+
+=item B<mkdn> ({I<username>|I<domainname>})
+
+Create the Distinguished Name associated with the I<username> (may be an
+alias or a list name regardless) or I<domainname>. The argument is first
+converted to ASCII.
+
+=cut
+
+sub mkdn {
+    my $self = shift;
+    my $user = shift // return;
+    my ($l,$d) = split_addr($user, -encode => 'ascii');
+    my @dn = ({fvd => $d}, @{$self->suffix});
+    unshift @dn, {fvl => $l} if defined $l and $l ne '';
+    canonical_dn( @dn );
+}
+
+
+# Set or get a key (the first argument), depending on whether or not a second
+# argument is given. The value after optional assignation is returned.
+sub _set_or_get {
+    my $self = shift;
+    my ($k,$v) = @_;
+
+    $self->{$k} = $v if defined $v;
+    return $self->{$k};
+}
+
+
+
+=item B<done>
+
+Unbind from the LDAP server and close the connection.
+
+=cut
+
+sub done {
+    my $self = shift;
+    $self->ldap->unbind if defined $self and defined $self->ldap;
+}
+
+
+=back
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012,2013 Guilhem Moulin.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=cut
+
+1;
+
+__END__
diff --git a/lib/Fripost/Schema/Util.pm b/lib/Fripost/Schema/Util.pm
index 2692421..0f6821c 100644
--- a/lib/Fripost/Schema/Util.pm
+++ b/lib/Fripost/Schema/Util.pm
@@ -13,9 +13,9 @@ use utf8;
 
 use Exporter 'import';
 our @EXPORT_OK = qw /concat get_perms explode
-                     must_attrs email_valid
-                     canonical_dn ldap_explode_dn
-                     split_addr/;
+                     must_attrs email_valid split_addr
+                     canonical_dn ldap_explode_dn ldap_error
+                     assert softdie/;
 use Email::Valid;
 use Net::IDN::Encode;
 use Net::LDAP::Util;
@@ -155,6 +155,64 @@ sub split_addr {
     split /\@/, $addr, 2;
 }
 
+sub ldap_error {
+    my $mesg = shift;
+    my %options = @_;
+
+    my $error;
+    if (defined $options{'-die'}) {
+        if (ref $options{'-die'} eq 'HASH') {
+            if (exists $options{'-die'}->{$mesg->code}) {
+                $error = $options{'-die'}->{$mesg->code};
+            }
+            elsif (exists $options{'-die'}->{_}) {
+                $error = $options{'-die'}->{_};
+            }
+            else {
+                $error = $mesg->error;
+            }
+        }
+        else {
+            $error = $options{'-die'} if $mesg->code;
+        }
+    }
+    else {
+        $error = $mesg->error if $mesg->code;
+    }
+
+    return $mesg unless defined $error;
+    return unless $error;
+
+    if (defined $options{'-error'}) {
+        ${$options{'-error'}} = $error;
+    }
+    else {
+        die $error, "\n";
+    }
+}
+
+sub assert {
+    my $what = shift;
+    my %options = @_;
+
+    return $what if defined $what;
+    die "Not defined.\n" unless defined $options{'-die'};
+
+    if (defined $options{'-error'}) {
+        ${$options{'-error'}} = $options{'-die'};
+    }
+    else {
+        die $options{'-die'}, "\n";
+    }
+}
+
+sub softdie {
+    my $mesg = shift;
+    my %options = @_;
+
+    $options{'-die'} = $mesg;
+    &assert (undef, %options);
+}
 
 =head1 AUTHOR
 
diff --git a/misc/deleteExpiredEntries.pl b/misc/deleteExpiredEntries.pl
index 3cbf570..80dd79b 100755
--- a/misc/deleteExpiredEntries.pl
+++ b/misc/deleteExpiredEntries.pl
@@ -23,7 +23,7 @@ B<deleteExpiredEntries.pl> [maximum age in seconds]
 use Pod::Usage;
 use Config::Auto;
 use lib 'lib';
-use Fripost::Schema;
+use Fripost::Schema::Auth;
 use POSIX 'strftime';
 
 # TODO: put that in a config file