package Net::LDAP::Class::User::POSIX;
use strict;
use warnings;
use Carp;
use Data::Dump qw( dump );
use Digest::SHA1;
use MIME::Base64;
use base qw( Net::LDAP::Class::User );
use Net::LDAP::Class::MethodMaker ( 'scalar --get_set_init' =>
        [qw( default_shell default_home_dir default_email_suffix )], );

our $VERSION = '0.22';

# see http://www.ietf.org/rfc/rfc2307.txt

=head1 NAME

Net::LDAP::Class::User::POSIX - user class for POSIX LDAP schema

=head1 SYNOPSIS

 # subclass this class for your local LDAP
 package MyLDAPUser;
 use base qw( Net::LDAP::Class::User::POSIX );
 
 __PACKAGE__->metadata->setup(
    base_dn             => 'dc=mycompany,dc=com',
    attributes          => __PACKAGE__->POSIX_attributes,
    unique_attributes   => __PACKAGE__->POSIX_unique_attributes,
 );
 
 1;
 
 # then use your class
 my $ldap = get_and_bind_LDAP_object(); # you write this
 
 use MyLDAPUser;
 my $user = MyLDAPUser->new( ldap => $ldap, uid  => 'foobar' );
 $user->read_or_create;
 for my $group ($user->group, @{ $user->groups }) {
     printf("user %s in group %s\n", $user, $group);
 }

=head1 DESCRIPTION

Net::LDAP::Class::User::POSIX isa Net::LDAP::Class::User implementing
the POSIX LDAP schema.

=head1 CLASS METHODS

=head2 POSIX_attributes

Returns array ref of default POSIX attributes.

=cut

sub POSIX_attributes {

    return [
        qw(
            uid userPassword uidNumber gidNumber
            gecos cn mail sn givenName pwdChangedTime
            homeDirectory loginShell
            )
    ];

}

=head2 POSIX_unique_attributes

Returns array ref of unique POSIX attributes: B<uid> and B<uidNumber>.

=cut

sub POSIX_unique_attributes {
    return [qw( uid uidNumber )];
}

=head1 OBJECT METHODS

All the init_* methods can be specified to the new() constructor without
the init_ prefix.

=head2 init_default_shell

Returns B</bin/bash>.

=cut

sub init_default_shell {'/bin/bash'}

=head2 init_default_home_dir

Returns B</home>.

=cut

sub init_default_home_dir {'/home'}

=head2 init_default_email_suffix

Returns an empty string.

=cut

sub init_default_email_suffix {''}

=head2 action_for_create([ uid => I<username>, uidNumber => I<nnn> ])

Returns hash ref suitable for creating a Net::LDAP::Batch::Action::Add.

May be called as a class method with explicit B<uid> and B<uidNumber>
key/value pairs.

=cut

sub action_for_create {
    my $self = shift;
    my %opts = @_;
    my $uid  = delete $opts{uidNumber} || $self->uidNumber
        or croak "uidNumber required to create()";
    my $username = delete $opts{uid} || $self->uid
        or croak "uid required to create()";

    my ( $group, $gid, $givenName, $sn, $gecos, $email, $hash )
        = $self->setup_for_write;

    # default attributes
    # note that not setting a homeDirectory or sn is a schema error
    my %attr = (
        objectClass  => [ "top", "person", "posixAccount" ],
        cn           => $username,
        givenName    => $givenName,
        sn           => $sn,
        uid          => $username,
        userPassword => "$hash",
        uidNumber    => $uid,
        gidNumber    => $gid,
        gecos        => $gecos,
        homeDirectory    => $self->default_home_dir . "/$username",
        loginShell       => $self->default_shell,
        shadowMin        => "-1",
        shadowMax        => "99999",
        shadowWarning    => "7",
        shadowLastChange => "13767",
        mail             => $email
    );

    # mix in whatever has been set
    for my $name ( keys %{ $self->{_not_yet_set} } ) {

        #warn "set $name => $self->{_not_yet_set}->{$name}";
        unless ( exists $attr{$name} ) {
            $attr{$name} = delete $self->{_not_yet_set}->{$name};
        }
        else {
            $attr{$name} = $self->{_not_yet_set}->{$name};
        }
    }

    my @actions = (
        add => {
            dn   => "uid=$username,ou=$group,ou=People," . $self->base_dn,
            attr => [%attr],
        }
    );

    # secondary groups
    if ( exists $self->{groups} ) {
        for my $group ( @{ $self->{groups} } ) {
            my @newUids;
            if ( !$group->read ) {
                croak
                    "You must create group $group before you add User $self to it";
            }
            if ( $self->debug ) {
                warn "POSIX group $group has memberUid: "
                    . Data::Dump::dump( $group->memberUid );
            }
            if ( $group->memberUid ) {
                @newUids = ( $group->memberUid, $username );
            }
            else {
                @newUids = ($username);
            }
            my $group_name = $group->cn;
            my $group_dn   = $group->base_dn;
            my $action     = {
                search => [
                    base   => "ou=Group,$group_dn",
                    scope  => "sub",
                    filter => "(cn=$group_name)",
                    attrs  => $group->attributes,
                ],
                replace => { memberUid => [@newUids] }
            };
            push( @actions, update => $action );
        }
    }

    return @actions;
}

