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 email_valid assert softdie/; =head1 METHODS =over 4 =item B (I, I, I) Start a LDAP connection, and SASL-authenticate using proxy authentication for the given (fully qualified) user. The following keys in the hash reference 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<-error>; See B for details. =cut sub SASLauth { my $class = shift; my $user = shift; my $cfg = shift; my %options = @_; return unless defined $cfg->{ldap_SASL_mechanism}; my $self = bless {}, $class; $self->suffix( ldap_explode_dn(@{$cfg->{ldap_suffix}}) ); $self->whoami( $self->mail2dn($user) ); $self->ldap( Net::LDAP::->new( $cfg->{ldap_uri} // 'ldap://127.0.0.1:389/' ) ); assert( $self->ldap, -die => "Couldn't connect to the LDAP server." ); my $callback; if ($cfg->{ldap_SASL_mechanism} eq 'DIGEST-MD5') { my ($id,$pw) = ($cfg->{ldap_authcID}, $cfg->{ldap_authcPW}); $callback = { user => $id , pass => $pw , authname => 'dn:'.$self->whoami }; } elsif ($cfg->{ldap_SASL_mechanism} eq 'GSSAPI') { $callback = { user => 'dn:'.$self->whoami }; } else { softdie( "Unknown SASL mechanism: ".$cfg->{ldap_SASL_mechanism}, %options ); } my $sasl = Authen::SASL::->new( mechanism => $cfg->{ldap_SASL_mechanism} , callback => $callback ); my $host = $cfg->{ldap_SASL_service_instance} // 'localhost'; my $conn = $sasl->client_new( 'ldap', $host ); ldap_error ($conn, %options) // return; my $mesg = $self->ldap->bind( undef, sasl => $conn ); ldap_error ($mesg, %options) // return; # These are private options, we don't want to pass them around. delete $cfg->{$_} for qw/ldap_authcID ldap_authcPW/; $self->{_cfg} = $cfg; return $self; } =item B (I, 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 reference 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<-error>; See B for details. =cut sub auth { my $class = shift; my $user = shift; my $pw = shift // return; my $cfg = shift; my %options = @_; my $self = bless {}, $class; $self->suffix( ldap_explode_dn(@{$cfg->{ldap_suffix}}) ); if (defined $cfg->{ldap_bind_dn}) { $self->whoami( join ',', @{$cfg->{ldap_bind_dn}} ); } else { return unless email_valid($user, -nodie => 1, -exact => 1); $self->whoami( $self->mail2dn($user) ); } $self->ldap( Net::LDAP::->new( $cfg->{ldap_uri} // 'ldap://127.0.0.1:389/' ) ); 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; $self->{_cfg} = $cfg; 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<-error>, see B for details. =cut sub passwd { my $self = shift; my $user = $self->mail2dn(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 mail2dn { my $self = shift; my $mail = shift // return; $mail =~ s/^\@//; my ($l,$d) = split_addr($mail, -encode => 'ascii') or return; my @dn = ({fvd => $d}, @{$self->suffix}); unshift @dn, {fvl => $l} if $l; canonical_dn( @dn ); } =item B ([key1, [key2, ...]]) Give the value of configuration options. Without arguments, returns the whole configuration (as a hash in array context, as a hash reference otherwise). Keys can be specify to fetch one value (or more) of the configuration; In that case, the list of the corresponding values are returned. =cut sub cfg { my $self = shift; return @{$self->{_cfg}}{@_} if @_; return unless defined wantarray; return wantarray ? %{$self->{_cfg}} : $self->{_cfg}; } # 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__