diff options
| -rw-r--r-- | config.in | 2 | ||||
| -rw-r--r-- | lib/Fripost/Panel/Login.pm | 2 | ||||
| -rw-r--r-- | lib/Fripost/Schema.pm | 130 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Auth.pm | 307 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Util.pm | 64 | ||||
| -rwxr-xr-x | misc/deleteExpiredEntries.pl | 2 |
6 files changed, 372 insertions, 135 deletions
@@ -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 |