Parser.pm 44.4 KB
Newer Older
1
package Lemonldap::NG::Manager::Conf::Parser;
2

Yadd's avatar
Yadd committed
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
# This module is called either to parse a new configuration in JSON format (as
# posted by the web interface) and test a new configuration object.
#
# The new object must be build with the following properties:
#  - refConf: the actual configuration
#  - req    : the Lemonldap::NG::Common::PSGI::Request
#  - tree   : the new configuration in JSON format
#   or
#  - newConf: the configuration to test
#
# The main method is check() which calls:
#  - scanTree() if configuration is not parsed (JSON string)
#  - testNewConf()
#
# It returns a boolean. Errors, warnings and changes are stored as array
# containing `{ message => 'Explanation' }. A main message is stored in
# `message` property.

Yadd's avatar
Yadd committed
21 22
use strict;
use utf8;
23
use Mouse;
24
use Lemonldap::NG::Common::Conf::ReConstants;
25 26
use Lemonldap::NG::Manager::Attributes;

27 28
our $VERSION = '2.0.0';

Yadd's avatar
Yadd committed
29 30
extends 'Lemonldap::NG::Common::Conf::Compact';

Yadd's avatar
Yadd committed
31
# High debugging for developpers, set this to 1
Yadd's avatar
Yadd committed
32 33
use constant HIGHDEBUG => 0;

Yadd's avatar
Yadd committed
34
# Messages storage
Yadd's avatar
Yadd committed
35 36 37
has errors => (
    is      => 'rw',
    isa     => 'ArrayRef',
Yadd's avatar
Yadd committed
38
    default => sub { return [] }
Yadd's avatar
Yadd committed
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
);
has warnings => (
    is      => 'rw',
    isa     => 'ArrayRef',
    default => sub { return [] },
    trigger => sub {
        hdebug( 'warnings contains', $_[0]->{warnings} );
    }
);
has changes => ( is => 'rw', isa => 'ArrayRef', default => sub { return [] } );
has message => (
    is      => 'rw',
    isa     => 'Str',
    default => '',
    trigger => sub {
        hdebug( "Message becomes " . $_[0]->{message} );
    }
);
Yadd's avatar
Yadd committed
57 58 59 60

# Booleans
has needConfirm =>
  ( is => 'rw', isa => 'ArrayRef', default => sub { return [] } );
Yadd's avatar
Yadd committed
61 62
has confChanged => (
    is      => 'rw',
Yadd's avatar
Yadd committed
63
    isa     => 'Bool',
Yadd's avatar
Yadd committed
64 65 66 67 68
    default => 0,
    trigger => sub {
        hdebug( "condChanged: " . $_[0]->{confChanged} );
    }
);
Yadd's avatar
Yadd committed
69 70

# Properties required during build
Yadd's avatar
Yadd committed
71
has refConf => ( is => 'ro', isa => 'HashRef', required => 1 );
72 73 74 75
has req     => ( is => 'ro', required => 1 );
has newConf => ( is => 'rw', isa      => 'HashRef' );
has tree    => ( is => 'rw', isa      => 'ArrayRef' );

Yadd's avatar
Yadd committed
76
# High debug method
Yadd's avatar
Yadd committed
77 78 79 80 81
sub hdebug {
    if (HIGHDEBUG) {
        foreach my $d (@_) {
            if ( ref $d ) {
                require Data::Dumper;
Yadd's avatar
Yadd committed
82
                $Data::Dumper::Useperl = 1;
Yadd's avatar
Yadd committed
83 84 85 86 87 88 89 90
                print STDERR Data::Dumper::Dumper($d);
            }
            else { print STDERR "$d\n" }
        }
    }
    undef;
}

Yadd's avatar
Yadd committed
91 92 93
##@method boolean check()
# Main method
#@return result
94 95
sub check {
    my $self = shift;
Yadd's avatar
Yadd committed
96
    hdebug("# check()");
97
    unless ( $self->newConf ) {
Yadd's avatar
Yadd committed
98
        return 0 unless ( $self->scanTree );
99 100
    }
    unless ( $self->testNewConf ) {
Yadd's avatar
Yadd committed
101
        hdebug("  testNewConf() failed");
102 103
        return 0;
    }
Yadd's avatar
Yadd committed
104
    hdebug("  tests succeed");
Yadd's avatar
Yadd committed
105
    $self->compactConf( $self->newConf );
Yadd's avatar
Yadd committed
106 107 108 109 110 111
    unless ( $self->confChanged ) {
        hdebug("  no changes detected");
        $self->message('__confNotChanged__');
        return 0;
    }
    return 1;
112 113
}

Yadd's avatar
Yadd committed
114 115 116
##@method boolean scanTree()
# Methods to build new conf from JSON string
#@result true if succeed
117 118
sub scanTree {
    my $self = shift;
Yadd's avatar
Yadd committed
119
    hdebug("# scanTree()");
120 121 122 123
    $self->newConf( {} );
    $self->_scanNodes( $self->tree ) or return 0;

    # Set cfgNum to ref cfgNum (will be changed when saving), set other
Yadd's avatar
Yadd committed
124
    # metadata and set a value to the key if empty
Yadd's avatar
Yadd committed
125 126 127 128
    $self->newConf->{cfgNum} = $self->req->params('cfgNum');
    $self->newConf->{cfgAuthor} =
      $self->req->userData->{ $Lemonldap::NG::Handler::Main::tsv->{whatToTrace}
          || '_whatToTrace' } // "anonymous";
Yadd's avatar
Yadd committed
129
    $self->newConf->{cfgAuthorIP} = $self->req->address;
130
    $self->newConf->{cfgDate}     = time;
131
    $self->newConf->{cfgVersion}  = $VERSION;
132 133 134 135 136 137 138 139
    $self->newConf->{key} ||=
      join( '', map { chr( int( rand(94) ) + 33 ) } ( 1 .. 16 ) );

    return 1;
}

