package LISM::Handler::Rewrite;

use strict;
use base qw(LISM::Handler);
use Net::LDAP::Constant qw(:all);
use Net::LDAP::Filter;
use Encode;
use LISM::Storage;
use Data::Dumper;

=head1 NAME

LISM::Handler::Rewrite - Handler to do script

=head1 DESCRIPTION

This class implements the L<LISM::Hanlder> interface to do script.

=head1 METHODS

=pod

=head2 pre_bind($binddnp)

Rewrite bind dn before bind operation is done.

=cut

sub pre_bind
{
    my $self = shift;
    my ($binddnp) = @_;
    my $conf = $self->{_config};

    foreach my $rule (@{$conf->{rewrite}}) {
        if ($rule->{context} eq 'request' || $rule->{context} eq 'bindRequest') {
            if (defined($rule->{dn}) && ${$binddnp} !~ /$rule->{dn}/i) {
                next;
            }

            my $substitution = $rule->{substitution};
            $substitution = $self->_rewritePattern($substitution, '%0', ${$binddnp});

            my $str = $self->_rewriteParse($rule->{match}, $substitution, ${$binddnp});
            if (!$str) {
                $self->log(level => 'err', message => "bind rewrite \"${$binddnp}\" failed");
                return LDAP_OPERATIONS_ERROR;
            }
            (${$binddnp}) = split(/\n/, $str);
        }
    }

    return LDAP_SUCCESS;
}

=head2 pre_compare($dnp, $avaStrp)

Rewrite dn and attribute, value before compare operation is done.

=cut

sub pre_compare
{
    my $self = shift;
    my ($dnp, $avaStrp) = @_;
    my $conf = $self->{_config};

    foreach my $rule (@{$conf->{rewrite}}) {
        if ($rule->{context} eq 'request' || $rule->{context} eq 'compareRequest') {
            if (defined($rule->{dn}) && ${$dnp} !~ /$rule->{dn}/i) {
                next;
            }

            my %rwcache;
            my $substitution = $rule->{substitution};
            $substitution = $self->_rewritePattern($substitution, '%0', "${$dnp}\n${$avaStrp}");

            my $str = $self->_rewriteParse($rule->{match}, $substitution, ${$dnp}, \%rwcache);
            if (!$str) {
                $self->log(level => 'err', message => "compare rewrite \"${$dnp}\" failed");
                return LDAP_OPERATIONS_ERROR;
            }
            (${$dnp}) = split(/\n/, $str);

            $str = $self->_rewriteParse($rule->{match}, $substitution, ${$avaStrp}, \%rwcache);
            if (!$str) {
                $self->log(level => 'err', message => "compcare rewrite \"${$dnp}\" failed");
                return LDAP_OPERATIONS_ERROR;
             }
             (${$avaStrp}) = split(/\n/, $str);
        }
    }

    return LDAP_SUCCESS;
}

=head2 pre_search($basep, $filterStrp)

Rewrite base dn and filter before search operation is done.

=cut

sub pre_search
{
    my $self = shift;
    my ($basep, $filterStrp) = @_;
    my $conf = $self->{_config};

    foreach my $rule (@{$conf->{rewrite}}) {
        if ($rule->{context} eq 'request' || $rule->{context} eq 'searchRequest') {
            if (defined($rule->{dn}) && ${$basep} !~ /$rule->{dn}/i) {
                next;
            }

            my %rwcache;
            my $substitution = $rule->{substitution};

            $substitution = $self->_rewritePattern($substitution, '%0', "${$basep}\n${$filterStrp}");
            my $str = $self->_rewriteParse($rule->{match}, $substitution, ${$basep}, \%rwcache);
            if (!defined($str)) {
                $self->log(level => 'err', message => "search rewrite \"${$basep}\" failed");
                return LDAP_OPERATIONS_ERROR;
            }
            (${$basep}) = split(/\n/, $str);

            my @elts = (${$filterStrp} =~ /\(([^()]+)\)/g);
            for (my $i = 0; $i < @elts; $i++) {
                $str = $self->_rewriteParse($rule->{match}, $substitution, $elts[$i], \%rwcache);
                if (!defined($str)) {
                    $self->log(level => 'err', message => "search rewrite \"${$filterStrp}\" failed");
                   return LDAP_OPERATIONS_ERROR;
                }

                my $elt;
                foreach my $line (split(/\n/, $str)) {
                    if ($elt) {
                        $elt = "(&$elt($line))";
                    } else {
                        $elt = "($line)";
                    }
                }

                $elts[$i] =~ s/([.*+?\[\]()|\^\$\\])/\\$1/g;
                ${$filterStrp} =~ s/\($elts[$i]\)/$elt/;
            }
        }
    }

    return LDAP_SUCCESS;
}

