Parser.pm 43.9 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 82 83 84 85 86 87 88 89
sub hdebug {
    if (HIGHDEBUG) {
        foreach my $d (@_) {
            if ( ref $d ) {
                require Data::Dumper;
                print STDERR Data::Dumper::Dumper($d);
            }
            else { print STDERR "$d\n" }
        }
    }
    undef;
}

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

Yadd's avatar
Yadd committed
113 114 115
##@method boolean scanTree()
# Methods to build new conf from JSON string
#@result true if succeed
116 117
sub scanTree {
    my $self = shift;
Yadd's avatar
Yadd committed
118
    hdebug("# scanTree()");
119 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
    # metadatas and set a value to the key if empty
Yadd's avatar
Yadd committed
124 125 126 127
    $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
128
    $self->newConf->{cfgAuthorIP} = $self->req->address;
129
    $self->newConf->{cfgDate}     = time;
130
    $self->newConf->{cfgVersion}  = $VERSION;
131 132 133 134 135 136 137 138
    $self->newConf->{key} ||=
      join( '', map { chr( int( rand(94) ) + 33 ) } ( 1 .. 16 ) );

    return 1;
}

use feature 'state';

Yadd's avatar
Yadd committed
139
##@method private boolean _scanNodes()
140
# Recursive JSON parser
Yadd's avatar
Yadd committed
141
#@result true if succeed
142
sub _scanNodes {
Yadd's avatar
Yadd committed
143
    my ( $self, $tree, ) = @_;
Yadd's avatar
Yadd committed
144
    hdebug("# _scanNodes()");
145 146 147 148 149 150
    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
151 152 153
    unless (@$tree) {
        hdebug('  empty tree !?');
    }
154 155
    foreach my $leaf (@$tree) {
        my $name = $leaf->{title};
Yadd's avatar
Yadd committed
156
        hdebug("Looking to $name");
157 158 159 160 161 162 163 164 165 166 167

        # 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
168
            hdebug("Root special node detected $leaf->{id}");
169 170 171

            # If node has not been opened
            if ( $leaf->{cnodes} ) {
Yadd's avatar
Yadd committed
172
                hdebug("  not opened");
173
                foreach my $k ( @{ $specialNodeHash->{ $leaf->{id} } } ) {
Yadd's avatar
Yadd committed
174
                    hdebug("  copying $k");
175 176 177 178 179 180 181 182 183 184 185 186 187
                    $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
188
                hdebug( "Keys detected as removed:", \@old );
189 190 191 192 193 194 195 196 197 198 199
                $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
200
            hdebug("Special node chield detected $leaf->{id}");
201 202 203 204
            my ( $base, $host ) = ( $1, $2 );

            # Check hostname/partner name changes (id points to the old name)
            $newNames{$host} = $leaf->{title};
205 206 207 208 209 210
            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} };
            }
211 212 213 214 215 216 217 218 219

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

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

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

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

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

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

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

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

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

        # 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
521 522 523
                my @listCatRef =
                  map { $self->refConf->{applicationList}->{$_}->{catname} }
                  keys %{ $self->refConf->{applicationList} };
524
                my @listCatNew =
525
                  map { $self->newConf->{applicationList}->{$_}->{catname} }
526
                  keys(
527 528 529 530 531 532
                    %{
                        ref $self->newConf->{applicationList}
                        ? $self->newConf->{applicationList}
                        : {}
                    }
                  );
533 534 535 536 537 538 539 540 541 542 543 544 545 546 547
                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
548
        elsif ( $leaf->{id} =~ /^applicationList\/(.+)$/ ) {
549
            hdebug('Application list subnode');
550 551 552 553 554 555 556 557 558 559 560 561
            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
562
                hdebug("  looking to cat $cat");
563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579
                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
580
                hdebug('  menu cat');
581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601
                $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
602 603
                my @listCatRef = keys %{ $cmp->{$app} };
                my @listCatNew = keys %{ $cn->{$s} };
604

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

            # Create new apps
            else {
Yadd's avatar
Yadd committed
618
                hdebug('  new app');
619 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
                $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
652 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
        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;
        }
697

Yadd's avatar
Yadd committed
698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715
        # 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;
        }

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

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

                # 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;
                }

751 752 753 754 755 756 757 758 759
                $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
