Manager.pm 27 KB
Newer Older
1 2 3 4 5
package Lemonldap::NG::Manager;

use strict;

use XML::Simple;
6

7 8
use Lemonldap::NG::Manager::Base;
use Lemonldap::NG::Manager::Conf;
9
use Lemonldap::NG::Manager::_HTML;
10
require Lemonldap::NG::Manager::_Response;
11 12
require Lemonldap::NG::Manager::_i18n;
require Lemonldap::NG::Manager::Help;
13
use Lemonldap::NG::Manager::Conf::Constants;
14
use LWP::UserAgent;
15 16
use Safe;
use MIME::Base64;
17 18 19

our @ISA = qw(Lemonldap::NG::Manager::Base);

20
our $VERSION = '0.82';
21 22

sub new {
23
    my ( $class, $args ) = @_;
24
    my $self = $class->SUPER::new();
25 26 27
    unless ($args) {
        print STDERR "parameters are required, I can't start so\n";
        return 0;
28
    }
29 30 31 32 33
    %$self = ( %$self, %$args );
    foreach (qw(configStorage dhtmlXTreeImageLocation)) {
        unless ( $self->{$_} ) {
            print STDERR qq/The "$_" parameter is required\n/;
            return 0;
34 35
        }
    }
36 37 38
    $self->{jsFile} ||= $self->_dir . "lemonldap-ng-manager.js";
    unless ( -r $self->{jsFile} ) {
        print STDERR qq#Unable to read $self->{jsFile}. You have to set "jsFile" parameter to /path/to/lemonldap-ng-manager.js\n#;
39
    }
40 41 42
    unless ( __PACKAGE__->can('ldapServer') ) {
        Lemonldap::NG::Manager::_i18n::import( $ENV{HTTP_ACCEPT_LANGUAGE} );
    }
43
    if ( $self->param('lmQuery') ) {
44
        my $tmp = "print_" . $self->param('lmQuery');
45
        $self->$tmp;
46 47
    }
    else {
48 49 50 51 52 53 54
        my $datas;
        if ( $datas = $self->param('POSTDATA') ) {
            $self->print_upload( \$datas );
        }
        else {
            return $self;
        }
55 56 57 58 59 60 61
    }
    exit;
}

# Subroutines to make all the work
sub doall {
    my $self = shift;
62 63 64
    # When using header_public here, Firefox does not load configuration
    # sometimes. Where is the bug ?
    print $self->header;
65 66 67 68 69 70 71 72
    print $self->start_html;
    print $self->main;
    print $self->end_html;
}

# CSS and Javascript export
sub print_css {
    my $self = shift;
73
    print $self->header_public( $ENV{SCRIPT_FILENAME}, -type => 'text/css' );
74 75 76 77 78
    $self->css;
}

sub print_libjs {
    my $self = shift;
79 80
    print $self->header_public( $self->{jsFile},
        -type => 'application/x-javascript' );
81
    open F, $self->{jsFile};
82 83
    while (<F>) {
        print;
84 85 86 87 88 89
    }
    close F;
}

sub print_lmjs {
    my $self = shift;
90 91
    print $self->header_public( $ENV{SCRIPT_FILENAME},
        -type => 'text/javascript' );
92 93 94 95 96 97 98
    $self->javascript;
}

# HELP subroutines

sub print_help {
    my $self = shift;
99
    print $self->header_public;
100 101 102 103
    Lemonldap::NG::Manager::Help::import( $ENV{HTTP_ACCEPT_LANGUAGE} )
      unless ( $self->can('help_groups') );
    my $chap = $self->param('help');
    eval { no strict "refs"; &{"help_$chap"} };
104 105
}

106 107 108 109 110 111 112
# Delete subroutine

sub print_delete {
    my $self = shift;
    print $self->header;
    Lemonldap::NG::Manager::Help::import( $ENV{HTTP_ACCEPT_LANGUAGE} )
      unless ( $self->can('help_groups') );
113
    if ( $self->config->delete( $self->param('cfgNum') ) ) {
114 115 116 117 118 119 120 121
        print &txt_configurationDeleted;
    }
    else {
        print &txt_configurationNotDeleted;
    }
    exit;
}

