From 93713bfe4b48e2335826f1886fa7e684787ece01 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Wed, 23 Jan 2013 20:39:19 +0100 Subject: Separate authentication-related methods in a new module Fripost::Schema::Auth. --- lib/Fripost/Panel/Login.pm | 2 +- lib/Fripost/Schema.pm | 130 +------------------ lib/Fripost/Schema/Auth.pm | 307 +++++++++++++++++++++++++++++++++++++++++++++ lib/Fripost/Schema/Util.pm | 64 +++++++++- 4 files changed, 370 insertions(+), 133 deletions(-) create mode 100644 lib/Fripost/Schema/Auth.pm (limited to 'lib') 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 (I, I) - -Start a LDAP connection, and SASL-authenticate (with the GSSAPI -mechanism) using proxy authentication for the given (fully-qualified) -user. I 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 (I, I, I) - -Start a LDAP connection, and (simple-) binds the given user. -I 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 Bless the object to C, to access @@ -199,19 +84,6 @@ local-specific (users, aliases and lists) methods. sub local { bless shift, 'Fripost::Schema::Local'; } - -=item B - -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 (I, I) + +Start a LDAP connection, and SASL-authenticate using proxy +authentication for the given (fully qualified) user. +The following keys in the hash I are considered: + +=over 4 + +=item B => I + +The host (or LDAP URI) to connect to. Defaults to +I. + +=item B => I + +The SASL mechanism to use. This is mandatory. + +=item B => I + +The authentication ID for SASL binds. Its format and whether or not it +is required depends on the used SASL mechanism. + +=item B => I + +The password to use for the SASL authentication. It may or not be +required, depending on the used SASL mechanism. + +=item B => I + +The SASL service instance. Defaults to I. + +=item B => 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 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 (I, I, I) + +Start a LDAP connection, and simple authenticate the given I. +An option B may be given to override I, which +may then be left undefined. +The following keys in the hash I are considered: + +=over 4 + +=item B => I + +The host (or LDAP URI) to connect to. Defaults to +I. + +=item B => I<[RDN1,RDN2,...]> + +Bind using the Distinguished Name formed by the concatenation of these +RDNs instead. + +=item B => 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 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 (I, I, I, I) + +Change the password of the given I (the current user is chosen +when no I is passed). The current user, whose current password +is I, must have write access on the C<< userPassword >> +attribute of the DN associated with I. + +If I 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 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 ([I]) + +Set or get the identity of the user that is currently associated with +the LDAP session. I is given in string canonical form, defined in +B. + +=cut + +sub whoami { shift->_set_or_get('_whoami',@_); } + + +=item B ([I]) + +Set or get the current LDAP I, a B object. + +=cut + +sub ldap { shift->_set_or_get('_ldap',@_); } + + +=item B ([I]) + +Set or get the current Distinguished Name determining where to store the +virtual entries. I must be given in exploded canonical form (array +of hashes), defined in B. + +=cut + +sub suffix { shift->_set_or_get('_suffix',@_); } + + +=item B ({I|I}) + +Create the Distinguished Name associated with the I (may be an +alias or a list name regardless) or I. 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 + +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<< >> + +=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 -- cgit v1.2.3