path: root/lib/Fripost/Schema/Auth.pm

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<SASLauth> (I<username>, I<cfg>, I<OPTIONS>)

Start a LDAP connection, and SASL-authenticate using proxy
authentication for the given (fully qualified) user.
The following keys in the hash reference I<cfg> 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<-error>; See
B<Fripost::Schema::Util> 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<auth> (I<username>, I<password>, I<cfg>, 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 reference I<cfg> 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<-error>; See
B<Fripost::Schema::Util> 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<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<-error>, see
B<Fripost::Schema::Util> 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<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<mail2dn> ({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 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<cfg> ([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<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__