=head2 setup_for_write

Utility method for generating default values for 
various attributes. Called by both action_for_create()
and action_for_update().

Returns array of values in this order:

 $groupname, $gid, $givenName, $sn, $gecos, $email, $passwordHash

=cut

sub setup_for_write {
    my $self = shift;

    # must find the group name first so we can set up dn correctly
    unless ( $self->gidNumber or $self->group ) {
        croak "group or gidNumber required";
    }
    my ( $group, $gid );

    my $group_class = $self->group_class;

    $group = $self->group
        || $group_class->new(
        gidNumber => $self->gidNumber,
        ldap      => $self->ldap
        )->read;

    if ( !defined $group ) {
        croak "group "
            . $self->gidNumber
            . " is not yet in LDAP. Must add it before creating User";
    }

    if ( ref $group and $group->isa('Net::LDAP::Class::Group::POSIX') ) {
        $gid   = $group->gidNumber;
        $group = $group->cn;
    }
    $gid ||= $self->gidNumber || $self->group->gidNumber;

    # set name
    unless ( $self->gecos || $self->sn || $self->givenName ) {
        croak "either gecos, sn or givenName must be set";
    }

    # the name logic breaks horribly here for anything but trivial cases.
    my @name_parts = split( m/\s+/, $self->gecos || '' );
    my $givenName = $self->givenName;
    $givenName = shift(@name_parts) unless defined $givenName;
    my $sn = $self->sn;
    $sn = join( ' ', @name_parts ) unless defined $sn;
    my $gecos = $self->gecos;
    $gecos = join( ' ', $givenName, $sn ) unless defined $gecos;

    my $email = $self->mail;
    $email = ( $self->username . $self->default_email_suffix )
        unless defined $email;

    # set password if not set.
    # this is useful for default random passwords.
    my $hash = $self->userPassword || $self->new_password;

    return ( $group, $gid, $givenName, $sn, $gecos, $email, $hash );
}

=head2 action_for_update

Returns array ref suitable for creating a Net::LDAP::Batch::Action::Update.

=cut