122 123 124 125
# Configuration download subroutines
sub print_conf {
    my $self = shift;
    print $self->header( -type => "text/xml", '-Cache-Control' => 'private' );
126
    $self->printXmlConf( { cfgNum => $self->param('cfgNum'), } );
127 128 129 130 131
    exit;
}

sub default {
    return {
132 133 134
        cfgNum   => 0,
        ldapBase => "dc=example,dc=com",
    };
135 136 137
}

sub printXmlConf {
138
    my $self = shift;
139
    print XMLout(
140
        $self->buildTree(@_),
141 142 143
        #XMLDecl  => "<?xml version='1.0' encoding='iso-8859-1'?>",
        RootName => 'tree',
        KeyAttr  => { item => 'id', username => 'name' },
144 145
        NoIndent => 1,
        NoSort   => 0,
146 147 148 149
    );
}

sub buildTree {
150
    my $self   = shift;
151
    my $config = $self->config->getConf(@_);
152
    $config = $self->default unless ($config);
153
    my $indice = 1;
154
    my $tree = {
155 156 157 158
        id   => '0',
        item => {
            id   => 'root',
            open => 1,
159
            text => &txt_configuration . " $config->{cfgNum}",
160 161
            item => {
                generalParameters => {
162
                    text => &txt_generalParameters,
163 164
                    item => {
                        exportedVars => {
165
                            text => &txt_exportedVars,
166 167
                            item => {},
                        },
Xavier Guimard's avatar
Xavier Guimard committed
168
                        macros => {
169
                            text => &txt_macros,
Xavier Guimard's avatar
Xavier Guimard committed
170
                        },
171
                        ldapParameters => {
172
                            text => &txt_ldapParameters,
173 174 175
                            item => {},
                        },
                        sessionStorage => {
176
                            text => &txt_sessionStorage,
177
                            item => {
178
                                globalStorageOptions =>
179
                                  { text => &txt_globalStorageOptions, }
180 181
                            },
                        },
182
                        authParams => {
183
                            text => &txt_authParams,
184 185
                            item => {},
                        },
186 187
                    },
                },
188
                groups       => { text => &txt_userGroups, },
189
                virtualHosts => {
190 191 192
                    text   => &txt_virtualHosts,
                    open   => 1,
                    select => 1,
193 194 195 196 197
                },
            },
        },
    };
    my $generalParameters = $tree->{item}->{item}->{generalParameters}->{item};
198
    my $exportedVars =
199
      $tree->{item}->{item}->{generalParameters}->{item}->{exportedVars}->{item};
200
    my $ldapParameters =
201
      $tree->{item}->{item}->{generalParameters}->{item}->{ldapParameters}->{item};
202
    my $sessionStorage =
203
      $tree->{item}->{item}->{generalParameters}->{item}->{sessionStorage}->{item};
204
    my $globalStorageOptions =
205
      $tree->{item}->{item}->{generalParameters}->{item}->{sessionStorage}->{item}->{globalStorageOptions}->{item};
206 207 208 209
    my $authParams =
      $tree->{item}->{item}->{generalParameters}->{item}->{authParams}->{item};
    $authParams->{authentication} =
      $self->xmlField( "value", $config->{authentication} || 'ldap',
210
        &txt_authenticationType, );
211
    $authParams->{portal} =
212
      $self->xmlField( "value", $config->{portal} || 'http://portal/',
213
        "Portail" );
214
    $authParams->{securedCookie} =
215 216 217
      $self->xmlField( "value", $config->{securedCookie} || 0, &txt_securedCookie );
    $generalParameters->{whatToTrace} =
      $self->xmlField( "value", $config->{whatToTrace} || '$uid', &txt_whatToTrace );
218

219
    $generalParameters->{domain} =
220
      $self->xmlField( "value", $config->{domain} || 'example.com', &txt_domain, );
221 222
    $generalParameters->{cookieName} =
      $self->xmlField( "value", $config->{cookieName} || 'lemonldap',
223
        &txt_cookieName, );
224

225 226
    $sessionStorage->{globalStorage} =
      $self->xmlField( "value",
227
        $config->{globalStorage} || 'Apache::Session::File',
228
        &txt_apacheSessionModule, );
229 230 231

    $ldapParameters->{ldapServer} =
      $self->xmlField( "value", $config->{ldapServer} || 'localhost',
232
        &txt_ldapServer, );
233
    $ldapParameters->{ldapPort} =
234
      $self->xmlField( "value", $config->{ldapPort} || 389, &txt_ldapPort, );
235
    $ldapParameters->{ldapBase} =
236
      $self->xmlField( "value", $config->{ldapBase} || ' ', &txt_ldapBase, );
237
    $ldapParameters->{managerDn} =
238
      $self->xmlField( "value", $config->{managerDn} || ' ', &txt_managerDn, );
239 240
    $ldapParameters->{managerPassword} =
      $self->xmlField( "value", $config->{managerPassword} || ' ',
241
        &txt_managerPassword, );
242 243

    if ( $config->{exportedVars} ) {
244 245
        foreach my $n ( sort keys %{ $config->{exportedVars} } ) {
            $exportedVars->{ sprintf( "ev_%010d", $indice) } = $self->xmlField( "both", $config->{exportedVars}->{$n}, $n );
246
            $indice++;
247 248 249
        }
    }
    else {
250 251 252
        foreach (qw(cn mail uid)) {
            $exportedVars->{ sprintf( "ev_%010d", $indice) } = $self->xmlField( 'both', $_, $_ );
            $indice++;
253 254 255
        }
    }

256 257 258
    if ( $config->{globalStorageOptions}
        and %{ $config->{globalStorageOptions} } )
    {
259
        $tree->{item}->{item}->{generalParameters}->{item}->{sessionStorage}->{item}->{globalStorageOptions}->{item} = {};
260
        $globalStorageOptions =
261
          $tree->{item}->{item}->{generalParameters}->{item}->{sessionStorage}->{item}->{globalStorageOptions}->{item};
262
        foreach my $n ( sort keys %{ $config->{globalStorageOptions} } ) {
263
            $globalStorageOptions->{ sprintf( "go_%010d", $indice) } = $self->xmlField( "both", $config->{globalStorageOptions}->{$n}, $n );
264
            $indice++;
265 266 267 268 269
        }
    }
    else {
    }

270
    if ( $config->{locationRules} and %{ $config->{locationRules} } ) {
271 272
        $tree->{item}->{item}->{virtualHosts}->{item} = {};
        my $virtualHost = $tree->{item}->{item}->{virtualHosts}->{item};
273
        # TODO: split locationRules into 2 arrays
274 275 276
        foreach my $host ( sort keys %{ $config->{locationRules} } ) {
            my $rules = $config->{locationRules}->{$host};
            my $vh_id = sprintf( "vh_%010d", $indice );
277 278
            $indice++;
            $virtualHost->{$vh_id} = $self->xmlField( "text", 'i', $host );
279 280
            my ( $ih, $ir ) =
              ( "exportedHeaders_$indice", "locationRules_$indice" );
281
            $virtualHost->{$vh_id}->{item} = {
282 283
                "$ih" => { text => &txt_httpHeaders, },
                "$ir" => { text => &txt_locationRules, },
284
            };
285
            foreach my $reg ( sort keys %$rules ) {
286
                my $type = ( $reg eq 'default' ) ? 'value' : 'both';
287 288
                $virtualHost->{$vh_id}->{item}->{$ir}->{item}->{ sprintf( "r_%010d", $indice ) } =
                  $self->xmlField( $type, $rules->{$reg} , $reg );
289 290 291
                $indice++;
            }
            my $headers = $config->{exportedHeaders}->{$host};
292 293 294
            foreach my $h ( sort keys %$headers ) {
                $virtualHost->{$vh_id}->{item}->{$ih}->{item}->{ sprintf( "h_%010d", $indice ) } =
                  $self->xmlField( "both", $headers->{$h}, $h );
295 296 297 298
                $indice++;
            }
        }
    }
299
    if ( $config->{groups} and %{ $config->{groups} } ) {
300 301
        $tree->{item}->{item}->{groups}->{item} = {};
        my $groups = $tree->{item}->{item}->{groups}->{item};
302 303
        foreach my $group ( sort keys  %{ $config->{groups} } ) {
            $groups->{ sprintf( "g_%010d", $indice) } = $self->xmlField( 'both', $config->{groups}->{$group}, $group );
304
            $indice++;
305 306
        }
    }
307
    if ( $config->{macros} and %{ $config->{macros} } ) {
Xavier Guimard's avatar
Xavier Guimard committed
308 309
        $tree->{item}->{item}->{generalParameters}->{item}->{macros}->{item} = {};
        my $macros = $tree->{item}->{item}->{generalParameters}->{item}->{macros}->{item};
310 311
        foreach my $macro ( sort keys %{ $config->{macros} } ) {
            $macros->{"m_$indice"} = $self->xmlField( 'both', $config->{macros}->{$macro}, $macro );
312
            $indice++;
Xavier Guimard's avatar
Xavier Guimard committed
313
        }
314
    }
315
    return $tree;
316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334
}

