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 /concat get_perms explode
                     must_attrs email_valid
                     canonical_dn ldap_explode_dn
                     split_addr/;
use Email::Valid;
use Net::IDN::Encode;
use Net::LDAP::Util;
use Encode;


# Let the first argument, if defined, intersperse the other arguments.
sub concat {
    my $concat = shift;

    if (defined $concat) {
        return join ($concat, @_);
    }
    else {
        return [ @_ ];
    }
}

# The reverse of 'concat': takes a single line, and split it along
# "concat", if defined. Returns an array reference in any case.
sub explode {
    my $concat = shift;

    my $out;
    if (defined $concat) {
        $out = [ split /$concat/, $_[0] ];
    }
    else {
        $out = [ @_ ];
    }
    [ grep { !/^\s*$/ } @$out ];
}


# This subroutine displays the access that the given DN has on the entry.
# Possible values are :
# - '': no rights
# - a:  can create aliases
# - l:  can create lists
# - al: can create aliases & lists
# - o:  owner
# - p:  postmaster
sub get_perms {
    my ($entry, $dn) = @_;
    my @dn = @{ldap_explode_dn ($dn)};
    shift @dn;
    my $dn2 = canonical_dn (@dn);
    my $perms = '';

    $perms .= 'a'
        if grep { $dn eq $_  or  $dn2 eq $_ }
                $entry->get_value ('fripostCanAddAlias');

    $perms .= 'l'
        if grep { $dn eq $_  or  $dn2 eq $_ }
                $entry->get_value ('fripostCanAddList');

    $perms = 'o'
        if grep { $dn eq $_ } $entry->get_value('fripostOwner');

    $perms = 'p'
        if grep { $dn eq $_ } $entry->get_value('fripostPostmaster');

    return $perms;
}


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


# Ensure that the first argument is a valid email. Can also be used to
# check the validity of domains using the '-prefix' option.
# '-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;
    $i =~ s/^[^<>]+\s<([^>]+)>/$1/;
    my $mesg = $options{'-error'} // "Invalid e-mail";
    $in = $options{'-prefix'}.$i if defined $options{'-prefix'};
    Encode::_utf8_on($in);
    Encode::_utf8_on($i);
    $in = Net::IDN::Encode::email_to_ascii($in);

    my $addr = Email::Valid::->address( -address => $in,
                                        -tldcheck => 1,
                                        -fqdn => 1 );
    my $match = defined $addr;
    $match &&= $addr eq $in if $options{'-exact'};
    unless ($match) {
      return if $options{'-nodie'};
      die $mesg." ‘".$i."’\n";
    }
    $addr =~ s/^$options{'-prefix'}// if defined $options{'-prefix'};
    return $addr;
}

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;
    my %options = @_;

    if (defined $options{'-encode'}) {
        my $e = $options{'-encode'};
        if ($e eq 'ascii') {
            $addr = Net::IDN::Encode::email_to_ascii($addr);
        }
        elsif ($e eq 'unicode') {
            $addr = Net::IDN::Encode::email_to_unicode($addr);
        }
        else {
            die "Unknown encoding: ". $e;
        }
    }

    split /\@/, $addr, 2;
}


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