Parser.pm 5.79 KB
Newer Older
Yadd's avatar
Yadd committed
1
package Lemonldap::NG::Common::Combination::Parser;
Yadd's avatar
Yadd committed
2 3

use strict;
Yadd's avatar
Temp  
Yadd committed
4
use Moo;
Yadd's avatar
Yadd committed
5
use Safe;
Yadd's avatar
Yadd committed
6 7
use constant PE_OK => 0;

Yadd's avatar
Yadd committed
8 9
our $VERSION = '2.0.0';

Yadd's avatar
Yadd committed
10 11
# Handle "if then else" (used during init)
# return a sub that can be called with ($req) to get a [array] of combination
Yadd's avatar
Yadd committed
12
#
Yadd's avatar
Yadd committed
13 14 15 16 17 18 19 20 21 22 23 24 25 26
# During auth, these combinations represents "or" (like Multi)
# Each combination is a [authSub,userSub] called like this:
#      $authSub->('authenticate',$req)
# This means that the 'authenticate' method of the real auth module will be
# called with $req

sub parse {
    my ( $self, $moduleList, $expr ) = @_;

    my $sub  = '';
    my $rest = $expr;
    if ( $rest =~ s/^\s*if\s*\(// ) {
        my ( $cond, $then, $else );
        ( $cond, $rest ) = $self->findB( $rest, ')' );
Yadd's avatar
Yadd committed
27
        unless ( length $cond ) {
Yadd's avatar
Yadd committed
28
            die('Bad combination: unmatched bracket');
Yadd's avatar
Yadd committed
29
        }
Yadd's avatar
Yadd committed
30
        unless ( $rest =~ s/^\s*\bthen\b\s*// ) {
Yadd's avatar
Yadd committed
31
            die('Bad combination: missing "then"');
Yadd's avatar
Yadd committed
32
        }
Yadd's avatar
Tidy  
Yadd committed
33
        unless ( $rest =~ /(.*?)\s*\belse\b\s*(.*)$/ ) {
Yadd's avatar
Yadd committed
34 35
            die('Bad combination: missing "else"');
        }
Yadd's avatar
Tidy  
Yadd committed
36
        ( $then, $else ) = ( $1, $2 );
Yadd's avatar
Yadd committed
37
        unless ($then) {
Yadd's avatar
Yadd committed
38
            die('Bad combination: missing "then" content');
Yadd's avatar
Yadd committed
39 40
        }
        unless ($else) {
Yadd's avatar
Yadd committed
41
            die('Bad combination: missing "else" content');
Yadd's avatar
Yadd committed
42 43
        }

Yadd's avatar
Yadd committed
44 45
        $cond = $self->buildSub($cond);
        $then = $self->parseOr( $moduleList, $then );
Yadd's avatar
Yadd committed
46 47
        $else = $self->parse( $moduleList, $else );
        unless ( $then and $else ) {
Yadd's avatar
Yadd committed
48
            die('Bad combination: bad then or else');
Yadd's avatar
Yadd committed
49 50
        }
        return sub {
Yadd's avatar
Yadd committed
51 52
            my ($env) = @_;
            return ( $cond->($env) ? $then : $else->($env) );
Yadd's avatar
Yadd committed
53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
        };
    }
    else {
        my $res = $self->parseOr( $moduleList, $rest );
        return sub { $res };
    }
}

# Internal request to manage "or" boolean expr.
# Returns [ [authSub,userSub], [authSub,userSub] ] array
sub parseOr {
    my ( $self, $moduleList, $expr ) = @_;
    my @res;
    foreach my $part ( split /\s+or\s+/, $expr ) {
        push @res, $self->parseAnd( $moduleList, $part );
    }
    return \@res;
}

# Internal request to manage "and" boolean expr
# Returns [authSub,userSub] array
sub parseAnd {
    my ( $self, $moduleList, $expr ) = @_;
    if ( $expr =~ /\]\s*and\s*\[/ ) {
        my @mod = ( [], [] );
Yadd's avatar
Yadd committed
78
        foreach my $part ( split /\s*and\s*/, $expr ) {
Yadd's avatar
Yadd committed
79 80 81 82 83 84 85
            my $tmp = $self->parseBlock( $moduleList, $part );
            push @{ $mod[0] }, $tmp->[0];
            push @{ $mod[1] }, $tmp->[1];
        }
        my @res;
        foreach my $type (@mod) {
            push @res, sub {
86
                my %str;
Yadd's avatar
Yadd committed
87
                foreach my $obj (@$type) {
Yadd's avatar
Yadd committed
88
                    my ( $r, $name ) = $obj->(@_);
89 90 91 92 93 94 95 96

                    # Case "string" (form type)
                    if ( $r & ~$r ) {
                        $str{$r}++;
                    }
                    else {
                        return ( $r, $name ) unless ( $r == PE_OK );
                    }
Yadd's avatar
Yadd committed
97
                }
98
                return ( ( %str ? join( ',', keys %str ) : PE_OK ), $expr );
Yadd's avatar
Yadd committed
99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
            };
        }
        return \@res;
    }
    else {
        return $self->parseBlock( $moduleList, $expr );
    }
}

# Internal method to parse [AuthModule,UserModule] expr
# Returns [authSub,userSub] array
sub parseBlock {
    my ( $self, $moduleList, $expr ) = @_;
    unless ( $expr =~ /^\s*\[(.*?)\s*(?:,\s*(.*?))?\s*\]\s*$/ ) {
        die "Bad expression: $expr";
    }
    my @res = ( $1, $2 || $1 );
Yadd's avatar
Tidy  
Yadd committed
116 117 118 119
    @res = (
        $self->parseMod( $moduleList, 0, $res[0] ),
        $self->parseMod( $moduleList, 1, $res[1] )
    );
Yadd's avatar
Yadd committed
120 121 122 123 124 125 126
    return \@res;
}

# Internal method to parse auth or userDB expr
# These expressions can be "LDAP" or "LDAP and DBI"
# Return sub
sub parseMod {
Yadd's avatar
Yadd committed
127
    my ( $self, $moduleList, $type, $expr ) = @_;
Yadd's avatar
Yadd committed
128
    my @list = split( /\s+and\s+/, $expr );
Yadd's avatar
Yadd committed
129
    my @mods = map {
Yadd's avatar
Yadd committed
130
        die "Undeclared module $_"
Yadd's avatar
Yadd committed
131 132
          unless ( $moduleList->{$_}->[$type] );
        $moduleList->{$_}->[$type]
Yadd's avatar
Yadd committed
133
    } @list;
Yadd's avatar
Yadd committed
134 135 136 137
    if ( @mods == 1 ) {
        my ($m) = @mods;
        return sub {
            my ( $sub, $req ) = @_;
Yadd's avatar
Yadd committed
138
            return ( $m->$sub($req), $expr );
Yadd's avatar
Yadd committed
139 140 141 142
        };
    }
    return sub {
        my ( $sub, $req ) = @_;
143
        my %str;
Yadd's avatar
Yadd committed
144 145
        for ( my $i = 0 ; $i < @list ; $i++ ) {
            my $res = $mods[$i]->$sub($req);
146 147 148 149 150 151 152 153

            # Case "string" (form type)
            if ( $res & ~$res ) {
                $str{$res}++;
            }
            else {
                return ( $res, $list[$i] ) unless ( $res == PE_OK );
            }
Yadd's avatar
Yadd committed
154
        }
155
        return ( ( %str ? join( ',', keys %str ) : PE_OK ), $expr );
Yadd's avatar
Yadd committed
156 157 158 159 160 161 162 163
    };
}

# Internal request to find brackets
sub findB {
    my ( $self, $expr, $char ) = @_;
    my $res;
    my @chars = split //, $expr;
Yadd's avatar
Yadd committed
164 165
    while (@chars) {
        my $c = shift @chars;
Yadd's avatar
Yadd committed
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
        if ( $c eq "\\" ) {
            $res .= $c . shift(@chars);
            next;
        }
        if ( $c eq $char ) {
            my $rest = join( '', @chars );
            $res =~ s/^\s*(.*?)\s*/$1/;
            $rest =~ s/^\s*(.*?)\s*/$1/;
            return ( $res, $rest );
        }
        if ( $c =~ /^(?:\(|\{|\[|'|")$/ ) {
            my $wanted = {
                '(' => ')',
                '{' => '}',
                '[' => ']',
                "'" => "'",
                '"' => '"'
            }->{$c};
            my ( $m, $rest ) =
              $self->findB( join( '', @chars ), $wanted );
Yadd's avatar
Yadd committed
186
            unless ( length $m ) {
Yadd's avatar
Yadd committed
187
                die("Bad combination: unmatched $c");
Yadd's avatar
Yadd committed
188 189 190 191 192 193 194 195 196 197
            }
            $res .= "$c$m$wanted";
            @chars = split //, $rest;
            next;
        }
        $res .= $c;
    }
    return undef;
}

Yadd's avatar
Yadd committed
198 199 200 201
# Compiles condition into sub
sub buildSub {
    my ( $self, $cond ) = @_;
    my $safe = Safe->new;
Yadd's avatar
Yadd committed
202
    my $res  = $safe->reval("sub{my(\$env)=\@_;return ($cond)}");
Yadd's avatar
Yadd committed
203 204 205 206
    die "Bad condition $cond: $@" if ($@);
    return $res;
}

Yadd's avatar
Yadd committed
207
1;