use feature 'state';

Yadd's avatar
Yadd committed
140
##@method private boolean _scanNodes()
141
# Recursive JSON parser
Yadd's avatar
Yadd committed
142
#@result true if succeed
143
sub _scanNodes {
Yadd's avatar
Yadd committed
144
    my ( $self, $tree, ) = @_;
Yadd's avatar
Yadd committed
145
    hdebug("# _scanNodes()");
146 147 148 149 150 151
    state( $knownCat, %newNames );
    unless ( ref($tree) eq 'ARRAY' ) {
        print STDERR 'Fatal: node is not an array';
        push @{ $self->errors }, { message => 'Fatal: node is not an array' };
        return 0;
    }
Yadd's avatar
Yadd committed
152 153 154
    unless (@$tree) {
        hdebug('  empty tree !?');
    }
155 156
    foreach my $leaf (@$tree) {
        my $name = $leaf->{title};
Yadd's avatar
Yadd committed
157
        hdebug("Looking to $name");
158 159 160 161 162 163 164 165 166 167 168

        # subnode
        my $subNodes     = $leaf->{nodes}      // $leaf->{_nodes};
        my $subNodesCond = $leaf->{nodes_cond} // $leaf->{_nodes_cond};

        ##################################
        # VirtualHosts and SAML partners #
        ##################################

        # Root nodes
        if ( $leaf->{id} =~ /^($specialNodeKeys)$/io ) {
Yadd's avatar
Yadd committed
169
            hdebug("Root special node detected $leaf->{id}");
170 171 172

            # If node has not been opened
            if ( $leaf->{cnodes} ) {
Yadd's avatar
Yadd committed
173
                hdebug("  not opened");
174
                foreach my $k ( @{ $specialNodeHash->{ $leaf->{id} } } ) {
Yadd's avatar
Yadd committed
175
                    hdebug("  copying $k");
176 177 178 179 180 181 182 183 184 185 186 187 188
                    $self->newConf->{$k} = $self->refConf->{$k};
                }
                next;
            }
            $self->_scanNodes($subNodes);

            # Check deleted keys
            my $field = $specialNodeHash->{ $leaf->{id} }->[0];
            my @old   = keys %{ $self->refConf->{$field} };
            foreach my $k ( keys %{ $self->newConf->{$field} } ) {
                @old = grep { $_ ne $k } @old;
            }
            if (@old) {
Yadd's avatar
Yadd committed
189
                hdebug( "Keys detected as removed:", \@old );
190 191 192 193 194 195 196 197 198 199 200
                $self->confChanged(1);
                foreach my $deletedHost (@old) {
                    push @{ $self->changes },
                      { key => $leaf->{id}, old => $deletedHost };
                }
            }
            next;
        }

        # 1st sublevel
        elsif ( $leaf->{id} =~ /^($specialNodeKeys)\/([^\/]+)$/io ) {
Yadd's avatar
Yadd committed
201
            hdebug("Special node chield detected $leaf->{id}");
202 203 204 205
            my ( $base, $host ) = ( $1, $2 );

            # Check hostname/partner name changes (id points to the old name)
            $newNames{$host} = $leaf->{title};
206 207 208 209 210 211
            if ( $newNames{$host} ne $host and $host !~ /^new__/ ) {
                hdebug("  $host becomes $newNames{$host}");
                $self->confChanged(1);
                push @{ $self->changes },
                  { key => $base, old => $host, new => $newNames{$host} };
            }
212 213 214 215 216 217 218 219 220

            $self->_scanNodes($subNodes);
            next;
        }

        # Other sub levels
        elsif ( $leaf->{id} =~
            /^($specialNodeKeys)\/([^\/]+)\/([^\/]+)(?:\/(.*))?$/io )
        {
Yadd's avatar
Yadd committed
221 222
            my ( $base, $key, $oldName, $target, $h ) =
              ( $1, $newNames{$2}, $2, $3, $4 );
Yadd's avatar
Yadd committed
223 224 225 226 227
            hdebug(
                "Special node chield subnode detected $leaf->{id}",
                "  base $base, key $key, target $target, h "
                  . ( $h ? $h : 'undef' )
            );
228 229 230

            # VirtualHosts
            if ( $base eq 'virtualHosts' ) {
Yadd's avatar
Yadd committed
231
                hdebug("  virtualhost");
232 233
                if ( $target =~ /^(?:locationRules|exportedHeaders|post)$/ ) {
                    if ( $leaf->{cnodes} ) {
Yadd's avatar
Yadd committed
234
                        hdebug('    unopened subnode');
235
                        $self->newConf->{$target}->{$key} =
Yadd's avatar
Yadd committed
236
                          $self->refConf->{$target}->{$oldName} // {};
237 238 239
                    }

                    elsif ($h) {
Yadd's avatar
Yadd committed
240
                        hdebug('    4 levels');
241
                        if ( $target eq 'locationRules' ) {
Yadd's avatar
Yadd committed
242
                            hdebug('    locationRules');
243 244 245 246 247 248 249
                            my $k =
                              $leaf->{comment}
                              ? "(?#$leaf->{comment})$leaf->{re}"
                              : $leaf->{re};
                            $self->set( $target, $key, $k, $leaf->{data} );
                        }
                        else {
Yadd's avatar
Yadd committed
250
                            hdebug('    other than locationrules');
251 252 253 254 255 256 257
                            $self->set( $target, $key, $leaf->{title},
                                $leaf->{data} );
                        }
                    }

                    # Unless $h is set, scan subnodes and check changes
                    else {
Yadd's avatar
Yadd committed
258
                        hdebug('    3 levels only (missing $h)');
259
                        if ( ref $subNodes ) {
Yadd's avatar
Yadd committed
260
                            hdebug('    has subnodes');
261 262 263 264 265 266
                            $self->_scanNodes($subNodes)
                              or return 0;
                        }
                        if ( exists $self->refConf->{$target}->{$key}
                            and %{ $self->refConf->{$target}->{$key} } )
                        {
Yadd's avatar
Yadd committed
267
                            hdebug('    old conf subnode has values');
268 269 270 271 272
                            my $c = $self->newConf->{$target};
                            foreach my $k (
                                keys %{ $self->refConf->{$target}->{$key} } )
                            {
                                unless ( defined $c->{$key}->{$k} ) {
Yadd's avatar
Yadd committed
273
                                    hdebug('      missing value in old conf');
274 275 276 277 278 279 280 281 282 283 284 285
                                    $self->confChanged(1);
                                    push @{ $self->changes },
                                      {
                                        key => "$target, $key",
                                        old => $k,
                                      };
                                }
                            }
                        }
                        elsif ( exists $self->newConf->{$target}->{$key}
                            and %{ $self->newConf->{$target}->{$key} } )
                        {
Yadd's avatar
Yadd committed
286
                            hdebug("    '$key' has values");
287 288 289 290 291 292 293
                            $self->confChanged(1);
                            push @{ $self->changes },
                              { key => "$target", new => $key };
                        }
                    }
                }
                elsif ( $target =~ /^$virtualHostKeys$/o ) {
294 295
                    $self->set( 'vhostOptions', [ $oldName, $key ],
                        $target, $leaf->{data} );
296 297 298 299 300 301 302 303
                }
                else {
                    push @{ $self->errors },
                      { message => "Unknown vhost key $target" };
                    return 0;
                }
                next;
            }
Yadd's avatar
Yadd committed
304

305
            # SAML
Yadd's avatar
Yadd committed
306
            elsif ( $base =~ /^saml(?:S|ID)PMetaDataNodes$/ ) {
Yadd's avatar
Yadd committed
307
                hdebug('SAML');
Yadd's avatar
Yadd committed
308 309
                if ( defined $leaf->{data} and ref( $leaf->{data} ) eq 'ARRAY' )
                {
Yadd's avatar
Yadd committed
310 311 312
                    hdebug("  SAML data is an array, serializing");
                    $leaf->{data} = join ';', @{ $leaf->{data} };
                }
Yadd's avatar
Yadd committed
313
                if ( $target =~ /^saml(?:S|ID)PMetaDataExportedAttributes$/ ) {
314
                    if ( $leaf->{cnodes} ) {
Yadd's avatar
Yadd committed
315
                        hdebug("  $target: unopened node");
316
                        $self->newConf->{$target}->{$key} =
Yadd's avatar
Yadd committed
317
                          $self->refConf->{$target}->{$oldName} // {};
318
                    }
Yadd's avatar
Yadd committed
319
                    elsif ($h) {
Yadd's avatar
Yadd committed
320
                        hdebug("  $target: opened node");
321
                        $self->confChanged(1);
322 323 324
                        $self->set( $target, $key, $leaf->{title},
                            $leaf->{data} );
                    }
Yadd's avatar
Yadd committed
325
                    else {
Yadd's avatar
Yadd committed
326 327
                        hdebug("  $target: looking for subnodes");
                        $self->_scanNodes($subNodes);
Yadd's avatar
Yadd committed
328
                    }
329
                }
330
                elsif ( $target =~ /^saml(?:S|ID)PMetaDataXML$/ ) {
Yadd's avatar
Yadd committed
331
                    hdebug("  $target");
332 333
                    $self->set( $target, [ $oldName, $key ],
                        $target, $leaf->{data} );
334
                }
335 336 337 338 339 340 341
                elsif ( $target =~ /^saml(?:ID|S)PMetaDataOptions/ ) {
                    my $optKey = $&;
                    hdebug("  $base sub key: $target");
                    if ( $target =~
                        /^(?:$samlIDPMetaDataNodeKeys|$samlSPMetaDataNodeKeys)/o
                      )
                    {
342 343 344 345
                        $self->set(
                            $optKey, [ $oldName, $key ],
                            $target, $leaf->{data}
                        );
346 347 348 349 350 351
                    }
                    else {
                        push @{ $self->errors },
                          { message => "Unknown SAML metadata option $target" };
                        return 0;
                    }
352 353 354
                }
                else {
                    push @{ $self->errors },
355
                      { message => "Unknown SAML key $target" };
356 357 358 359
                    return 0;
                }
                next;
            }
360

Yadd's avatar
Yadd committed
361
            # OIDC
Yadd's avatar
Yadd committed
362
            elsif ( $base =~ /^oidc(?:O|R)PMetaDataNodes$/ ) {
Yadd's avatar
Yadd committed
363
                hdebug('OIDC');
Yadd's avatar
Yadd committed
364
                if ( $target =~ /^oidc(?:O|R)PMetaDataOptions$/ ) {
Yadd's avatar
Yadd committed
365 366
                    hdebug("  $target: looking for subnodes");
                    $self->_scanNodes($subNodes);
Yadd's avatar
Yadd committed
367 368 369
                    $self->set( $target, $key, $leaf->{title}, $leaf->{data} );
                }
                elsif ( $target =~ /^oidcOPMetaData(?:JSON|JWKS)$/ ) {
Yadd's avatar
Yadd committed
370
                    hdebug("  $target");
Yadd's avatar
Yadd committed
371 372 373
                    $self->set( $target, $key, $leaf->{data} );
                }
                elsif ( $target =~ /^oidc(?:O|R)PMetaDataExportedVars$/ ) {
Yadd's avatar
Yadd committed
374
                    hdebug("  $target");
Yadd's avatar
Yadd committed
375
                    if ( $leaf->{cnodes} ) {
Yadd's avatar
Yadd committed
376
                        hdebug('    unopened');
Yadd's avatar
Yadd committed
377
                        $self->newConf->{$target}->{$key} =
Yadd's avatar
Yadd committed
378
                          $self->refConf->{$target}->{$oldName} // {};
Yadd's avatar
Yadd committed
379 380
                    }
                    elsif ($h) {
Yadd's avatar
Yadd committed
381
                        hdebug('    opened');
Yadd's avatar
Yadd committed
382 383 384
                        $self->set( $target, $key, $leaf->{title},
                            $leaf->{data} );
                    }
Yadd's avatar
Yadd committed
385 386 387 388
                    else {
                        hdebug("  $target: looking for subnodes");
                        $self->_scanNodes($subNodes);
                    }
Yadd's avatar
Yadd committed
389
                }
Yadd's avatar
Yadd committed
390
                elsif ( $target =~ /^oidc(?:O|R)PMetaDataOptions/ ) {
391
                    my $optKey = $&;
Yadd's avatar
Yadd committed
392
                    hdebug "  $base sub key: $target";
Yadd's avatar
Yadd committed
393 394 395 396
                    if ( $target eq 'oidcRPMetaDataOptionsExtraClaims' ) {
                        if ( $leaf->{cnodes} ) {
                            hdebug('    unopened');
                            $self->newConf->{$target}->{$key} =
Yadd's avatar
Yadd committed
397
                              $self->refConf->{$target}->{$oldName} // {};
Yadd's avatar
Yadd committed
398 399 400 401 402 403 404 405 406 407 408 409
                        }
                        elsif ($h) {
                            hdebug('    opened');
                            $self->set( $target, $key, $leaf->{title},
                                $leaf->{data} );
                        }
                        else {
                            hdebug("  $target: looking for subnodes");
                            $self->_scanNodes($subNodes);
                        }
                    }
                    elsif ( $target =~
410 411 412
                        /^(?:$oidcOPMetaDataNodeKeys|$oidcRPMetaDataNodeKeys)/o
                      )
                    {
413 414 415 416
                        $self->set(
                            $optKey, [ $oldName, $key ],
                            $target, $leaf->{data}
                        );
417 418 419 420 421 422
                    }
                    else {
                        push @{ $self->errors },
                          { message => "Unknown OIDC metadata option $target" };
                        return 0;
                    }
Yadd's avatar
Yadd committed
423
                }
Yadd's avatar
Yadd committed
424 425
                else {
                    push @{ $self->errors },
426
                      { message => "Unknown OIDC key $target" };
Yadd's avatar
Yadd committed
427 428 429 430
                    return 0;
                }
                next;
            }
Yadd's avatar
Yadd committed
431 432 433 434 435

            # CAS
            elsif ( $base =~ /^cas(?:App|Srv)MetaDataNodes$/ ) {
                my $optKey = $&;
                hdebug('CAS');
Yadd's avatar
Yadd committed
436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457
                if ( $target =~ /^cas(?:App|Srv)MetaDataOptions$/ ) {
                    hdebug("  $target: looking for subnodes");
                    $self->_scanNodes($subNodes);
                    $self->set( $target, $key, $leaf->{title}, $leaf->{data} );
                }
                elsif ( $target =~ /^cas(?:App|Srv)MetaDataExportedVars$/ ) {
                    hdebug("  $target");
                    if ( $leaf->{cnodes} ) {
                        hdebug('    unopened');
                        $self->newConf->{$target}->{$key} =
                          $self->refConf->{$target}->{$oldName} // {};
                    }
                    elsif ($h) {
                        hdebug('    opened');
                        $self->set( $target, $key, $leaf->{title},
                            $leaf->{data} );
                    }
                    else {
                        hdebug("  $target: looking for subnodes");
                        $self->_scanNodes($subNodes);
                    }
                }
Yadd's avatar
Yadd committed
458 459 460
                elsif ( $target =~ /^cas(?:Srv|App)MetaDataOptions/ ) {
                    my $optKey = $&;
                    hdebug "  $base sub key: $target";
461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477
                    if ( $target eq 'casSrvMetaDataOptionsProxiedServices' ) {
                        if ( $leaf->{cnodes} ) {
                            hdebug('    unopened');
                            $self->newConf->{$target}->{$key} =
                              $self->refConf->{$target}->{$oldName} // {};
                        }
                        elsif ($h) {
                            hdebug('    opened');
                            $self->set( $target, $key, $leaf->{title},
                                $leaf->{data} );
                        }
                        else {
                            hdebug("  $target: looking for subnodes");
                            $self->_scanNodes($subNodes);
                        }
                    }
                    elsif ( $target =~
dcoutadeur dcoutadeur's avatar
dcoutadeur dcoutadeur committed
478 479
                        /^(?:$casSrvMetaDataNodeKeys|$casAppMetaDataNodeKeys)/o
                      )
Yadd's avatar
Yadd committed
480
                    {
dcoutadeur dcoutadeur's avatar
dcoutadeur dcoutadeur committed
481 482 483 484
                        $self->set(
                            $optKey, [ $oldName, $key ],
                            $target, $leaf->{data}
                        );
Yadd's avatar
Yadd committed
485 486 487 488 489 490
                    }
                    else {
                        push @{ $self->errors },
                          { message => "Unknown CAS metadata option $target" };
                        return 0;
                    }
Yadd's avatar
Yadd committed
491 492 493
                }
                else {
                    push @{ $self->errors },
Yadd's avatar
Yadd committed
494
                      { message => "Unknown CAS option $target" };
Yadd's avatar
Yadd committed
495 496
                    return 0;
                }
Yadd's avatar
Yadd committed
497
                next;
Yadd's avatar
Yadd committed
498
            }
Yadd's avatar
Yadd committed
499
            else {
500 501
                push @{ $self->errors },
                  { message => "Fatal: unknown special sub node $base" };
Yadd's avatar
Yadd committed
502 503
                return 0;
            }
504 505 506 507 508
        }

        ####################
        # Application list #
        ####################
509 510 511 512 513 514 515 516 517 518 519 520 521

        # Application list root node
        elsif ( $leaf->{title} eq 'applicationList' ) {
            hdebug( $leaf->{title} );
            if ( $leaf->{cnodes} ) {
                hdebug('  unopened');
                $self->newConf->{applicationList} =
                  $self->refConf->{applicationList} // {};
            }
            else {
                $self->_scanNodes($subNodes) or return 0;

                # Check for deleted
522 523 524
                my @listCatRef =
                  map { $self->refConf->{applicationList}->{$_}->{catname} }
                  keys %{ $self->refConf->{applicationList} };
525
                my @listCatNew =
526
                  map { $self->newConf->{applicationList}->{$_}->{catname} }
527
                  keys(
528 529 530 531 532 533
                    %{
                        ref $self->newConf->{applicationList}
                        ? $self->newConf->{applicationList}
                        : {}
                    }
                  );
534 535 536 537 538 539 540 541 542 543 544 545 546 547 548
                foreach my $cat (@listCatNew) {
                    @listCatRef = grep { $_ ne $cat } @listCatRef;
                }
                if (@listCatRef) {
                    $self->confChanged(1);
                    foreach my $cat (@listCatRef) {
                        push @{ $self->changes },
                          { key => $leaf->{id}, old => $cat };
                    }
                }
            }
            next;
        }

        # Application list sub nodes
549
        elsif ( $leaf->{id} =~ /^applicationList\/(.+)$/ ) {
550
            hdebug('Application list subnode');
551 552 553 554 555 556 557 558 559 560 561 562
            use feature 'state';
            my @cats = split /\//, $1;
            my $app = pop @cats;
            $self->newConf->{applicationList} //= {};

            # $cn is a pointer to the parent
            my $cn  = $self->newConf->{applicationList};
            my $cmp = $self->refConf->{applicationList};
            my @path;

            # Makes $cn point to the parent
            foreach my $cat (@cats) {
Yadd's avatar
Yadd committed
563
                hdebug("  looking to cat $cat");
564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580
                unless ( defined $knownCat->{$cat} ) {
                    push @{ $self->{errors} },
                      { message =>
                          "Fatal: sub cat/app before parent ($leaf->{id})" };
                    return 0;
                }
                $cn = $cn->{ $knownCat->{$cat} };
                push @path, $cn->{catname};
                $cmp->{$cat} //= {};
                $cmp = $cmp->{$cat};
            }

            # Create new category
            #
            # Note that this works because nodes are ordered so "cat/cat2/app"
            # is looked after "cat" and "cat/cat2"
            if ( $leaf->{type} eq 'menuCat' ) {
Yadd's avatar
Yadd committed
581
                hdebug('  menu cat');
582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602
                $knownCat->{__id}++;
                my $s = $knownCat->{$app} = sprintf '%04d-cat',
                  $knownCat->{__id};
                $cn->{$s} =
                  { catname => $leaf->{title}, type => 'category' };
                unless ($cmp->{$app}
                    and $cmp->{$app}->{catname} eq $cn->{$s}->{catname} )
                {
                    $self->confChanged(1);
                    push @{ $self->changes },
                      {
                        key => join(
                            ', ', 'applicationList', @path, $leaf->{title}
                        ),
                        new => $cn->{$s}->{catname},
                        old => ( $cn->{$s} ? $cn->{$s}->{catname} : undef )
                      };
                }
                if ( ref $subNodes ) {
                    $self->_scanNodes($subNodes) or return 0;
                }
Yadd's avatar
Yadd committed
603 604
                my @listCatRef = keys %{ $cmp->{$app} };
                my @listCatNew = keys %{ $cn->{$s} };
605

Yadd's avatar
Yadd committed
606 607 608 609 610 611
                # Check for deleted
                unless ( @listCatRef == @listCatNew ) {
                    $self->confChanged(1);
                    push @{ $self->changes },
                      {
                        key => join( ', ', 'applicationList', @path ),
612
                        new => 'Changes in cat(s)/app(s)',
Yadd's avatar
Yadd committed
613 614
                      };
                }
615 616 617 618
            }

            # Create new apps
            else {
Yadd's avatar
Yadd committed
619
                hdebug('  new app');
620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652
                $knownCat->{__id}++;
                my $name = sprintf( '%04d-app', $knownCat->{__id} );
                $cn->{$name} =
                  { type => 'application', options => $leaf->{data} };
                $cn->{$name}->{options}->{name} = $leaf->{title};
                unless ( $cmp->{$app} ) {
                    $self->confChanged(1);
                    push @{ $self->changes },
                      {
                        key => join( ', ', 'applicationList', @path ),
                        new => $leaf->{title},
                      };
                }
                else {
                    foreach my $k ( keys %{ $cn->{$name}->{options} } ) {
                        unless ( $cmp->{$app}->{options}->{$k} eq
                            $cn->{$name}->{options}->{$k} )
                        {
                            $self->confChanged(1);
                            push @{ $self->changes },
                              {
                                key => join( ', ',
                                    'applicationList', @path,
                                    $leaf->{title},    $k ),
                                new => $cn->{$name}->{options}->{$k},
                                old => $cmp->{$app}->{options}->{$k}
                              };
                        }
                    }
                }
            }
            next;
        }
Yadd's avatar
Yadd committed
653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697
        elsif ( $leaf->{id} eq 'grantSessionRules' ) {
            hdebug('grantSessionRules');
            if ( $leaf->{cnodes} ) {
                hdebug('  unopened');
                $self->newConf->{$name} = $self->refConf->{$name} // {};
            }
            else {
                hdebug('  opened');
                $subNodes //= [];
                my $count = 0;
                my $ref   = $self->refConf->{grantSessionRules};
                my $new   = $self->newConf->{grantSessionRules};
                my @old   = ref $ref ? keys %$ref : ();
                $self->newConf->{grantSessionRules} = {};
                foreach my $n (@$subNodes) {
                    hdebug("  looking at $n subnode");
                    my $k =
                      $n->{re} . ( $n->{comment} ? "##$n->{comment}" : '' );
                    $self->newConf->{grantSessionRules}->{$k} = $n->{data};
                    $count++;
                    unless ( defined $ref->{$k} ) {
                        $self->confChanged(1);
                        push @{ $self->changes },
                          { keys => 'grantSessionRules', new => $k };
                    }
                    elsif ( $ref->{$k} ne $n->{data} ) {
                        $self->confChanged(1);
                        push @{ $self->changes },
                          {
                            key => "grantSessionRules, $k",
                            old => $self->refConf->{grantSessionRules}->{$k},
                            new => $n->{data}
                          };
                    }
                    @old = grep { $_ ne $k } @old;
                }
                if (@old) {
                    $self->confChanged(1);
                    push @{ $self->changes },
                      { key => 'grantSessionRules', old => $_, }
                      foreach (@old);
                }
            }
            next;
        }
698

Yadd's avatar
Yadd committed
699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716
        # openIdIDPList: data is splitted by Conf.pm into a boolean and a
        # string
        elsif ( $name eq 'openIdIDPList' ) {
            hdebug('openIdIDPList');
            if ( $leaf->{data} ) {
                unless ( ref $leaf->{data} eq 'ARRAY' ) {
                    push @{ $self->{errors} },
                      { message => 'Malformed openIdIDPList ' . $leaf->{data} };
                    return 0;
                }
                $self->set( $name, join( ';', @{ $leaf->{data} } ) );
            }
            else {
                $self->set( $name, undef );
            }
            next;
        }

717 718 719
        ####################
        # Other hash nodes #
        ####################
720
        elsif ( $leaf->{title} =~ /^$simpleHashKeys$/o
721 722
            and not $leaf->{title} eq 'applicationList' )
        {
Yadd's avatar
Yadd committed
723
            hdebug( $leaf->{title} );
724 725 726

            # If a `cnodes` key is found, keep old key unchanges
            if ( $leaf->{cnodes} ) {
Yadd's avatar
Yadd committed
727
                hdebug('  unopened');
728 729 730
                $self->newConf->{$name} = $self->refConf->{$name} // {};
            }
            else {
Yadd's avatar
Yadd committed
731
                hdebug('  opened');
732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751

                # combModules: just to replace "over" key
                if ( $name eq 'combModules' ) {
                    hdebug('     combModules');
                    $self->newConf->{$name} = {};
                    foreach my $node ( @{ $leaf->{nodes} } ) {
                        my $tmp;
                        $tmp->{$_} = $node->{data}->{$_} foreach (qw(type for));
                        $tmp->{over} = {};
                        foreach ( @{ $node->{data}->{over} } ) {
                            $tmp->{over}->{ $_->[0] } = $_->[1];
                        }
                        $self->newConf->{$name}->{ $node->{title} } = $tmp;
                    }

                    # TODO: check changes
                    $self->confChanged(1);
                    next;
                }

752 753 754 755 756 757 758 759 760
                $subNodes //= [];
                my $count = 0;
                my @old   = (
                    ref( $self->refConf->{$name} )
                    ? ( keys %{ $self->refConf->{$name} } )
                    : ()
                );
                $self->newConf->{$name} = {};
                foreach my $n (@$subNodes) {
Yadd's avatar
Yadd committed
761
                    hdebug("  looking at $n subnode");
Yadd's avatar
Yadd committed
762 763 764
                    if ( ref $n->{data} and ref $n->{data} eq 'ARRAY' ) {
                        $n->{data} = join ';', @{ $n->{data} };
                    }
765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794
                    $self->newConf->{$name}->{ $n->{title} } = $n->{data};
                    $count++;
                    unless ( defined $self->refConf->{$name}->{ $n->{title} } )
                    {
                        $self->confChanged(1);
                        push @{ $self->changes },
                          { key => $name, new => $n->{title}, };
                    }
                    elsif (
                        $self->refConf->{$name}->{ $n->{title} } ne $n->{data} )
                    {
                        $self->confChanged(1);
                        push @{ $self->changes },
                          {
                            key => "$name, $n->{title}",
                            old => $self->refConf->{$name}->{ $n->{title} },
                            new => $n->{data}
                          };
                    }
                    @old = grep { $_ ne $n->{title} } @old;
                }
                if (@old) {
                    $self->confChanged(1);
                    push @{ $self->changes }, { key => $name, old => $_, }
                      foreach (@old);
                }
            }
            next;
        }

795 796 797 798 799 800 801 802 803
        # Double hash nodes
        elsif ( $leaf->{title} =~ /^$doubleHashKeys$/ ) {
            hdebug( $leaf->{title} );
            my @oldHosts = (
                ref( $self->refConf->{$name} )
                ? ( keys %{ $self->refConf->{$name} } )
                : ()
            );
            $self->newConf->{$name} = {};
Yadd's avatar
Yadd committed
804 805
            unless ( defined $leaf->{data} ) {
                hdebug('  unopened');
806
                $self->newConf->{$name} = $self->refConf->{$name} || {};
Yadd's avatar
Yadd committed
807
                next;
808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825
            }
            foreach my $getHost ( @{ $leaf->{data} } ) {
                my $change = 0;
                my @oldKeys;
                my $host = $getHost->{k};
                hdebug("  looking at host: $host");
                $self->newConf->{$name}->{$host} = {};
                unless ( defined $self->refConf->{$name}->{$host} ) {
                    $self->confChanged(1);
                    $change++;
                    push @{ $self->changes }, { key => $name, new => $host };
                    hdebug("    $host is new");
                }
                else {
                    @oldHosts = grep { $_ ne $host } @oldHosts;
                    @oldKeys = keys %{ $self->refConf->{$name}->{$host} };
                }
                foreach my $prm ( @{ $getHost->{h} } ) {
Yadd's avatar
Yadd committed
826 827
                    $self->newConf->{$name}->{$host}->{ $prm->{k} } =
                      $prm->{v};
828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864
                    if (
                        !$change
                        and (
                            not defined(
                                $self->refConf->{$name}->{$host}->{ $prm->{k} }
                            )
                            or $self->newConf->{$name}->{$host}->{ $prm->{k} }
                            ne $self->refConf->{$name}->{$host}->{ $prm->{k} }
                        )
                      )
                    {
                        $self->confChanged(1);
                        hdebug("    key $prm->{k} has been changed");
                        push @{ $self->changes },
                          { key => "$name/$host", new => $prm->{k} };
                    }
                    elsif ( !$change ) {
                        @oldKeys = grep { $_ ne $prm->{k} } @oldKeys;
                    }
                }
                if (@oldKeys) {
                    $self->confChanged(1);
                    hdebug( "  old keys: " . join( ' ', @oldKeys ) );
                    push @{ $self->changes },
                      { key => "$name/$host", old => $_ }
                      foreach (@oldKeys);
                }
            }
            if (@oldHosts) {
                $self->confChanged(1);
                hdebug( "  old hosts " . join( ' ', @oldHosts ) );
                push @{ $self->changes }, { key => "$name", old => $_ }
                  foreach (@oldHosts);
            }
            next;
        }

865 866 867 868 869 870 871
        ###############
        # Other nodes #
        ###############

        # Check if subnodes
        my $n = 0;
        if ( ref $subNodesCond ) {
Yadd's avatar
Yadd committed
872 873 874 875
            hdebug('  conditional subnodes detected');

            # Bad idea,subnode unopened are not read
            #$subNodesCond = [ grep { $_->{show} } @$subNodesCond ];
876 877 878 879
            $self->_scanNodes($subNodesCond) or return 0;
            $n++;
        }
        if ( ref $subNodes ) {
Yadd's avatar
Yadd committed
880
            hdebug('  subnodes detected');
881 882 883
            $self->_scanNodes($subNodes) or return 0;
            $n++;
        }
Yadd's avatar
Yadd committed
884 885 886
        if ($n) {
            next;
        }
887 888
        if ( defined $leaf->{data} and ref( $leaf->{data} ) eq 'ARRAY' ) {
            if ( ref( $leaf->{data}->[0] ) eq 'HASH' ) {
Yadd's avatar
Yadd committed
889
                hdebug("  array found");
890 891 892 893 894 895 896
                $self->_scanNodes( $leaf->{data} ) or return 0;
            }
            else {
                $self->set( $name, join( ';', @{ $leaf->{data} } ) );
            }
        }

897 898 899 900 901 902 903 904
        # Grouped nodes not opened
        elsif ( $leaf->{get} and ref $leaf->{get} eq 'ARRAY' ) {
            hdebug("  unopened grouped node");
            foreach my $subkey ( @{ $leaf->{get} } ) {
                $self->set( $subkey, undef );
            }
        }

905 906 907 908 909 910 911 912
        # Normal leaf
        else {
            $self->set( $name, $leaf->{data} );
        }
    }
    return 1;
}

