Combination parser (#1151)
This commit is contained in:
parent
6040f03671
commit
7a675d14ca
|
@ -11,6 +11,7 @@ lib/Lemonldap/NG/Common/Apache/Session/Store.pm
|
|||
lib/Lemonldap/NG/Common/Captcha.pm
|
||||
lib/Lemonldap/NG/Common/CGI.pm
|
||||
lib/Lemonldap/NG/Common/Cli.pm
|
||||
lib/Lemonldap/NG/Common/CombinationParser.pm
|
||||
lib/Lemonldap/NG/Common/Conf.pm
|
||||
lib/Lemonldap/NG/Common/Conf/AccessLib.pm
|
||||
lib/Lemonldap/NG/Common/Conf/Backends/_DBI.pm
|
||||
|
|
192
lemonldap-ng-common/lib/Lemonldap/NG/Common/CombinationParser.pm
Normal file
192
lemonldap-ng-common/lib/Lemonldap/NG/Common/CombinationParser.pm
Normal file
|
@ -0,0 +1,192 @@
|
|||
package Lemonldap::NG::Common::CombinationParser;
|
||||
|
||||
use strict;
|
||||
use Mouse;
|
||||
use constant PE_OK => 0;
|
||||
|
||||
# Handle "if then else" (used during init)
|
||||
# return a sub that can be called with ($req) to get a [array] of combination
|
||||
#
|
||||
# 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, ')' );
|
||||
unless ($cond) {
|
||||
$self->lmLog( 'Bad combination: unmatched bracket', 'error' );
|
||||
return undef;
|
||||
}
|
||||
unless ( $rest =~ s/\s*then\s*\{// ) {
|
||||
$self->lmLog( 'Bad combination: missing "then"', 'error' );
|
||||
return undef;
|
||||
}
|
||||
( $then, $rest ) = $self->findB( $rest, '}' );
|
||||
unless ($then) {
|
||||
$self->lmLog( 'Bad combination: missing "then" content', 'error' );
|
||||
return undef;
|
||||
}
|
||||
unless ( $rest =~ s/\s*else\s*\{// ) {
|
||||
$self->lmLog( 'Bad combination: missing "else"', 'error' );
|
||||
return undef;
|
||||
}
|
||||
( $else, $rest ) = $self->findB( $rest, '}' );
|
||||
unless ($else) {
|
||||
$self->lmLog( 'Bad combination: missing "else" content', 'error' );
|
||||
return undef;
|
||||
}
|
||||
if ( $rest !~ /^\s*$/ ) {
|
||||
$self->lmLog( 'Bad combination: trailing characters after else{}',
|
||||
'error' );
|
||||
return undef;
|
||||
}
|
||||
|
||||
#TODO:
|
||||
#$cond = HANDLER->buildSub($cond);
|
||||
$cond = sub { 1 };
|
||||
$then = $self->parse( $moduleList, $then );
|
||||
$else = $self->parse( $moduleList, $else );
|
||||
unless ( $then and $else ) {
|
||||
$self->lmLog('Bad combination: bad then or else');
|
||||
return undef;
|
||||
}
|
||||
return sub {
|
||||
my ( $sub, $req ) = @_;
|
||||
return [
|
||||
( $cond->($req) ? $then->[0]->($@) : $else->[0]->($@) ),
|
||||
( $cond->($req) ? $then->[1]->($@) : $else->[1]->($@) ),
|
||||
];
|
||||
};
|
||||
}
|
||||
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 = ( [], [] );
|
||||
foreach my $part ( split /\]\s*and\s*\[/, $expr ) {
|
||||
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 {
|
||||
foreach my $obj (@$type) {
|
||||
my $r = $obj->(@_);
|
||||
return $r unless ( $r == PE_OK );
|
||||
}
|
||||
return PE_OK;
|
||||
};
|
||||
}
|
||||
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 );
|
||||
@res = map { $self->parseMod( $moduleList, $_ ) } @res;
|
||||
return \@res;
|
||||
}
|
||||
|
||||
# Internal method to parse auth or userDB expr
|
||||
# These expressions can be "LDAP" or "LDAP and DBI"
|
||||
# Return sub
|
||||
sub parseMod {
|
||||
my ( $self, $moduleList, $expr ) = @_;
|
||||
my @mods = map {
|
||||
die "Unknown module $_"
|
||||
unless ( $moduleList->{$_} );
|
||||
$moduleList->{$_}
|
||||
} split( /\s+and\s+/, $expr );
|
||||
if ( @mods == 1 ) {
|
||||
my ($m) = @mods;
|
||||
return sub {
|
||||
my ( $sub, $req ) = @_;
|
||||
return $m->$sub($req);
|
||||
};
|
||||
}
|
||||
return sub {
|
||||
my ( $sub, $req ) = @_;
|
||||
foreach my $obj (@mods) {
|
||||
my $res = $obj->$sub($req);
|
||||
return $res unless ( $res == PE_OK );
|
||||
}
|
||||
return PE_OK;
|
||||
};
|
||||
}
|
||||
|
||||
# Internal request to find brackets
|
||||
sub findB {
|
||||
my ( $self, $expr, $char ) = @_;
|
||||
my $res;
|
||||
my @chars = split //, $expr;
|
||||
while ( my $c = shift @chars ) {
|
||||
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 );
|
||||
unless ($m) {
|
||||
$self->lmLog( "Bad combination: unmatched $c", 'error' );
|
||||
return undef;
|
||||
}
|
||||
$res .= "$c$m$wanted";
|
||||
@chars = split //, $rest;
|
||||
next;
|
||||
}
|
||||
$res .= $c;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
Loading…
Reference in New Issue
Block a user