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/Schema/Auth.pm | 307 +++++++++++++++++++++++++++++++++++++++++++++ lib/Fripost/Schema/Util.pm | 64 +++++++++- 2 files changed, 368 insertions(+), 3 deletions(-) create mode 100644 lib/Fripost/Schema/Auth.pm (limited to 'lib/Fripost/Schema') 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