sub xmlField {
    my ( $self, $type, $value, $text ) = @_;
    $value =~ s/"/\&#34;/g;
    $text  =~ s/"/\&#34;/g;
    return {
        text     => $text,
        aCol     => "#000000",
        sCol     => "#0000FF",
        userdata => [
            { name => 'value', content => $value },
            { name => 'modif', content => $type },
        ],
    };
}

# Upload subroutines
sub print_upload {
335
    my $self  = shift;
336
    my $datas = shift;
337 338
    print $self->header( -type => "text/javascript" );
    my $r = Lemonldap::NG::Manager::_Response->new();
339 340 341
    my $tmp = $self->upload( $datas, $r );
    if ( $tmp == 0 ) {
        $r->message( &txt_unknownError, &txt_checkLogs );
342
    }
343
    elsif ( $tmp > 0 ) {
344
        $r->setConfiguration($tmp);
345
        $r->message( &txt_confSaved . " $tmp", &txt_warningConfNotApplied );
346
    }
347 348
    elsif ( $tmp == CONFIG_WAS_CHANGED ) {
        $r->message( &txt_saveFailure, &txt_configurationWasChanged );
349
    }
350 351
    elsif ( $tmp == SYNTAX_ERROR ) {
        $r->message( &txt_saveFailure, &txt_syntaxError );
352 353
    }
    $r->send;
354 355 356
}

