package LATMOS::Accounts::Bases::Unix;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases);
use LATMOS::Accounts::Log;
use Fcntl qw(:flock);
use Encode;

our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];

=head1 NAME

LATMOS::Ad - Perl extension for blah blah blah

=head1 SYNOPSIS

  use LATMOS::Accounts::Bases;
  my $base = LATMOS::Accounts::Bases->new('unix');
  ...

=head1 DESCRIPTION

Account base access over standard unix file format.

=head1 FUNCTIONS

=cut

=head2 new(%config)

Create a new LATMOS::Ad object for windows AD $domain.

domain / server: either the Ad domain or directly the server

ldap_args is an optionnal list of arguments to pass to L<Net::LDAP>.

=cut

sub new {
    my ($class, %config) = @_;
    
    my $base = {
        # are we using shadow, default to yes
        use_shadow => (defined($config{use_shadow}) ? $config{use_shadow} : 1),
        min_gid => $config{min_gid},
        min_uid => $config{min_uid},
        nis_overflow => ($config{nis_overflow} || ''),
        users => {},
        groups => {},
    };

    foreach (qw(passwd shadow group gshadow)) {
        if ($config{$_}) {
            $base->{$_} = $config{$_};
        } elsif ($config{directory}) {
            $base->{$_} = $config{directory} . '/' . $_;
        } else {
            $base->{$_} = "/etc/$_";
        }
    }


    bless($base, $class);
}

my @password_fields = qw(account password uid gid gecos home shell);
my @shadow_fields =   qw(account spassword last_changed before_ch after_ch exp_warn exp_disable disable res);
my @group_fields =    qw(group_name passwd gid user_list);
my @gshadow_fields =  qw(group_name spassword unknown suser_list);

# All UNIX account file are colon separated field
# This function factorize open/read/split fields

sub _load_unix_file {
    my ($self, $file, $callback) = @_;
    my $enc = find_encoding($self->config('encoding') || 'iso-8859-14')
        or do {
        $self->log(LA_ERROR, "Cannot find encoding %s", $self->config('encoding') || 'iso-8859-15');
        return;
    };
    open(my $handle, '<', $file) or do {
        $self->log(LA_ERR, "Cannot open unix file `%s' for reading (%s)", $file, $!);
        return;
    };
    $self->log(LA_DEBUG, "Reading file $file");
    flock($handle, LOCK_EX);
    while (my $line = <$handle>) {
        chomp($line);
        $line = encode('utf-8', $line);
        my @ch = split(':', $line);
        $callback->(@ch);
    }
    close($handle);
    return 1;
}

=head2 load

Read file and load data into memory

=cut

sub load {
    my ($self) = @_;

    # If already loaded, just say ok !
    $self->{_loaded} and return 1;
    
    $self->_load_unix_file(
        $self->{passwd},
        sub {
            my @ch = @_;
            my $user = $ch[0] or return;
            # TODO add check ?
            foreach (@password_fields) {
                $self->{users}{$user}{$_} = shift(@ch);
            }
            if ($self->{users}{$user}{password} =~ /^!!/) {
                $self->{users}{$user}{password} =~ s/^!!//;
                $self->{users}{$user}{locked} = 1;
            }
            $self->{users}{$user}{shell} ||= '';
            $self->{users}{$user}{shell} =~ s/^-//;
        },
    ) or return;
    
    $self->_load_unix_file(
        $self->{group},
        sub {
            my @ch = @_;
            my $group = $ch[0];

            foreach (@group_fields) {
                $self->{groups}{$group}{$_} = shift(@ch);
            }

            # split user in the group
            foreach (split(',', ($self->{groups}{$group}{'user_list'} || ''))) {
                $self->{groups}{$group}{'users'}{$_} = 1;
            }
        }
    ) or return;

    # Post processing group for split group because nis
    foreach my $group (keys %{$self->{groups} || {}}) {
        if (my ($realgroup) = $group =~ /(.*)_\d\d$/) {
            if (exists($self->{groups}{$realgroup}) &&
                $self->{groups}{$realgroup}{gid} == $self->{groups}{$group}{gid}) {
               # for sure, it's the same
                foreach (keys %{$self->{groups}{$group}{'users'} || {}}) {
                    $self->{groups}{$realgroup}{'users'}{$_} = 1;
                }
                delete($self->{groups}{$group});
            }
        }
    }

    # using shadow ? then reading shadow file
    if ($self->{use_shadow}) {

    $self->_load_unix_file(
        $self->{shadow},
        sub {
            my @ch = @_;
            my $user = $ch[0];
            foreach (@shadow_fields) {
                $self->{users}{$user}{$_} = shift(@ch);
            }
            if ($self->{users}{$user}{spassword} =~ /^!!/) {
                $self->{users}{$user}{spassword} =~ s/^!!//;
                $self->{users}{$user}{locked} = 1;
            }
        }
    ) or return;

    $self->_load_unix_file(
        $self->{gshadow},
        sub {
            my @ch = @_;
            my $group = $ch[0];
            # TODO add check ?
            foreach (@gshadow_fields) {
                $self->{groups}{$group}{$_} = shift(@ch);
            }
            # split user in the group
            foreach (split(',', $self->{groups}{$group}{'suser_list'} || '')) {
                $self->{groups}{$group}{'susers'}{$_} = 1;
            }
        }
    ) or return;

    } # use shadow ?

    $self->{_loaded} = 1;

    1;
}

