Combination parser (#1151)

lemonldap-ng-common/MANIFEST

@@ -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

lemonldap-ng-common/lib/Lemonldap/NG/Common/CombinationParser.pm

@@ -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;