sub upload {
357 358
    my $self     = shift;
    my $tree     = shift;
359
    my $response = shift;
360 361
    my $config   = $self->tree2conf( $tree, $response );
    return SYNTAX_ERROR unless ( $self->checkConf( $config, $response ) );
362 363 364 365
    return $self->config->saveConf($config);
}

sub tree2conf {
366
    my ( $self, $tree, $response ) = @_;
367
    $tree = XMLin($$tree);
368
    my $config = {};
369
    # Load config number
370
    ( $config->{cfgNum} ) = ( $tree->{text} =~ /(\d+)$/ );
371
    # Load groups
372 373
    while ( my ( $g, $h ) = each( %{ $tree->{groups} } ) ) {
        next unless ( ref($h) );
374
        $config->{groups}->{ $h->{text} } = $h->{value};
375
    }
376
    # Load virtualHosts
377
    while ( my ( $k, $h ) = each( %{ $tree->{virtualHosts} } ) ) {
378
        next unless ( ref($h) );
379 380 381 382 383 384
        my $lr;
        my $eh;
        foreach ( keys(%$h) ) {
            $lr = $h->{$_} if ( $_ =~ /locationRules/ );
            $eh = $h->{$_} if ( $_ =~ /exportedHeaders/ );
        }
385
        my $vh = $h->{text};
386
        # TODO: split locationRules into 2 arrays
387 388 389 390 391 392 393 394 395
      LR: foreach my $r ( values(%$lr) ) {
            next LR unless ( ref($r) );
            $config->{locationRules}->{$vh}->{ $r->{text} } = $r->{value};
        }
      EH: foreach my $h ( values(%$eh) ) {
            next EH unless ( ref($h) );
            $config->{exportedHeaders}->{$vh}->{ $h->{text} } = $h->{value};
        }
    }
396
    # General parameters
397
    $config->{cookieName}  = $tree->{generalParameters}->{cookieName}->{value};
398
    $config->{whatToTrace} = $tree->{generalParameters}->{whatToTrace}->{value};
399
    $config->{domain}      = $tree->{generalParameters}->{domain}->{value};
400 401
    $config->{globalStorage} = $tree->{generalParameters}->{sessionStorage}->{globalStorage}->{value};
    while ( my ( $v, $h ) = each( %{ $tree->{generalParameters}->{sessionStorage}->{globalStorageOptions} })) {
402
        next unless ( ref($h) );
403
        $config->{globalStorageOptions}->{ $h->{text} } = $h->{value};
404
    }
405
    while ( my ( $v, $h ) = each( %{ $tree->{generalParameters}->{macros} } ) ) {
406
        next unless ( ref($h) );
Xavier Guimard's avatar
Xavier Guimard committed
407
        $config->{macros}->{ $h->{text} } = $h->{value};
408
    }
409
    foreach (qw(ldapBase ldapPort ldapServer managerDn managerPassword)) {
410 411 412 413
        $config->{$_} =
          $tree->{generalParameters}->{ldapParameters}->{$_}->{value};
        $config->{$_} = '' if ( ref( $config->{$_} ) );
        $config->{$_} =~ s/^\s*(.*?)\s*/$1/;
414 415
    }
    foreach (qw(authentication portal securedCookie)) {
416 417 418
        $config->{$_} = $tree->{generalParameters}->{authParams}->{$_}->{value};
        $config->{$_} = '' if ( ref( $config->{$_} ) );
        $config->{$_} =~ s/^\s*(.*?)\s*/$1/;
419
    }
420 421 422
    while ( my ( $v, $h ) =
        each( %{ $tree->{generalParameters}->{exportedVars} } ) )
    {
423
        next unless ( ref($h) );
424
        $config->{exportedVars}->{ $h->{text} } = $h->{value};
425
    }
426
    return $config;
427 428
}