sub _save_unix_file {
    my ($self, $file, @data) = @_;
    my $enc = find_encoding($self->config('encoding') || 'iso-8859-14')
        or do {
        $self->log(LA_ERROR, "Cannot find encoding %s", $self->config('encoding') || 'iso-8859-15');
        return;
    };
    open(my $handle, '>>', $file) or do {
        la_log(LA_ERR, "Cannot open unix file `%s' for writing (%s)", $file, $!);
        return;
    };
    flock($handle, LOCK_EX);
    truncate($handle, 0);
    foreach my $line (@data) {
        my $string = join(':', map { my $f = $_; $f =~ s/:/;/g; $f } map { defined($_) ? $_ : '' } @$line) . "\n";
        $string = decode('utf8', $string);
        print $handle $string;
    }
    close($handle);
    $self->log(LA_INFO, $file . " saved");
    return 1;
}

sub _commit {
    my ($self) = @_;

    $self->_save_unix_file(
        $self->{passwd},
        map {[
            $_,
            ($self->{users}{$_}{locked}
                ? '!!' . ($self->{users}{$_}{password} || '')
                : ($self->{users}{$_}{password} || 'x')), # No empty pass !!
            $self->{users}{$_}{uid},
            $self->{users}{$_}{gid},
            $self->{users}{$_}{gecos} || '',
            $self->{users}{$_}{home} || '/dev/null',
            ($self->{users}{$_}{locked} ? '-' : '') . ($self->{users}{$_}{shell}
                || '/bin/false'),
        ]} sort { $self->{users}{$a}{uid} <=> $self->{users}{$b}{uid} } keys %{$self->{users}}
    ) or return;

    my @grouplines = ();
    foreach (
        sort {  $self->{groups}{$a}{gid} <=> $self->{groups}{$b}{gid} }
        keys %{$self->{groups}}) {
        my @gline = ($_, $self->{groups}{$_}{password} || 'x',
            $self->{groups}{$_}{gid},
            join(',', sort keys %{$self->{groups}{$_}{users} || {}}),
        );
        if (length(join(':', @gline)) >= 1023) {
            $self->{nis_overflow} ||= '';
            if ($self->{nis_overflow} eq 'kill') {
                $gline[3] = 'LINE_TOO_LONG';
            } elsif ($self->{nis_overflow} eq 'truncate') {
                my $len = length(join(':', @gline[0 .. 2])) + 1;
                my @users = sort keys %{$self->{groups}{$_}{users} || {}};
                while (@users && $len + length(join(',', @users)) >= 1023) {
                    pop(@users);
                }
                $gline[3] = join(',', @users);
            } elsif($self->{nis_overflow} eq 'split') {
                my @users = sort keys %{$self->{groups}{$_}{users} || {}};
                my $count = 0;
                my @nextusers;
                while (my $u = shift(@users)) {
                    my $needflush = 0;
                    if (length(join(':', @gline[0 .. 2])) + 1 +
                        length(join(',', (@nextusers, $u))) >= 1023) {
                        unshift(@users, $u);
                        $needflush = 1;
                    } else {
                        push(@nextusers, $u);
                    }
                    if (!@users || $needflush) {
                        push(@grouplines, [
                            $gline[0] . ($count ? sprintf('_%02d', $count) :''),
                            $gline[1],
                            $gline[2],
                            join(',', @nextusers) ]
                        );
                        @nextusers = (); $count++;
                    }
                }
                next;
            }
        }
        push(@grouplines, \@gline);
    }
    $self->_save_unix_file(
        $self->{group},
        @grouplines,
    ) or return;

    if ($self->{use_shadow}) {

    $self->_save_unix_file(
        $self->{shadow},
        map {[
            $_,
            ($self->{users}{$_}{locked}
                ? '!!' . ($self->{users}{$_}{spassword} || '')
                : $self->{users}{$_}{spassword} || 'x'),
            $self->{users}{$_}{last_changed},
            $self->{users}{$_}{before_ch},
            $self->{users}{$_}{after_ch},
            $self->{users}{$_}{exp_warn},
            $self->{users}{$_}{exp_disable},
            $self->{users}{$_}{disable},
            $self->{users}{$_}{res},
        ]} sort { $self->{users}{$a}{uid} <=> $self->{users}{$b}{uid} } keys %{$self->{users}}
    ) or return;


    $self->_save_unix_file(
        $self->{gshadow},
        map {[
            $_,
            $self->{groups}{$_}{spassword} || 'x',
            $self->{groups}{$_}{unknown},
            join(',', keys %{$self->{groups}{$_}{susers} || {}}), 
        ]} sort {  $self->{groups}{$a}{gid} <=> $self->{groups}{$b}{gid} } keys %{$self->{groups}}
    ) or return;

    } # If use shadow

    1
}

