package Fripost::Schema::Util;

=head1 NAME

Util.pm -

=cut

use 5.010_000;
use strict;
use warnings;
use utf8;

use Exporter 'import';
our @EXPORT_OK = qw /mandatory_attrs domain_valid email_valid split_addr dn2mail
                     canonical_dn ldap_explode_dn ldap_error ldap_and_filter
                     ldap_clean_entry escape_filter_nostar
                     assert ldap_assert_absent softdie/;
use Email::Valid;
use Net::IDN::Encode qw/domain_to_unicode email_to_unicode
                        domain_to_ascii email_to_ascii/;
use Net::LDAP::Util;
use Encode;




# "&must_att $h qw/a b c .../" ensures that attributes a b c... are all
# defined in the hash reference.
sub mandatory_attrs {
    my $h = shift;
    foreach (@_) {
        die 'Missing value: ‘'.$_."’\n"
            unless defined $h->{$_} and
                   (ref $h->{$_} eq 'ARRAY' ? @{$h->{$_}} : $h->{$_} ne '')
    }
}


# Ensure that the first argument is a valid email.
# '-exact' forces the input to be a bare email, ("name <email>" is not
# allowed).
sub email_valid {
    my $in = shift;
    my %options = @_;

    my $i = $in;
    $in = 'fake'.$i if defined $options{'-allow-empty-local'} and $i =~ /^\@/;
    my $mesg = $options{'-error'} // "Invalid e-mail";
    Encode::_utf8_on($in);
    Encode::_utf8_on($i);

    my ($addr, $match);
    eval {
        $in = Net::IDN::Encode::email_to_ascii($in);
        $addr = Email::Valid::->address( -address => $in,
                                         -tldcheck => 1,
                                         -fqdn => 1 );
        $match = defined $addr;
        $match &&= $addr eq $in
            if $options{'-exact'} or $options{'-allow-empty-local'};
    };
    if ($@ || !$match) {
      return if $options{'-nodie'};
      die $mesg." ‘".$i."’\n";
    }
    $addr =~ s/^fake\@/\@/ if defined $options{'-allow-empty-local'};
    return $addr;
}

sub domain_valid {
    my $in = shift;
    Encode::_utf8_on($in);
    my %options = @_;

    my $domainname = Net::IDN::Encode::domain_to_ascii($in);
    my $fake = 'fake@'.$domainname;
    my $addr = Email::Valid::->address( -address => $fake
                                      , -tldcheck => 1
                                      , -fqdn => 1 );
    unless (defined $addr and $addr eq $fake) {
        return if $options{'-nodie'};
        my $mesg = $options{'-die'} // "Invalid domain";
        die $mesg." ‘".$in."’\n";
    }
    return $domainname;
}

sub canonical_dn {
    Net::LDAP::Util::canonical_dn(\@_, casefold => 'lower'
                                     , mbcescape => 1
                                     , reverse => 0
                                     , separator => ',');
};

sub ldap_explode_dn {
    Net::LDAP::Util::ldap_explode_dn( join (',', @_), casefold => 'lower' )
}

sub split_addr {
    my $addr = shift // return;
    my %options = @_;

    Encode::_utf8_on($addr);
    my $mesg = $addr =~ /\@/ ? "Invalid e-mail ‘".$addr."’" :
                               "Invalid domain ‘".$addr."’";
    my $ret;
    if (defined $options{'-encode'}) {
        my $e = $options{'-encode'};
        if ($e eq 'ascii') {
            eval { $addr = $addr =~ /\@/ ? email_to_ascii($addr)
                                         : domain_to_ascii($addr);
            };
            $ret = $@;
        }
        elsif ($e eq 'unicode') {
            eval { $addr = $addr =~ /\@/ ? email_to_unicode($addr)
                                         : domain_to_unicode($addr);
            };
            $ret = $@;
        }
        else {
            die "Unknown encoding ‘".$e."’";
        }
    }
    softdie ($mesg, %options) // return if $ret;
    return ('',$addr) unless $addr =~ /\@/;

    $addr =~ /^(.*)\@([^\@]+)$/;
    return ($1,$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;
    }

    &softdie( $error, %options );
}

sub softdie {
    my $mesg = shift;
    my %options = @_;

    return 1 unless $mesg;

    if (defined $options{'-error'}) {
        ${$options{'-error'}} = $mesg;
        return;
    }
    elsif (exists $options{'-error'}) {
        return; # Ignore the error
    }
    else {
        die $mesg, "\n";
    }
}

sub assert {
    my $what = shift;
    my %options = @_;

    return $what if $what;
    &softdie($options{'-die'} // "Not defined.", %options);
}

sub dn2mail {
    my $dn = ldap_explode_dn(shift);

    return '@'. domain_to_unicode(lc $dn->[0]->{fvd})
        if exists $dn->[0]->{fvd};
    return email_to_unicode(lc $dn->[0]->{fvl} .'@'. lc $dn->[1]->{fvd});
}

sub ldap_and_filter {
    my @filters = @_;

    if ($#filters == 0) {
        return $filters[0];
    }
    else {
        @filters = map { /^\(.*\)$/ ? $_ : '('.$_.')' } @filters;
        return '(&'.(join '', @filters).')';
    }
}


sub ldap_clean_entry {
    my $attrs = shift;

    foreach (keys %$attrs) {
        if (defined $attrs->{$_}) {
            if (ref $attrs->{$_} eq 'ARRAY') {
                delete $attrs->{$_} unless @{$attrs->{$_}}
            }
            elsif (ref $attrs->{$_} eq '') {
                delete $attrs->{$_} if $attrs->{$_} eq '';
            }
        }
        else {
            delete $attrs->{$_};
        }
    }
}

sub ldap_assert_absent {
    my $self = shift;
    my $name = shift;
    my $found = shift // "‘".$name."’ exists";
    my %options = @_;

    my $mesg = $self->ldap->search( base => $self->mail2dn( $name )
                                  , scope => 'base'
                                  , deref => 'never'
                                  , filter => '(objectClass=*)'
                                  , attrs => [ '1.1' ]
                                  );
    $options{'-die'} = { Net::LDAP::Constant::LDAP_NO_SUCH_OBJECT => 0
                       , Net::LDAP::Constant::LDAP_SUCCESS =>
                             $options{'-append'} ? 0 : $found
                       };
    ldap_error($mesg, %options) // return;
    return $mesg->code eq Net::LDAP::Constant::LDAP_SUCCESS ? 1 :
           $mesg->code eq Net::LDAP::Constant::LDAP_NO_SUCH_OBJECT ? 0 :
           undef
}


sub escape_filter_nostar {
  join '*', Net::LDAP::Util::escape_filter_value (split '\*', shift);
}

=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__