429
# Configuration check : before saving, we try to find faults in configuration
430
sub checkConf {
431 432
    my $self     = shift;
    my $config   = shift;
433
    my $response = shift;
434 435
    my $expr     = '';
    my $result   = 1;
436
    my $assign   = qr/(?<=[^=<!>\?])=(?![=~])/;
437
    # Check cookie name
438
    unless ( $config->{cookieName} =~ /^[a-zA-Z]\w*$/ ) {
439
        $result = 0;
440
        $response->error( '"' . $config->{cookieName} . '" ' . &txt_isNotAValidCookieName );
441
    }
442
    # Check domain name
443
    unless ( $config->{domain} =~ /^(?=^.{1,254}$)(?:(?!\d+\.)[\w\-]{1,63}\.?)+(?:[a-zA-Z]{2,})$/ ) {
444
        $result = 0;
445
        $response->error( '"' . $config->{domain} . '" ' . &txt_isNotAValidCookieName );
446
    }
447 448 449 450
    # Customized variables
    foreach ( @{ $self->{customVars} } ) {
        $expr .= "my \$$_ = '1';";
    }
451
    # Load variables
452
    foreach ( keys %{ $config->{exportedVars} } ) {
453
        # Reserved words
454
        if ( $_ eq 'groups' or $_ !~ /^\w+$/ ) {
455
            $response->error( "\"$_\" " . &txt_isNotAValidAttributeName );
456 457
            $result = 0;
        }
458 459
        if ( $config->{exportedVars}->{$_} !~ /^\w+$/ ) {
            $response->error( "\"$config->{exportedVars}->{$_}\" " . &txt_isNotAValidLDAPAttributeName );
460
            $result = 0;
461 462 463 464 465
        }
        $expr .= "my \$$_ = '1';";
    }
    # Load and check macros
    my $safe = new Safe;
466 467 468
    $safe->share('&encode_base64');
    $safe->reval($expr);
    if ($@) {
469
        $result = 0;
470
        $response->error( &txt_unknownErrorInVars . " ($@)" );
471
    }
472 473 474 475
    while ( my ( $k, $v ) = each( %{ $config->{macros} } ) ) {
        # Syntax
        if ( $k eq 'groups' or $k !~ /^[a-zA-Z]\w*$/ ) {
            $response->error( "\"$k\" " . &txt_isNotAValidMacroName );
476 477
            $result = 0;
        }
478
        # "=" may be a fault ("==")
479
        if ( $v =~ $assign ) {
480
            $response->warning( &txt_macro . " $k " . &txt_containsAnAssignment );
481
        }
482
        # Test macro values;
483
        $expr .= "my \$$k = $v;";
484 485
        $safe->reval($expr);
        if ($@) {
486 487 488
            $response->error( &txt_macro . " $k : " . &txt_syntaxError . " : $@");
            $result = 0;
        }
489 490 491 492
    }
    # TODO: check module name
    # Check whatToTrace
    unless ( $config->{whatToTrace} =~ /^\$?[a-zA-Z]\w*$/ ) {
493
        $response->error(&txt_invalidWhatToTrace);
494
        $result = 0;
495
    }
496 497
    # Test groups
    $expr .= 'my $groups;';
498 499 500 501
    while ( my ( $k, $v ) = each( %{ $config->{groups} } ) ) {
        # Name syntax
        if ( $k !~ /^[\w-]+$/ ) {
            $response->error( "\"$k\" " . &txt_isNotAValidGroupName );
502 503
            $result = 0;
        }
504
        # "=" may be a fault (but not "==")
505
        if ( $v =~ $assign ) {
506
            $response->warning( &txt_group . " $k " . &txt_containsAnAssignment );
507
        }
508 509 510
        # Test boolean expression
        $safe->reval( $expr . "\$groups = '$k' if($v);" );
        if ($@) {
511
            $response->error( &txt_group . " $k " . &txt_syntaxError );
512
            $result = 0;
513 514 515
        }
    }
    # Test rules
516 517 518 519
    while ( my ( $vh, $rules ) = each( %{ $config->{locationRules} } ) ) {
        # Virtual host name has to be a fully qualified name or an IP address (CDA)
        unless ( $vh =~ /^(?:(?=^.{1,254}$)(?:(?!\d+\.)[\w\-]{1,63}\.?)+(?:[a-zA-Z]{2,})|(?:\d{1,3}\.){3}\d{1,3})$/ ) {
            $response->error( "\"$vh\" " . &txt_isNotAValidVirtualHostName );
520
            $result = 0;
521
        }
522 523 524
        while ( my ( $reg, $v ) = each( %{$rules} ) ) {
            # Test regular expressions
            unless ( $reg eq 'default' ) {
525 526
                $reg =~ s/#/\\#/g;
                $safe->reval( $expr . "my \$r = qr#$reg#;" );
527
                if ($@) {
528
                    $response->error( &txt_rule . " $vh -> \"$reg\" : " . &txt_syntaxError );
529
                    $result = 0;
530 531
                }
            }
532
            # Test boolean expressions
533
            unless ( $v =~ /^(?:accept$|deny$|logout)/ ) {
534
                # "=" may be a fault (but not "==")
535
                if ( $v =~ $assign ) {
536
                    $response->warning( &txt_rule . " $vh -> \"$reg\" : " . &txt_containsAnAssignment );
537
                }
538 539 540

                $safe->reval( $expr . "my \$r=1 if($v);" );
                if ($@) {
541
                    $response->error( &txt_rule . " $vh -> \"$reg\" : " . &txt_syntaxError );
542
                    $result = 0;
543 544 545 546 547
                }
            }
        }
    }
    # Test exported headers
548 549 550 551
    while ( my ( $vh, $headers ) = each( %{ $config->{exportedHeaders} } ) ) {
        # Virtual host name has to be a fully qualified name or an IP address (CDA)
        unless ( $vh =~ /^(?:(?=^.{1,254}$)(?:(?!\d+\.)[\w\-]{1,63}\.?)+(?:[a-zA-Z]{2,})|(?:\d{1,3}\.){3}\d{1,3})$/ ) {
            $response->error( "\"$vh\" " . &txt_isNotAValidVirtualHostName );
552
            $result = 0;
553
        }
554 555 556 557
        while ( my ( $header, $v ) = each( %{$headers} ) ) {
            # Header name syntax
            unless ( $header =~ /^[\w][-\w]*$/ ) {
                $response->error( "\"$header\" ($vh) " . &txt_isNotAValidHTTPHeaderName );
558 559
                $result = 0;
            }
560
            # "=" may be a fault ("==")
561
            if ( $v =~ $assign ) {
562
                $response->warning( &txt_header . " $vh -> $header " . &txt_containsAnAssignment );
563
            }
564
            # Perl expression
565
            $safe->reval( $expr . "my \$r = $v;" );
566 567
            if ($@) {
                $response->error( &txt_header . " $vh -> $header " . &txt_syntaxError );
568
                $result = 0;
569 570 571
            }
        }
    }
572
    return $result;
573 574
}