=head2 post_search($entriesp, $attrsp)

Rewrite search results.

=cut

sub post_search
{
    my $self = shift;
    my ($entriesp, $attrsp) = @_;
    my $conf = $self->{_config};

    foreach my $rule (@{$conf->{rewrite}}) {
        if ($rule->{context} eq 'searchResult') {
            if (defined($rule->{attrs}) && @{$attrsp} && !grep(/$rule->{attrs}/i, @{$attrsp})) {
                next;
            }

            my %rwcache;
            for (my $i = 0; $i < @{$entriesp}; $i++) {
                my $entryStr = ${$entriesp}[$i];
                my (@line) = split(/\n/, $entryStr);
                my ($dn) = ($line[0] =~ /^dn: (.*)$/);
                if (defined($rule->{dn}) && $dn !~ /$rule->{dn}/i) {
                    next;
                }
                if (defined($rule->{filter}) && !LISM::Storage->parseFilter($rule->{filterobj}, $entryStr)) {
                    next;
                }

                my $rc = 0;
                my $substitution = $rule->{substitution};
                $substitution = $self->_rewritePattern($substitution, '%0', $entryStr);

                my $str = $self->_rewriteParse($rule->{match}, $substitution, $dn, \%rwcache);
                if (!$str) {
                    $self->log(level => 'err', message => "search result rewrite \"$dn\" failed");
                    next;
                }
                $line[0] = "dn: $str";

                my @replaced;
                for (my $j = 1; $j < @line; $j++) {
                    $line[$j] = $self->_rewriteParse($rule->{match}, $substitution, $line[$j], \%rwcache);
                    if (!defined($line[$j])) {
                        $self->log(level => 'err', message => "search result rewrite \"$dn\" failed");
                        $rc = -1;
                        last;
                    } elsif ($line[$j]) {
                        push(@replaced, split(/\n/, $line[$j]));
                    }
                }
                if (!$rc) {
                    ${$entriesp}[$i] = "$line[0]\n".join("\n", $self->_unique(@replaced))."\n";
                }
            }
        }
    }

    return LDAP_SUCCESS;
}

=pod

=head2 pre_modify($dnp, $listp)

Rewrite dn and attributes, values before modify operation is done.

=cut

sub pre_modify
{
    my $self = shift;
    my ($dnp, $listp) = @_;
    my $conf = $self->{_config};

    foreach my $rule (@{$conf->{rewrite}}) {
        if ($rule->{context} eq 'request' || $rule->{context} eq 'modifyRequest') {
            if (defined($rule->{dn}) && ${$dnp} !~ /$rule->{dn}/i) {
                next;
            }

            my %rwcache;
            my $substitution = $rule->{substitution};
            my $modlist = "${$dnp}\n".join("\n", @{$listp});
            $substitution = $self->_rewritePattern($substitution, '%0', $modlist);

            my $str = $self->_rewriteParse($rule->{match}, $substitution, ${$dnp}, \%rwcache);
            if (!$str) {
                $self->log(level => 'err', message => "modify rewrite \"${$dnp}\" failed");
                return LDAP_OPERATIONS_ERROR;
            }
            (${$dnp}) = split(/\n/, $str);

            my @mod_list;
            while (@{$listp} > 0) {
                my $action = shift @{$listp};
                my $attr = shift @{$listp};
                my @values;
                my %replaced;

                $str = $self->_rewriteParse($rule->{match}, $substitution, "$action: $attr");
                ($attr) = ($str =~ /^[^:]+: (.*)$/);
                while (@{$listp} > 0 && ${$listp}[$0] !~ /ADD|DELETE|REPLACE/) {
                    push(@values, shift @{$listp});
                }

                if (defined($rule->{modop}) && $rule->{modop} !~ /$action/i) {
                    push(@mod_list, ($action, $attr, @values));
                } elsif (@values) {
                    for (my $i =0; $i < @values; $i++) {
                        $str = $self->_rewriteParse($rule->{match}, $substitution, "$attr: ".$values[$i], \%rwcache);
                        if (!defined($str)) {
                            $self->log(level => 'err', message => "modify rewrite \"${$dnp}\" failed");
                            return LDAP_OPERATIONS_ERROR;
                        } elsif ($str) {
                            foreach my $line (split(/\n/, $str)) {
                                my ($rwattr, $value) = ($line =~ /(^[^:]*): (.*)$/);
                                if (!defined($replaced{$rwattr})) {
                                    @{$replaced{$rwattr}} = ();
                                }
                                push(@{$replaced{$rwattr}}, $value);
                            }
                        }
                    }
                    foreach my $rwattr (keys %replaced) {
                        push(@mod_list, ($action, $rwattr, $self->_unique(@{$replaced{$rwattr}})));
                    }
                } else {
                    push(@mod_list, ($action, $attr));
                }
            }
            @{$listp} = @mod_list;
        }
    }

    return LDAP_SUCCESS;
}