sub action_for_update {
    my $self     = shift;
    my %opts     = @_;                 # currently unused
    my $uid      = $self->uidNumber;
    my $username = $self->uid;

    unless ( $username and $uid ) {
        croak "must have uid and uidNumber set to update";
    }

    my @actions;

    my ( $group, $gid, $givenName, $sn, $gecos, $email, $hash )
        = $self->setup_for_write;

    my %derived = (
        cn            => $username,
        givenName     => $givenName,
        sn            => $sn,
        uid           => $username,
        userPassword  => $hash,
        uidNumber     => $uid,
        gidNumber     => $gid,
        gecos         => $gecos,
        mail          => $email,
        homeDirectory => $self->default_home_dir . "/$username",
        loginShell    => $self->default_shell,
    );

    # which fields have changed.
    my %replace;
    for my $attr ( keys %{ $self->{_was_set} } ) {

        my $old = $self->{_was_set}->{$attr}->{old};
        my $new = $self->{_was_set}->{$attr}->{new} || $derived{$attr};

        if ( defined($old) and !defined($new) ) {
            $replace{$attr} = undef;
        }
        elsif ( !defined($old) and defined($new) ) {
            $replace{$attr} = $new;
        }
        elsif ( !defined($old) and !defined($new) ) {

            #$replace{$attr} = undef;
        }
        elsif ( $old ne $new ) {
            $replace{$attr} = $new;
        }

    }

    if (%replace) {
        push(
            @actions,
            update => {
                search => [
                    base   => "ou=People," . $self->base_dn,
                    scope  => "sub",
                    filter => "(uid=$username)",
                    attrs  => $self->attributes,
                ],
                replace => \%replace
            }
        );
    }

    # what group(s) have changed?
    # compare primary group first
    # this assumes that setting group() is preferred to
    # explicitly setting gidNumber.
    if ( !exists $replace{gidNumber}
        and $self->group->gidNumber != $self->gidNumber )
    {

        # primary group has changed
        # must set gidNumber and change dn in two steps.
        my $newgroup = $self->group->cn;
        push(
            @actions,
            update => [
                {   search => [
                        base   => "ou=People," . $self->base_dn,
                        scope  => "sub",
                        filter => "(uid=$username)",
                        attrs  => $self->attributes,
                    ],
                    replace => { gidNumber => $self->group->gidNumber },
                },
                {   dn => {
                        'newrdn'       => "uid=$username",
                        'deleteoldrdn' => 1,
                        'newsuperior'  => "ou=$newgroup,ou=People,"
                            . $self->group->base_dn,
                    },
                    search => [
                        base   => "ou=People," . $self->base_dn,
                        scope  => "sub",
                        filter => "(uid=$username)",
                        attrs  => $self->attributes,
                    ],
                }
            ],
        );

        # clear so next access re-fetches
        delete $self->{group};

    }

    # next, secondary group membership.
    # check if any have been set explicitly,
    # since otherwise there is nothing to be done.
    if ( exists $self->{groups} ) {

        my $existing_groups = $self->fetch_groups;
        my %existing = map { $_->gidNumber => $_ } @$existing_groups;

        # the delete $self->{groups} has helpful side effect of clearing
        # cache.
        my %new = map { $_->gidNumber => $_ } @{ delete $self->{groups} };

        # which should be added
        my @to_add;
        for my $gid ( keys %new ) {
            if ( !exists $existing{$gid} ) {
                my @newUids    = ( $new{$gid}->memberUid, $self->uid );
                my $group_name = $new{$gid}->cn;
                my $group_dn   = $new{$gid}->base_dn;
                my $action     = {
                    search => [
                        base   => "ou=Group,$group_dn",
                        scope  => "one",
                        filter => "(cn=$group_name)",
                        attrs  => $new{$gid}->attributes,
                    ],
                    replace => { memberUid => [@newUids] }
                };
                push( @to_add, update => $action );
            }
        }

        # which should be removed
        my @to_rm;
        for my $gid ( keys %existing ) {
            if ( !exists $new{$gid} ) {
                my @newUids
                    = grep { $_ ne $self->uid } $existing{$gid}->memberUid;
                my $group_name = $existing{$gid}->cn;
                my $group_dn   = $existing{$gid}->base_dn;
                my $action     = {
                    search => [
                        base   => "ou=Group,$group_dn",
                        scope  => "one",
                        filter => "(cn=$group_name)",
                        attrs  => $existing{$gid}->attributes,
                    ],
                    replace => { memberUid => [@newUids] }
                };
                push( @to_rm, update => $action );
            }
        }

        carp "to_add: " . dump( \@to_add ) if $self->debug;
        carp "to_rm: " . dump( \@to_rm )   if $self->debug;

        push( @actions, @to_add, @to_rm );

    }

    if ( !@actions ) {
        warn "no fields have changed for User $username. Skipping update().";
        return;
    }

    carp "updating User with actions: " . Data::Dump::dump( \@actions )
        if $self->debug;

    return @actions;

}

=head2 action_for_delete

Returns hash ref suitable for creating a Net::LDAP::Batch::Action::Delete.

=cut

sub action_for_delete {
    my $self     = shift;
    my %opts     = @_;
    my $username = delete $opts{uid} || $self->uid;

    if ( !$username ) {
        croak "uid required to delete a User";
    }

    # delete the user
    my @actions = (
        delete => {
            search => [
                base   => "ou=People," . $self->base_dn,
                scope  => "sub",
                filter => "(uid=$username)",
                attrs  => $self->attributes,
            ]
        }
    );

    return @actions;
}

=head2 fetch_group

Required MethodMaker method for retrieving primary group from LDAP.

Returns an object of type group_class().

=cut

sub fetch_group {
    my $self = shift;
    my $class = $self->group_class or croak "group_class() required";

    if ( !$self->gidNumber ) {
        croak "cannot fetch group without a gidNumber set";
    }

    # get groups too
    return $class->new(
        gidNumber => $self->gidNumber,
        ldap      => $self->ldap
    )->read;
}