Yadd's avatar
Yadd committed
913 914
##@method private void set($target, @path, $data)
# Store a value in the $target key (following subkeys if @path is set)
915 916 917 918 919 920 921 922 923
sub set {
    my $self  = shift;
    my $data  = pop;
    my @confs = ( $self->refConf, $self->newConf );
    my @path;
    while ( @_ > 1 ) {
        my $tmp = shift;
        push @path, $tmp;
        foreach my $i ( 0, 1 ) {
924 925 926
            my $v = ref($tmp) ? $tmp->[$i] : $tmp;
            $confs[$i]->{$v} //= {};
            $confs[$i] = $confs[$i]->{$v};
927 928 929
        }
    }
    my $target = shift;
Yadd's avatar
Yadd committed
930 931
    hdebug( "# set() called:",
        { data => $data, path => \@path, target => $target } );
932 933 934 935
    die @path unless ($target);

    # Check new value
    if ( defined $data ) {
Yadd's avatar
Yadd committed
936
        hdebug("  data defined");
937 938 939 940 941 942 943 944

        # TODO: remove if $data == default value
        $confs[1]->{$target} = $data;
        eval {
            unless (
                $target eq 'cfgLog'
                or ( defined $confs[0]->{$target}
                    and $confs[0]->{$target} eq $data )
Yadd's avatar
Yadd committed
945
                or (   !defined $confs[0]->{$target}
946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962
                    and defined $self->defaultValue($target)
                    and $data eq $self->defaultValue($target) )
              )
            {
                $self->confChanged(1);
                push @{ $self->changes },
                  {
                    key => join( ', ', @path, $target ),
                    old => $confs[0]->{$target} // $self->defaultValue($target),
                    new => $confs[1]->{$target}
                  };
            }
        };
    }

    # Set old value if exists
    else {
Yadd's avatar
Yadd committed
963
        hdebug("  data undefined");
964
        if ( exists $confs[0]->{$target} ) {
Yadd's avatar
Yadd committed
965
            hdebug("    old value exists");
966 967
            $confs[1]->{$target} = $confs[0]->{$target};
        }
Yadd's avatar
Yadd committed
968 969 970
        else {
            hdebug("    no old value, skipping");
        }
971 972 973 974
    }
}