575 576 577 578 579 580
# Apply subroutines
# TODO: Credentials in applyConfFile

sub print_apply {
    my $self = shift;
    print $self->header( -type => "text/html" );
581 582
    unless ( -r $self->{applyConfFile} ) {
        print "<h3>" . &txt_canNotReadApplyConfFile . "</h3>";
583 584 585 586 587 588
        return;
    }
    print '<h3>' . &txt_result . ' : </h3><ul>';
    open F, $self->{applyConfFile};
    my $ua = new LWP::UserAgent( requests_redirectable => [] );
    $ua->timeout(10);
589
    while (<F>) {
590 591
        local $| = 1;
        # pass blank lines and comments
592
        next if ( /^$/ or /^\s*#/ );
593 594 595 596
        chomp;
        s/\r//;
        # each line must be like:
        #    host  http(s)://vhost/request/
597 598 599
        my ( $host, $request ) = (/^\s*([^\s]+)\s+([^\s]+)$/);
        unless ( $host and $request ) {
            print "<li> " . &txt_invalidLine . ": $_</li>";
600 601 602
            next;
        }
        my ( $method, $vhost, $uri ) = ( $request =~ /^(https?):\/\/([^\/]+)(.*)$/ );
603
        unless ($vhost) {
604
            $vhost = $host;
605
            $uri   = $request;
606 607
        }
        print "<li>$host ... ";
608 609
        my $r = HTTP::Request->new( 'GET', "$method://$host$uri", HTTP::Headers->new( Host => $vhost ) );
        my $response = $ua->request($r);
610 611 612 613 614 615 616 617 618 619
        if ( $response->code != 200 ) {
            print join( ' ', &txt_error, ":", $response->code, $response->message, "</li>");
        }
        else {
            print "OK</li>";
        }
    }
    print "</ul><p>" . &txt_changesAppliedLater . "</p>";
}

620 621
# Internal subroutines
sub _dir {
622
    my $d = $ENV{SCRIPT_FILENAME};
623 624 625 626 627 628 629
    $d =~ s#[^/]*$##;
    return $d;
}

sub config {
    my $self = shift;
    return $self->{_config} if $self->{_config};
630 631 632 633
    $self->{_config} =
      Lemonldap::NG::Manager::Conf->new( $self->{configStorage} );
    unless ( $self->{_config} ) {
        die "Configuration not loaded\n";
634 635 636 637
    }
    return $self->{_config};
}

638 639
# Those sub are loaded en demand. With &header_public, they are not loaded each
# time.
640 641 642 643
*css        = *Lemonldap::NG::Manager::_HTML::css;
*javascript = *Lemonldap::NG::Manager::_HTML::javascript;
*main       = *Lemonldap::NG::Manager::_HTML::main;
*start_html = *Lemonldap::NG::Manager::_HTML::start_html;
644

645
__END__
646

647 648 649 650 651 652 653 654 655 656 657 658 659 660 661
=head1 NAME

Lemonldap::NG::Manager - Perl extension for managing Lemonldap::NG Web-SSO
system.

=head1 SYNOPSIS

  use Lemonldap::NG::Manager;
  my $h=new Lemonldap::NG::Manager(
      {
        configStorage=>{
            type=>'File',
            dirName=>"/tmp/",
        },
        dhtmlXTreeImageLocation=> "/devel/img/",
662 663
        # uncomment this only if lemonldap-ng-manager.js is not in the same
        # directory than your script.
664 665 666 667 668 669 670 671 672 673 674
        # jsFile => /path/to/lemonldap-ng-manager.js,
      }
    ) or die "Unable to start, see Apache logs";
  # Simple
  $h->doall();

You can also peersonalize the HTML code instead of using C<doall()>:

  print $self->header_public;
  print $self->start_html (  # See CGI(3) for more about start_html
        -style => "/location/to/my.css",
675
        -title => "Example.com SSO configuration",
676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719
        );
  # optional HTML code for the top of the page
  print "<img src=...";
  print $self->main;
  # optional HTML code for the footer of the page
  print "<img src=...";
  
  print $self->end_html;

=head1 DESCRIPTION

Lemonldap::NG::Manager provides a web interface to manage Lemonldap::NG Web-SSO
system.

=head2 SUBROUTINES

=over

=item * B<new> (constructor): new instanciates the manager object. It takes the
following arguments:

=over

=item * B<configStorage> (required): a hash reference to the description of the
configuration database system. the key 'type' must be set. Example:

  configStorage => {
      type => "DBI",
      dbiChain    => "DBI:mysql:database=session;host=1.2.3.4",
      dbiUser     => "lemonldap-ng",
      dbiPassword => "pass",
  }

See L<Lemonldap::Manager::NG::Manager::Conf::File> or
L<Lemonldap::Manager::NG::Manager::Conf::DBI> to know which keys are required.

=item * B<dhtmlXTreeImageLocation> (required): the location of the directory
containing dhtmlXTree images (provided in example/imgs). If this parameter
isn't correct, the tree will not appear and you will have sone error in Apache
error logs.

=item * B<jsFile> (optional): the path to the file C<lemonldap-ng-manager.js>.
It is required only if this file is not in the same directory than your script.

720 721 722 723 724 725 726 727 728
=item * B<applyConfFile> (optional): the path to a file containing parameters
to make configuration reloaded by handlers. See C<reload> function in
L<Lemonldap::NG::Handler>. The configuration file must contains lines like:

  # Comments if wanted
  host  http://virtual-host/reload-path

When this parameter is set, an "apply" button is added to the manager menu.

729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746
=back

=item * B<doall>: subroutine that provide headers and the full html code. Il
simply calls C<header_public>, C<start_html>, C<main> and C<end_html> in this
order.

=item * B<header>: print HTTP headers. See L<CGI> for more.

=item * B<header_public>: print HTTP headers and manage the
C<If-Modified-Since> HTTP header. If it match to the age of the file passed
in first argument, it returns C<HTTP 304 Not Modified> end exit. Else, it
calls C<header> with the other arguments. By default, all elements of the
manager use this mecanism except the configuration itself.

=item * B<start_html>: subroutine that print the HTML headers. you can add
parameters to it; example;

  print start_html(-title     => 'My SSO configuration',
747 748 749 750 751 752
                  -author     => 'fred@capricorn.org',
                  -target     => '_blank',
                  -meta       => {'keywords'=>'pharaoh secret mummy',
                  'copyright' => 'copyright 1996 King Tut'},
                  -style      => {'src'=>'/styles/style1.css'},
                  -BGCOLOR    => 'blue');
753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770

See start_html description in L<CGI> for more. Bee carefull with C<-style>
argument. You have to call it like the example above or simply like this:
  -style=> '/styles/style1.css',
All other forms will not work.

=item * B<main>: il produce the main HTML code needed to build the
configuration interface.

=item * B<end_html>: close the HTML code by writing C<'E<lt>/bodyE<gt>E<lt>/htmlE<gt>'>

=back

Other subroutines manage the produce of CSS, Javascripts and of course the
configuration tree (called with AJAX).

=head1 SEE ALSO

771 772
L<Lemonldap::NG::Handler>, L<Lemonldap::NG::Portal>, L<CGI>,
http://wiki.lemonldap.objectweb.org/xwiki/bin/view/NG/Presentation
773 774 775 776 777

=head1 AUTHOR

Xavier Guimard, E<lt>x.guimard@free.frE<gt>

Xavier Guimard's avatar
Xavier Guimard committed
778 779 780 781 782 783 784 785 786 787
=head1 BUG REPORT

Use OW2 system to report bug or ask for features:
L<http://forge.objectweb.org/tracker/?group_id=274>

=head1 DOWNLOAD

Lemonldap::NG is available at
L<http://forge.objectweb.org/project/showfiles.php?group_id=274>

788 789
=head1 COPYRIGHT AND LICENSE

790
Copyright (C) 2006-2007 by Xavier Guimard
791 792 793 794 795 796

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.

=cut
797