=head2 fetch_groups

Required MethodMaker method for retrieving secondary groups from LDAP.

Returns array or array ref (based on context) of objects of type
group_class().

=cut

sub fetch_groups {
    my $self  = shift;
    my $class = $self->group_class or croak "group_class required";
    my @g     = $class->find(
        ldap    => $self->ldap,
        base_dn => 'ou=Group,' . $self->group->base_dn,
        filter  => "(memberUid=" . $self->uid . ")",
    );
    return wantarray ? @g : \@g;
}

=head2 groups_iterator([I<opts>])

Returns a Net::LDAP::Class::Iterator object for same data
as fetch_groups().

See the advice in L<Net::LDAP::Class::Iterator> about iterators
versus arrays.

=cut

sub groups_iterator {
    my $self        = shift;
    my $group_class = $self->group_class or croak "group_class required";
    my $uid         = $self->uid || $self->read->uid;
    return Net::LDAP::Class::Iterator->new(
        class   => $group_class,
        base_dn => 'ou=Group,' . $self->group->base_dn,
        filter  => "(memberUid=$uid)",
        ldap    => $self->ldap,
        @_
    );
}

=head2 gid

Alias for gidNumber() attribute.

=cut

sub gid {
    my $self = shift;
    $self->gidNumber(@_);
}

=head2 password([I<plain_password>])

Convenience wrapper around userPassword() attribute method.

This method will SHA-1-hashify I<plain_password> using ssha_hash()
and set the hash
in the ldap_entry(). If no argument is supplied, returns the hash
string set in ldap_entry() (if any).

=cut

sub password {
    my $self      = shift;
    my $attribute = 'userPassword';

    if ( !defined $self->ldap_entry && grep { $_ eq $attribute }
        @{ $self->attributes } )
    {

        if ( scalar @_ ) {
            $self->{_not_yet_set}->{$attribute} = $self->ssha_hash( $_[0] );
        }
        return
            exists $self->{_not_yet_set}->{$attribute}
            ? $self->{_not_yet_set}->{$attribute}
            : undef;

    }

    if (@_) {
        my $hash = $self->ssha_hash( $_[0] );
        my @old  = $self->ldap_entry->get_value($attribute);
        $self->ldap_entry->replace( $attribute, $hash );
        $self->{_was_set}->{$attribute}->{new} = $hash;

       # do not overwrite an existing 'old' value, since we might need to know
       # what was originally in the ldap_entry in order to replace it.
        unless ( exists $self->{_was_set}->{$attribute}->{old} ) {
            $self->{_was_set}->{$attribute}->{old}
                = @old > 1 ? \@old : $old[0];
        }
    }

    return $self->ldap_entry->get_value($attribute);
}

=head2 new_password([I<len>])

Returns a SHA-1-hashed password from a random string of length I<len>.
Default length is 8 characters. This method is just a simple
wrapper around ssha_hash() and random_string().

=cut

sub new_password {
    my $self = shift;
    return $self->ssha_hash( $self->random_string(@_) );
}

=head2 ssha_hash( I<string> )

Returns seeded hash of I<string> using SHA-1. See
http://www.openldap.org/faq/data/cache/347.html

B<NOTE:> The hash will contain the LDAP-required
C<{SSHA}> prefix. If the prefix is already present, will
return I<string> untouched.

=cut

sub ssha_hash {
    my $self = shift;
    my $string = shift or croak "string required";
    return $string if $string =~ m/^\{SSHA\}/;

    my $seed = $self->random_string;
    my $sha1 = Digest::SHA1->new;
    $sha1->add($string);
    $sha1->add($seed);

    return '{SSHA}' . encode_base64( $sha1->digest . $seed, '' );
}

1;

__END__

=head1 AUTHOR

Peter Karman, C<< <karman at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-net-ldap-class at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-LDAP-Class>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Net::LDAP::Class

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Net-LDAP-Class>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Net-LDAP-Class>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-LDAP-Class>

=item * Search CPAN

L<http://search.cpan.org/dist/Net-LDAP-Class>

=back

=head1 ACKNOWLEDGEMENTS

The Minnesota Supercomputing Institute C<< http://www.msi.umn.edu/ >>
sponsored the development of this software.

=head1 COPYRIGHT

Copyright 2008 by the Regents of the University of Minnesota.
All rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

Net::LDAP

=cut