=pod

=head2 pre_add($dnp, $entryStrp)

Rewrite entry before add operation is done.

=cut

sub pre_add
{
    my $self = shift;
    my ($dnp, $entryStrp) = @_;
    my $conf = $self->{_config};

    foreach my $rule (@{$conf->{rewrite}}) {
        if ($rule->{context} eq 'request' || $rule->{context} eq 'addRequest') {
            if (defined($rule->{dn}) && ${$dnp} !~ /$rule->{dn}/i) {
                next;
            }
            if (defined($rule->{filter}) && !LISM::Storage->parseFilter($rule->{filterobj}, "${$dnp}\n${$entryStrp}[0]")) {
                next;
            }

            my %rwcache;
            my $substitution = $rule->{substitution};
            $substitution = $self->_rewritePattern($substitution, '%0', "${$dnp}\n${$entryStrp}[0]");

            my $str = $self->_rewriteParse($rule->{match}, $substitution, ${$dnp}, \%rwcache);
            if (!$str) {
                $self->log(level => 'err', message => "add rewrite \"${$dnp}\" failed");
                return LDAP_OPERATIONS_ERROR;
            }
            (${$dnp}) = split(/\n/, $str);

            my (@line) = split(/\n/, ${$entryStrp}[0]);

            for (my $i = 0; $i < @line; $i++) {
                $line[$i] = $self->_rewriteParse($rule->{match}, $substitution, $line[$i], \%rwcache);
                if (!defined($line[$i])) {
                    $self->log(level => 'err', message => "add rewrite \"${$dnp}\" failed");
                    return LDAP_OPERATIONS_ERROR;
                }
            }
            ${$entryStrp}[0] = join("\n", $self->_unique(@line))."\n";
        }
    }

    return LDAP_SUCCESS;
}

=head2 pre_modrdn($dnp, $argsp)

Rewrite dn and new rdn before modrdn operation is done.

=cut

sub pre_modrdn
{
    my $self = shift;
    my ($dnp, $argsp) = @_;
    my $conf = $self->{_config};

    foreach my $rule (@{$conf->{rewrite}}) {
        if ($rule->{context} eq 'request' || $rule->{context} eq 'modrdnRequest') {
            if (defined($rule->{dn}) && ${$dnp} !~ /$rule->{dn}/i) {
                next;
            }

            my %rwcache;
            my $substitution = $rule->{substitution};
            $substitution = $self->_rewritePattern($substitution, '%0', "${$dnp}\n${$argsp}[0]");

            my $str = $self->_rewriteParse($rule->{match}, $substitution, ${$dnp}, \%rwcache);
            if (!$str) {
                $self->log(level => 'err', message => "modrdn rewrite \"${$dnp}\" failed");
                return LDAP_OPERATIONS_ERROR;
            }
            (${$dnp}) = split(/\n/, $str);

            $str = $self->_rewriteParse($rule->{match}, $substitution, ${$argsp}[0], \%rwcache);
            if (!$str) {
                $self->log(level => 'err', message => "modrdn rewrite \"${$dnp}\" failed");
                return LDAP_OPERATIONS_ERROR;
            }
            ${$argsp}[0] = $str;
        }
    }

    return LDAP_SUCCESS;
}

=pod

=head2 pre_delete($dnp)

Rewrite dn before delete operation is done.
    
=cut
    
sub pre_delete
{
    my $self = shift;
    my ($dnp) = @_;
    my $conf = $self->{_config};

    foreach my $rule (@{$conf->{rewrite}}) {
        if ($rule->{context} eq 'request' || $rule->{context} eq 'deleteRequest') {
            if (defined($rule->{dn}) && ${$dnp} !~ /$rule->{dn}/i) {
                next;
            }

            my %rwcache;
            my $substitution = $rule->{substitution};
            $substitution = $self->_rewritePattern($substitution, '%0', ${$dnp});

            my $str = $self->_rewriteParse($rule->{match}, $substitution, ${$dnp}, \%rwcache);
            if (!$str) {
                $self->log(level => 'err', message => "delete rewrite \"${$dnp}\" failed");
                return LDAP_OPERATIONS_ERROR;
            }
            (${$dnp}) = split(/\n/, $str);
        }
    }

    return LDAP_SUCCESS;
}