760
                    hdebug("  looking at $n subnode");
Yadd's avatar
Yadd committed
761 762 763
                    if ( ref $n->{data} and ref $n->{data} eq 'ARRAY' ) {
                        $n->{data} = join ';', @{ $n->{data} };
                    }
764 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
                    $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;
        }

794 795 796 797 798 799 800 801 802
        # 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
803 804
            unless ( defined $leaf->{data} ) {
                hdebug('  unopened');
805
                $self->newConf->{$name} = $self->refConf->{$name} || {};
Yadd's avatar
Yadd committed
806
                next;
807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824
            }
            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
825 826
                    $self->newConf->{$name}->{$host}->{ $prm->{k} } =
                      $prm->{v};
827 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
                    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;
        }

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

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

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

896 897 898 899 900 901 902 903
        # 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 );
            }
        }

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

Yadd's avatar
Yadd committed
912 913
##@method private void set($target, @path, $data)
# Store a value in the $target key (following subkeys if @path is set)
914 915 916 917 918 919 920 921 922
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 ) {
923 924 925
            my $v = ref($tmp) ? $tmp->[$i] : $tmp;
            $confs[$i]->{$v} //= {};
            $confs[$i] = $confs[$i]->{$v};
926 927 928
        }
    }
    my $target = shift;
Yadd's avatar
Yadd committed
929 930
    hdebug( "# set() called:",
        { data => $data, path => \@path, target => $target } );
931 932 933 934
    die @path unless ($target);

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

        # 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
944
                or (   !defined $confs[0]->{$target}
945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961
                    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
962
        hdebug("  data undefined");
963
        if ( exists $confs[0]->{$target} ) {
Yadd's avatar
Yadd committed
964
            hdebug("    old value exists");
965 966
            $confs[1]->{$target} = $confs[0]->{$target};
        }
Yadd's avatar
Yadd committed
967 968 969
        else {
            hdebug("    no old value, skipping");
        }
970 971 972 973
    }
}

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

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

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

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

Yadd's avatar
Typo  
Yadd committed
1016
            # TODO Recursive for SAML/OIDC nodes
1017 1018
        }
        else {
Yadd's avatar
Yadd committed
1019 1020

            # Check if key exists
1021
            unless ($attr) {
Yadd's avatar
Yadd committed
1022
                push @{ $self->errors }, { message => "__unknownKey__: $key" };
Yadd's avatar
Yadd committed
1023
                $res = 0;
Yadd's avatar
Yadd committed
1024 1025 1026
                next;
            }

Yadd's avatar
Yadd committed
1027
            # Hash parameters
1028
            if ( $key =~ /^$simpleHashKeys$/o ) {
Yadd's avatar
Yadd committed
1029 1030 1031 1032 1033 1034 1035
                $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
1036
            }
1037
            elsif ( $attr->{type} =~ /Container$/ ) {
1038

1039 1040
                #TODO
            }
Yadd's avatar
Yadd committed
1041
            if (   $key =~ /^(?:$simpleHashKeys|$doubleHashKeys)$/o
1042 1043
                or $attr->{type} =~ /Container$/ )
            {
1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059
                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
1060 1061
            }
            elsif ( defined $attr->{keyTest} ) {
Yadd's avatar
Yadd committed
1062 1063 1064 1065

                #TODO
            }
            else {
Yadd's avatar
Yadd committed
1066 1067 1068 1069 1070 1071 1072 1073
                my $msg = $attr->{msgFail} // $type->{msgFail};
                $res = 0
                  unless (
                    $self->_execTest(
                        $attr->{test} // $type->{test},
                        $conf->{$key}, $key, $attr, $msg, $conf
                    )
                  );
1074 1075 1076 1077 1078 1079
            }
        }
    }
    return $res;
}

Yadd's avatar
Yadd committed
1080 1081 1082 1083 1084 1085 1086
##@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;
1087 1088
    die
"Malformed test for $key: only regexp ref or sub are accepted (type \"$ref\")"
1089 1090
      unless ( $ref = ref($test) and $ref =~ /^(CODE|Regexp|HASH)$/ );
    if ( $ref eq 'CODE' ) {
Yadd's avatar
Yadd committed
1091
        my ( $r, $m ) = ( $test->( $value, $conf, $attr ) );
1092 1093 1094 1095