sub defaultValue {
Yadd's avatar
Yadd committed
975
    my ( $self, $target ) = @_;
Yadd's avatar
Typo  
Yadd committed
976
    hdebug("# defaultValue($target)");
977 978 979 980 981 982 983 984
    die unless ($target);
    my $res = eval {
        &Lemonldap::NG::Manager::Attributes::attributes()->{$target}
          ->{'default'};
    };
    return $res;
}

Yadd's avatar
Yadd committed
985 986 987 988
##@method boolean testNewConf()
# Launch _unitTest() and _globaTest()
#
#@return true if tests succeed
989 990
sub testNewConf {
    my $self = shift;
Yadd's avatar
Yadd committed
991
    hdebug('# testNewConf()');
Yadd's avatar
Yadd committed
992
    return $self->_unitTest( $self->newConf(), '' ) && $self->_globalTest();
993 994
}

Yadd's avatar
Yadd committed
995 996 997 998
##@method private boolean _unitTest()
# Launch unit tests declared in Lemonldap::NG::Manager::Build::Attributes file
#
#@return true if tests succeed
999
sub _unitTest {
Yadd's avatar
Yadd committed
1000
    my ( $self, $conf ) = @_;
Yadd's avatar
Yadd committed
1001
    hdebug('# _unitTest()');
1002 1003 1004 1005
    my $types = &Lemonldap::NG::Manager::Attributes::types();
    my $attrs = &Lemonldap::NG::Manager::Attributes::attributes();
    my $res   = 1;
    foreach my $key ( keys %$conf ) {
1006 1007 1008 1009 1010 1011
        if (    $self->{skippedUnitTests}
            and $self->{skippedUnitTests} =~ /\b$key\b/ )
        {
            $self->logger->debug("Ignore test for $key");
            next;
        }
Yadd's avatar
Yadd committed
1012
        hdebug("Testing $key");
1013 1014
        my $attr = $attrs->{$key};
        my $type = $types->{ $attr->{type} };
1015 1016 1017 1018 1019
        unless ( $type or $attr->{test} ) {
            print STDERR "Unknown attribute $key, deleting it\n";
            delete $conf->{$key};
            next;
        }
1020

Yadd's avatar
Yadd committed
1021
        if ( $attr->{type} and $attr->{type} eq 'subContainer' ) {
1022

Yadd's avatar
Typo  
Yadd committed
1023
            # TODO Recursive for SAML/OIDC nodes
1024 1025
        }
        else {
Yadd's avatar
Yadd committed
1026 1027

            # Check if key exists
1028
            unless ($attr) {
Yadd's avatar
Yadd committed
1029
                push @{ $self->errors }, { message => "__unknownKey__: $key" };
Yadd's avatar
Yadd committed
1030
                $res = 0;
Yadd's avatar
Yadd committed
1031 1032 1033
                next;
            }

Yadd's avatar
Yadd committed
1034
            # Hash parameters
1035
            if ( $key =~ /^$simpleHashKeys$/o ) {
Yadd's avatar
Yadd committed
1036 1037 1038 1039 1040 1041 1042
                $conf->{$key} //= {};
                unless ( ref $conf->{$key} eq 'HASH' ) {
                    push @{ $self->errors },
                      { message => "$key is not a hash ref" };
                    $res = 0;
                    next;
                }
Yadd's avatar
Yadd committed
1043
            }
1044
            elsif ( $attr->{type} =~ /Container$/ ) {
1045

1046 1047
                #TODO
            }
Yadd's avatar
Yadd committed
1048
            if (   $key =~ /^(?:$simpleHashKeys|$doubleHashKeys)$/o
1049 1050
                or $attr->{type} =~ /Container$/ )
            {
1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066
                my $keyMsg = $attr->{keyMsgFail} // $type->{keyMsgFail};
                my $msg    = $attr->{msgFail}    // $type->{msgFail};
                $res = 0
                  unless (
                    $self->_execTest(
                        {
                            keyTest => $attr->{keyTest} // $type->{keyTest},
                            keyMsgFail => $attr->{keyMsgFail}
                              // $type->{keyMsgFail},
                            test    => $attr->{test}    // $type->{test},
                            msgFail => $attr->{msgFail} // $type->{msgFail},
                        },
                        $conf->{$key},
                        $key, $attr, undef, $conf
                    )
                  );
Yadd's avatar
Yadd committed
1067 1068
            }
            elsif ( defined $attr->{keyTest} ) {
Yadd's avatar
Yadd committed
1069 1070 1071 1072

                #TODO
            }
            else {
Yadd's avatar
Yadd committed
1073 1074 1075 1076 1077 1078 1079 1080
                my $msg = $attr->{msgFail} // $type->{msgFail};
                $res = 0
                  unless (
                    $self->_execTest(
                        $attr->{test} // $type->{test},
                        $conf->{$key}, $key, $attr, $msg, $conf
                    )
                  );
1081 1082 1083 1084 1085 1086
            }
        }
    }
    return $res;
}

Yadd's avatar
Yadd committed
1087 1088 1089 1090 1091 1092 1093
##@method private boolean _execTest($test, $value)
# Execute the given test with value
#@param test that can be a code-ref, or a regexp
#@return result of test
sub _execTest {
    my ( $self, $test, $value, $key, $attr, $msg, $conf ) = @_;
    my $ref;
1094 1095
    die
"Malformed test for $key: only regexp ref or sub are accepted (type \"$ref\")"
1096 1097
      unless ( $ref = ref($test) and $ref =~ /^(CODE|Regexp|HASH)$/ );
    if ( $ref eq 'CODE' ) {
Yadd's avatar
Yadd committed