sub list_objects {
    my ($self, $otype) = @_;

    # objects are store into sub ref:
    my $internal_obj = {
        user => 'users',
        group => 'groups',
    }->{$otype};
    my @obj = sort keys %{$self->{$internal_obj} || {} };
    for ($otype) {
        /^user$/ and
            return grep { $self->{$internal_obj}{$_}{uid} >= ($self->{min_uid} || 0) } @obj;
        /^group$/ and
            return grep { $self->{$internal_obj}{$_}{gid} >= ($self->{min_gid} || 0) } @obj;
    }
}

sub create_object {
    my ($self, $otype, $id, %data) = @_;

    # objects are store into sub ref:
    my $internal_obj = {
        user => 'users',
        group => 'groups',
    }->{$otype};
    for ($otype) {
        /^user$/ && !defined($data{uid}) && !defined($data{gid}) and return;
        /^group$/ && !defined($data{gid}) and return;
    }

    if ($self->{$internal_obj}{$id}) { return };
    $self->{$internal_obj}{$id} = {
        account => $id,
        uid => $data{uid},
        gid => $data{gid},
    };
    my $obj = $self->get_object($otype, $id) or return;
    $obj->set_fields(%data) or return;
    $obj
}

sub _delete_object {
    my ($self, $otype, $id, %data) = @_;

    # objects are store into sub ref:
    my $internal_obj = {
        user => 'users',
        group => 'groups',
    }->{$otype};
    delete $self->{$internal_obj}{$id};
    1
}

sub _rename_object {
    my ($self, $otype, $id, $newid) = @_;
    my $internal_obj = {
        user => 'users',
        group => 'groups',
    }->{$otype};
    
    if (exists($self->{$internal_obj}{$newid})) {
        $self->log(LA_ERR, 'cannot rename %s/%s, %s already exists',
            $otype, $id, $newid);
        return;
   }

   $self->{$internal_obj}{$newid} = $self->{$internal_obj}{$id};
   delete($self->{$internal_obj}{$id});

   1
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.


=cut