sub _checkConfig
{
    my $self = shift;
    my $conf = $self->{_config};
    my $rc = 0;

    if ($rc = $self->SUPER::_checkConfig()) {
        return $rc;
    }

    if (defined($conf->{libload})) {
        foreach my $lib (@{$conf->{libload}}) {
            eval "do \'$lib\'";
            if ($@) {
                $self->log(level => 'alert', message => "rewrite do require $lib: $@");
                return 1;
            }
        }
    }

    if (defined($conf->{rewritemap})) {
        foreach my $map_name (keys %{$conf->{rewritemap}}) {
            my $type = $conf->{rewritemap}{$map_name}->{type};
            if ($type eq 'ldap') {
                if (!defined($self->{ldapmap})) {$self->{ldapmap} = {}};
                my $ldapmap = {};
                $self->_parseLdapUri($ldapmap, $conf->{rewritemap}{$map_name}->{attrs});
                $self->{ldapmap}{$map_name} = $ldapmap;
            } elsif ($type eq 'lism') {
                if (!defined($self->{lismmap})) {$self->{lismmap} = {}};
                my $lismmap = {};
                my ($base, $attr, $scope, $sizelimit) = split(/\?/, $conf->{rewritemap}{$map_name}->{attrs});
                $lismmap->{base} = $base;
                $lismmap->{attr} = $attr;
                if ($scope) {
                    $lismmap->{scope} = $scope;
                }
                if ($sizelimit) {
                    $lismmap->{sizelimit} = $sizelimit;
                }
                $self->{lismmap}{$map_name} = $lismmap;
            }
        }
    }

    if (defined($conf->{rewrite})) {
        foreach my $rule (@{$conf->{rewrite}}) {
            if (defined($rule->{filter})) {
                $rule->{filter} =~ s/&amp;/&/g;
                $rule->{filterobj} = Net::LDAP::Filter->new(encode('utf8', $rule->{filter}));
            }
            if (defined($rule->{attrs})) {
                $rule->{attrs} =~ s/,/|/;
                $rule->{attrs} = '^('.$rule->{attrs}.')$';
            }

            # enable escape sequence
            $rule->{substitution} =~ s/([^\\])\\n/$1\n/g;
            $rule->{substitution} =~ s/([^\\])\\t/$1\t/g;
            $rule->{substitution} =~ s/&amp;/&/g;
        }
    }

    return $rc;
}

sub _rewritePattern
{
    my $self = shift;
    my ($str, $pattern, $value) = @_;

    my @rwmaps = ($str =~ /%{([^(]*\((?:(?!%{).)*\))}/gs);
    foreach my $rwmap (@rwmaps) {
        my $tmpstr = $rwmap;
        my $tmpval = $value;
        my $qt = '';
        if ($rwmap =~ /'[^']*$pattern[^']*'/) {
            $qt = '\'';
        } elsif ($rwmap =~ /"[^"]*$pattern[^"]*"/) {
            $qt = '"';
        }

        if ($qt) {
            $tmpval =~ s/$qt/\\$qt/g;
            $tmpstr =~ s/$pattern/$tmpval/g;
        }
        $rwmap =~ s/([.*+?\[\]()|\^\$\\])/\\$1/g;
        $str =~ s/%{$rwmap}/%{$tmpstr}/;
    }

    $str =~ s/$pattern/$value/g;
    return $str;
}

sub _rewriteParse
{
    my $self = shift;
    my ($match, $substitution, $str, $rwcache) = @_;
    my $newstr;

    my @matches = ($str =~ /$match/gi);
    if (!@matches) {
         return $str;
    }

    # replace variables
    for (my $i = 0; $i < @matches; $i++) {
        my $num = $i + 1;
        while ($substitution =~ /%$num/) {
            $substitution = $self->_rewritePattern($substitution, "%$num", $matches[$i]);
        }
    }

    foreach my $substline ($self->_splitSubst($substitution)) {
        my $oldstr = $str;

        # do functions
        my @substs = ($substline);
        my @rwmaps = ($substline =~ /%{([^(]*\((?:(?!%{).)*\))}/gs);
        foreach my $rwmap (@rwmaps) {
            my @values;
            my $key = lc($rwmap);

            if (defined(${$rwcache}{$key})) {
                @values = @{${$rwcache}{$key}};
            } else {
                my ($map_name, $map_args) = ($rwmap =~ /^([^(]*)\((.*)\)$/s);
                if (!$map_name) {
                    return undef;
                }

                @values = $self->_rewriteMap($map_name, $map_args);
                if (!defined($values[0])) {
                    return undef;
                }

                ${$rwcache}{$key} = \@values;
            }

            if ($values[0] eq '') {
                return $str;
            }

            $rwmap =~ s/([.*+?\[\]()|\^\$\\])/\\$1/g;
            my @tmpsubsts;
            foreach my $subst (@substs) {
                foreach my $value (@values) {
                    my $tmpsubst = $subst;
                    $tmpsubst =~ s/%{$rwmap}/$value/;
                    push(@tmpsubsts, $tmpsubst);
                }
            }
            undef(@substs);
            @substs = @tmpsubsts;
        }

        my @strs;
        foreach my $subst (@substs) {
            my $tmpstr = $oldstr;
            $tmpstr =~ s/$match/$subst/gi;
            push(@strs, $tmpstr);
        }
        if ($newstr) {
            $newstr = "$newstr\n".join("\n", @strs);
        } else {
            $newstr = join("\n", @strs);
        }
    }

    return $newstr;
}

sub _splitSubst
{
    my $self = shift;
    my ($substitution) = @_;
    my @substs;

    my $prevpos = 0;
    my $oldpos = 0;
    while ((my $pos = index($substitution, "\n", $oldpos)) > 0) {
        my $str = substr($substitution, $prevpos, $pos - $prevpos);
        if (index($str, "%{", $oldpos - $prevpos) > 0) {
            if (index($str, "(", $oldpos - $prevpos) > 0) {
                 $oldpos = $self->_passArgs($substitution, $oldpos);
            }
            $oldpos = index($substitution, "}", $oldpos);
            next;
        }
        push(@substs, $str);
        $prevpos = $oldpos = $pos + 1;
    }
    push(@substs, substr($substitution, $prevpos));

    return @substs;
}

sub _passArgs
{
    my $self = shift;
    my ($str, $oldpos) = @_;
    my $pos = $oldpos;

    $pos = index($str, "(", $pos);
    if ($pos < 0) {
        return $pos;
    }

    my $leftstr = substr($str, $pos + 1);
    my ($qtchar) = ($leftstr =~ /^ *(['"])/);

    while ($qtchar) {
        while (1) {
            $pos = index($str, $qtchar, $pos);
            my $tmppos = index($str, $qtchar, $pos);
            if ($tmppos < 0) {
                last;
            }
            $pos = $tmppos + 1;

            if (substr($str, $tmppos - 1, 1) eq "\\") {
                next;
            }
            last;
        }
        $leftstr = substr($str, $pos);
        ($qtchar) = ($leftstr =~ / *(['"])/);
    }

    $pos = index($str, ")", $pos);
    if ($pos < 0) {
        $pos = $oldpos;
    }

    return $pos;
}

sub _rewriteMap
{
    my $self = shift;
    my ($map_name, $map_args) = @_;
    my $conf = $self->{_config};
    my @values = ();

    if (defined($conf->{rewritemap}{$map_name})) {
        my $method = '_'.$conf->{rewritemap}{$map_name}->{type}.'Map';
        @values = $self->$method($map_name, $map_args);
    }

    return @values;
}

sub _ldapMap
{
    my $self = shift;
    my ($map_name, $map_args) = @_;
    my $ldapmap = $self->{ldapmap}{$map_name};

    return $self->_searchLdap($ldapmap, $map_args);
}

sub _lismMap
{
    my $self = shift;
    my ($map_name, $map_args) = @_;
    my $lismmap = $self->{lismmap}{$map_name};

    return $self->_searchLism($lismmap, $map_args);
}

sub _functionMap
{
    my $self = shift;
    my ($map_name, $map_args) = @_;
    my @values;

    eval "\@values = $map_name($map_args)";
    if ($@) {
        $self->log(level => 'err', message => "rewriteMap $map_name failed: $@");
        return undef;
    }

    return @values;
}

sub _regexpMap
{
    my $self = shift;
    my ($map_name, $map_args) = @_;
    my $conf = $self->{_config};

    return ($map_args =~ /$conf->{rewritemap}{$map_name}->{attrs}/gi);
}

=head1 SEE ALSO

L<LISM>,
L<LISM::Handler>

=head1 AUTHOR

Kaoru Sekiguchi, <sekiguchi.kaoru@secioss.co.jp>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006 by Kaoru Sekiguchi

This library is free software; you can redistribute it and/or modify
it under the GNU LGPL.

=cut

1;
