Reload.pm 19.9 KB
Newer Older
1 2
package Lemonldap::NG::Handler::Main::Reload;

Xavier Guimard's avatar
Xavier Guimard committed
3
our $VERSION = '2.1.0';
4 5 6

package Lemonldap::NG::Handler::Main;

7 8 9 10 11
use strict;
use Lemonldap::NG::Common::Conf::Constants;    #inherits
use Lemonldap::NG::Common::Crypto;
use Lemonldap::NG::Common::Safelib;            #link protected safe Safe object
use Lemonldap::NG::Handler::Main::Jail;
12
use Scalar::Util qw(weaken);
13 14 15 16

use constant UNPROTECT => 1;
use constant SKIP      => 2;

17
our @_onReload;
18

19 20 21 22
sub onReload {
    my ( $class, $obj, $sub ) = @_;
    weaken($obj);
    push @_onReload, [ $obj, $sub ];
23 24
}

25
# CONFIGURATION UPDATE
26

27 28 29 30 31 32 33 34 35
## @rmethod protected int checkConf(boolean force)
# Check if configuration is up to date, and reload it if needed.
# If the optional boolean $force is set to true,
# * cached configuration is ignored
# * and checkConf returns false if it fails to load remote config
# @param $force boolean
# @return true if config is up to date or if reload config succeeded
sub checkConf {
    my ( $class, $force ) = @_;
36
    $class->logger->debug("Check configuration for $class");
37
    my $prm  = { local => !$force, localPrm => $class->localConfig };
38
    my $conf = $class->confAcc->getConf($prm);
39
    chomp $Lemonldap::NG::Common::Conf::msg;
40 41

    unless ( ref($conf) ) {
42 43
        $class->logger->error(
"$class: Unable to load configuration: $Lemonldap::NG::Common::Conf::msg"
44 45 46 47
        );
        return $force ? 0 : $class->cfgNum ? 1 : 0;
    }

48 49 50 51 52 53 54 55 56 57 58
    if ($Lemonldap::NG::Common::Conf::msg) {
        if ( $Lemonldap::NG::Common::Conf::msg =~ /Error:/ ) {
            $class->logger->error($Lemonldap::NG::Common::Conf::msg);
        }
        elsif ( $Lemonldap::NG::Common::Conf::msg =~ /Warn:/ ) {
            $class->logger->warn($Lemonldap::NG::Common::Conf::msg);
        }
        else {
            $class->logger->debug($Lemonldap::NG::Common::Conf::msg);
        }
    }
59
    if ( $force or !$class->cfgNum or $class->cfgNum != $conf->{cfgNum} ) {
60
        $class->logger->debug("Get configuration $conf->{cfgNum}");
61
        unless ( $class->cfgNum( $conf->{cfgNum} ) ) {
62
            $class->logger->error('No configuration available');
63 64 65
            return 0;
        }
        $class->configReload($conf);
66 67 68 69 70 71 72 73 74
        foreach (@_onReload) {
            my ( $obj, $sub ) = @$_;
            if ($obj) {
                $class->logger->debug(
                    'Launching ' . ref($obj) . "->$sub(conf)" );
                unless ( $obj->$sub($conf) ) {
                    $class->logger->error( "Underlying object can't load conf ("
                          . ref($obj)
                          . "->$sub)" );
75
                    return 0;
76
                }
77 78
            }
        }
79
    }
80 81
    $class->tsv->{checkTime} = $conf->{checkTime} if ( $conf->{checkTime} );
    $class->lastCheck( time() );
82
    $class->logger->debug("$class: configuration is up to date");
83 84 85 86 87 88 89 90 91 92 93 94
    return 1;
}

# RELOAD SYSTEM

## @rmethod int reload
# Launch checkConf() with $local=0, so remote configuration is tested.
# Then build a simple HTTP response that just returns "200 OK" or
# "500 Server Error".
# @return Apache constant ($class->OK or $class->SERVER_ERROR)
sub reload {
    my $class = shift;
95
    $class->logger->notice("Request for configuration reload");
96 97 98 99 100 101
    return $class->checkConf(1) ? $class->DONE : $class->SERVER_ERROR;
}

*refresh = *reload;

# INTERNAL METHODS
102

103 104 105 106 107
## @imethod void configReload(hashRef conf, hashRef tsv)
# Given a Lemonldap::NG configuration $conf, computes values used to
# handle requests and store them in a thread shared object called $tsv
#
# methods called by configReload, and thread shared values computed, are:
108 109 110
# - jailInit():
#      - jail
# - defaultValuesInit():
111 112 113 114 115 116 117 118
#      (scalars for global options)
#      - cookieExpiration  # warning: absent from default Conf
#      - cookieName
#      - securedCookie,
#      - httpOnly
#      - whatToTrace
#      - customFunctions
#      - timeoutActivity
119
#      - timeoutActivityInterval
120 121 122 123 124 125 126 127 128
#      - useRedirectOnError
#      - useRedirectOnForbidden
#      - useSafeJail
#      (objects)
#      - cipher  # Lemonldap::NG::Common::Crypto object
#      (hashrefs for vhost options)
#      - https
#      - port
#      - maintenance
129
# - portalInit():
130
#      - portal (functions that returns portal URL)
131
# - locationRulesInit():
132 133 134 135 136 137 138
#      - locationCount
#      - defaultCondition
#      - defaultProtection
#      - locationCondition
#      - locationProtection
#      - locationRegexp
#      - locationConditionText
139
# - sessionStorageInit():
140 141 142 143
#      - sessionStorageModule
#      - sessionStorageOptions
#      - sessionCacheModule
#      - sessionCacheOptions
144
# - headersInit():
145 146
#      - headerList
#      - forgeHeaders
147
# - postUrlInit():
148 149
#      - inputPostData
#      - outputPostData
150
# - aliasInit():
151
#      - vhostAlias
152 153 154 155
#
# The *Init() methods can be run in any order,
# but jailInit must be run first because $tsv->{jail}
# is used by locationRulesInit, headersInit and postUrlInit.
156 157 158 159

# @param $conf reference to the configuration hash
# @param $tsv reference to the thread-shared parameters conf
sub configReload {
160
    my ( $class, $conf ) = @_;
161 162
    $class->logger->info(
        "Loading configuration $conf->{cfgNum} for process $$");
163

164
    foreach my $sub (
165
        qw( defaultValuesInit jailInit portalInit locationRulesInit
Clément OUDOT's avatar
Clément OUDOT committed
166 167 168
        sessionStorageInit headersInit postUrlInit aliasInit )
      )
    {
169
        $class->logger->debug("Process $$ calls $sub");
170
        $class->$sub($conf);
171
    }
172 173
    return 1;
}
174

175 176 177 178
## @imethod protected void jailInit(hashRef args)
# Set default values for non-customized variables
# @param $args reference to the configuration hash
sub jailInit {
179
    my ( $class, $conf ) = @_;
180

Xavier Guimard's avatar
Xavier Guimard committed
181
    $class->tsv->{jail} = Lemonldap::NG::Handler::Main::Jail->new( {
182 183
            useSafeJail     => $conf->{useSafeJail},
            customFunctions => $conf->{customFunctions},
Xavier Guimard's avatar
Xavier Guimard committed
184 185
        }
    );
186
    $class->tsv->{jail}->build_jail( $class, $conf->{require} );
187
}
188 189 190 191 192

## @imethod protected void defaultValuesInit(hashRef args)
# Set default values for non-customized variables
# @param $args reference to the configuration hash
sub defaultValuesInit {
193
    my ( $class, $conf ) = @_;
Clément OUDOT's avatar
Clément OUDOT committed
194

Xavier Guimard's avatar
Xavier Guimard committed
195
    $class->tsv->{$_} = $conf->{$_} foreach ( qw(
Xavier Guimard's avatar
Xavier Guimard committed
196 197 198
        cookieExpiration        cookieName         customFunctions httpOnly
        securedCookie           timeout            timeoutActivity
        timeoutActivityInterval useRedirectOnError useRedirectOnForbidden
Xavier Guimard's avatar
Xavier Guimard committed
199
        useSafeJail             whatToTrace        handlerInternalCache
Christophe Maudoux's avatar
Christophe Maudoux committed
200
        handlerServiceTokenTTL  customToTrace      lwpOpts lwpSslOpts
201
        authChoiceParam         authChoiceAuthBasic
Clément OUDOT's avatar
Clément OUDOT committed
202 203
        )
    );
204

205
    $class->tsv->{cipher} = Lemonldap::NG::Common::Crypto->new( $conf->{key} );
206

207
    foreach my $opt (qw(https port maintenance)) {
208

209 210
        # Record default value in key '_'
        $class->tsv->{$opt} = { _ => $conf->{$opt} };
211 212

        # Override with vhost options
213 214 215
        if ( $conf->{vhostOptions} ) {
            my $name = 'vhost' . ucfirst($opt);
            foreach my $vhost ( keys %{ $conf->{vhostOptions} } ) {
216
                $conf->{vhostOptions}->{$vhost} ||= {};
217
                my $val = $conf->{vhostOptions}->{$vhost}->{$name};
Xavier Guimard's avatar
Xavier Guimard committed
218

219
                # Keep global value if $val is negative
Xavier Guimard's avatar
Xavier Guimard committed
220
                if ( defined $val and $val >= 0 ) {
221 222
                    $class->logger->debug(
                        "Options $opt for vhost $vhost: $val");
Xavier Guimard's avatar
Xavier Guimard committed
223 224
                    $class->tsv->{$opt}->{$vhost} = $val;
                }
225 226 227
            }
        }
    }
228 229 230 231
    if ( $conf->{vhostOptions} ) {
        foreach my $vhost ( keys %{ $conf->{vhostOptions} } ) {
            $class->tsv->{type}->{$vhost} =
              $conf->{vhostOptions}->{$vhost}->{vhostType};
232 233
            $class->tsv->{authnLevel}->{$vhost} =
              $conf->{vhostOptions}->{$vhost}->{vhostAuthnLevel};
234 235
            $class->tsv->{serviceTokenTTL}->{$vhost} =
              $conf->{vhostOptions}->{$vhost}->{vhostServiceTokenTTL};
236 237
        }
    }
238
    return 1;
239 240 241 242 243 244
}

## @imethod protected void portalInit(hashRef args)
# Verify that portal variable exists. Die unless
# @param $args reference to the configuration hash
sub portalInit {
245
    my ( $class, $conf ) = @_;
246
    unless ( $conf->{portal} ) {
247
        $class->logger->error("portal parameter required");
248 249
        return 0;
    }
250
    if ( $conf->{portal} =~ /[\$\(&\|"']/ ) {
251 252
        ( $class->tsv->{portal} ) =
          $class->conditionSub( $conf->{portal} );
253 254
    }
    else {
255
        $class->tsv->{portal} = sub { return $conf->{portal} };
256
    }
257
    return 1;
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272
}

## @imethod void locationRulesInit(hashRef args)
# Compile rules.
# Rules are stored in $args->{locationRules}->{<virtualhost>} that contains
# regexp=>test expressions where :
# - regexp is used to test URIs
# - test contains an expression used to grant the user
#
# This function creates 2 hashRef containing :
# - one list of the compiled regular expressions for each virtual host
# - one list of the compiled functions (compiled with conditionSub()) for each
# virtual host
# @param $args reference to the configuration hash
sub locationRulesInit {
Xavier Guimard's avatar
Xavier Guimard committed
273 274 275
    my ( $class, $conf, $orules ) = @_;

    $orules ||= $conf->{locationRules};
276

Xavier Guimard's avatar
Xavier Guimard committed
277 278
    foreach my $vhost ( keys %$orules ) {
        my $rules = $orules->{$vhost};
279 280 281 282 283
        $class->tsv->{locationCount}->{$vhost}         = 0;
        $class->tsv->{locationCondition}->{$vhost}     = [];
        $class->tsv->{locationProtection}->{$vhost}    = [];
        $class->tsv->{locationRegexp}->{$vhost}        = [];
        $class->tsv->{locationConditionText}->{$vhost} = [];
284
        $class->tsv->{locationAuthnLevel}->{$vhost}    = [];
285

Clément OUDOT's avatar
Clément OUDOT committed
286
        foreach my $url ( sort keys %{$rules} ) {
287
            my ( $cond, $prot ) = $class->conditionSub( $rules->{$url} );
Xavier Guimard's avatar
Xavier Guimard committed
288
            unless ($cond) {
289
                $class->tsv->{maintenance}->{$vhost} = 1;
290
                $class->logger->error(
Xavier Guimard's avatar
Xavier Guimard committed
291
                    "Unable to build rule '$rules->{$url}': "
292
                      . $class->tsv->{jail}->error );
Xavier Guimard's avatar
Xavier Guimard committed
293 294
                next;
            }
295

296
            if ( $url eq 'default' ) {
297 298
                $class->tsv->{defaultCondition}->{$vhost}  = $cond;
                $class->tsv->{defaultProtection}->{$vhost} = $prot;
299 300
            }
            else {
301 302 303
                push @{ $class->tsv->{locationCondition}->{$vhost} },  $cond;
                push @{ $class->tsv->{locationProtection}->{$vhost} }, $prot;
                push @{ $class->tsv->{locationRegexp}->{$vhost} },     qr/$url/;
304 305 306 307
                push @{ $class->tsv->{locationAuthnLevel}->{$vhost} },
                  $url =~ /\(\?#AuthnLevel=(-?\d+)\)/
                  ? $1
                  : undef;
308
                push @{ $class->tsv->{locationConditionText}->{$vhost} },
Christophe Maudoux's avatar
Christophe Maudoux committed
309 310
                    $url =~ /^\(\?#(.*?)\)/ ? $1
                  : $url =~ /^(.*?)##(.+)$/ ? $2
311
                  :                           $url;
312
                $class->tsv->{locationCount}->{$vhost}++;
313
            }
314 315
        }

316
        # Default policy set to 'accept'
317
        unless ( $class->tsv->{defaultCondition}->{$vhost} ) {
318
            $class->tsv->{defaultCondition}->{$vhost}  = sub { 1 };
319
            $class->tsv->{defaultProtection}->{$vhost} = 0;
320
        }
321
    }
322
    return 1;
323 324
}

325 326 327
## @imethod protected void sessionStorageInit(hashRef args)
# Initialize the Apache::Session::* module choosed to share user's variables
# and the Cache::Cache module choosed to cache sessions
328
# @param $args reference to the configuration hash
329
sub sessionStorageInit {
330
    my ( $class, $conf ) = @_;
331 332

    # Global session storage
333
    unless ( $class->tsv->{sessionStorageModule} = $conf->{globalStorage} ) {
334
        $class->logger->error("globalStorage required");
335 336
        return 0;
    }
337
    eval "use " . $class->tsv->{sessionStorageModule};
338
    die($@) if ($@);
339
    $class->tsv->{sessionStorageOptions} = $conf->{globalStorageOptions};
340

341 342
    # OIDC session storage
    if ( $conf->{oidcStorage} ) {
343
        eval "use " . $conf->{oidcStorage};
344 345 346 347 348 349 350 351 352 353 354
        die($@) if ($@);
        $class->tsv->{oidcStorageModule}  = $conf->{oidcStorage};
        $class->tsv->{oidcStorageOptions} = $conf->{oidcStorageOptions};

    }
    else {
        $class->tsv->{oidcStorageModule}  = $conf->{globalStorage};
        $class->tsv->{oidcStorageOptions} = $conf->{globalStorageOptions};
    }

    # Local session storage
Clément OUDOT's avatar
Clément OUDOT committed
355
    if ( $conf->{localSessionStorage} ) {
356 357 358 359
        $class->tsv->{sessionCacheModule} = $conf->{localSessionStorage};
        $class->tsv->{sessionCacheOptions} =
          $conf->{localSessionStorageOptions};
        $class->tsv->{sessionCacheOptions}->{default_expires_in} ||= 600;
Clément OUDOT's avatar
Clément OUDOT committed
360 361

        if ( $conf->{status} ) {
362
            my $params = "";
363
            if ( $class->tsv->{sessionCacheModule} ) {
364 365 366 367 368 369 370
                $params = ' ' . join(
                    ',',
                    $class->tsv->{sessionCacheModule} . map {
                        "$_ => "
                          . $class->tsv->{sessionCacheOptions}->{$_}
                    } keys %{ $class->tsv->{sessionCacheOptions} // {} }
                );
371
            }
372
            $class->tsv->{statusPipe}->print("RELOADCACHE $params\n");
373 374
        }
    }
375
    return 1;
376 377
}

378 379
## @imethod void headersInit(hashRef args)
# Create the subroutines used to insert headers into the HTTP request.
380
# @param $args reference to the configuration hash
381
sub headersInit {
Xavier Guimard's avatar
Xavier Guimard committed
382 383
    my ( $class, $conf, $headers ) = @_;
    $headers ||= $conf->{exportedHeaders};
384 385

    # Creation of the subroutine which will generate headers
Xavier Guimard's avatar
Xavier Guimard committed
386
    foreach my $vhost ( keys %{$headers} ) {
Xavier Guimard's avatar
Xavier Guimard committed
387 388 389 390
        unless ($vhost) {
            $class->logger->warn('Empty vhost in headers, skipping');
            next;
        }
391
        $headers->{$vhost} ||= {};
Xavier Guimard's avatar
Xavier Guimard committed
392
        my %headers = %{ $headers->{$vhost} };
393
        $class->tsv->{headerList}->{$vhost} = [ keys %headers ];
Xavier Guimard's avatar
Xavier Guimard committed
394
        my $sub = '';
395
        foreach ( keys %headers ) {
396 397
            $headers{$_} ||= "''";
            my $val = $class->substitute( $headers{$_} ) . " // ''";
Christophe Maudoux's avatar
Christophe Maudoux committed
398
            $sub .= "('$_' => $val),";
399 400
        }

401
        unless ( $class->tsv->{forgeHeaders}->{$vhost} =
Xavier Guimard's avatar
Xavier Guimard committed
402
            $class->buildSub($sub) )
403
        {
404
            $class->tsv->{maintenance}->{$vhost} = 1;
Christophe Maudoux's avatar
Christophe Maudoux committed
405
            $class->logger->error( "$class Unable to forge $vhost headers: "
406
                  . $class->tsv->{jail}->error );
407
        }
408
    }
409
    return 1;
410 411 412 413 414
}

## @imethod protected void postUrlInit()
# Prepare methods to post form attributes
sub postUrlInit {
415
    my ( $class, $conf ) = @_;
416
    return unless ( $conf->{post} );
417 418

    # Browse all vhost
419
    foreach my $vhost ( keys %{ $conf->{post} } ) {
Clément OUDOT's avatar
Clément OUDOT committed
420

421
        #  Browse all POST URI
422
        foreach my $url ( keys %{ $conf->{post}->{$vhost} || {} } ) {
423
            my $d = $conf->{post}->{$vhost}->{$url};
424
            $class->logger->debug("Compiling POST data for $url");
425 426

            # Where to POST
427
            $d->{target} ||= $url;
428
            my $sub;
429 430
            $d->{vars} ||= [];
            foreach my $input ( @{ delete $d->{vars} } ) {
431 432
                $sub .=
                  "'$input->[0]' => " . $class->substitute( $input->[1] ) . ",";
433
            }
434 435 436
            unless (
                $class->tsv->{inputPostData}->{$vhost}->{ delete $d->{target} }
                = $class->tsv->{outputPostData}->{$vhost}->{$url} =
Xavier Guimard's avatar
Xavier Guimard committed
437
                $class->buildSub($sub) )
438
            {
439
                $class->tsv->{maintenance}->{$vhost} = 1;
Xavier Guimard's avatar
Xavier Guimard committed
440
                $class->logger->error( "$class: Unable to build post data: "
441
                      . $class->tsv->{jail}->error );
442
            }
443

444
            $class->tsv->{postFormParams}->{$vhost}->{$url} = $d;
445 446
        }
    }
447
    return 1;
448 449 450 451 452 453 454
}

## @imethod protected codeRef conditionSub(string cond)
# Returns a compiled function used to grant users (used by
# locationRulesInit(). The second value returned is a non null
# constant if URL is not protected (by "unprotect" or "skip"), 0 else.
# @param $cond The boolean expression to use
455
# @param $mainClass  optional
456 457
# @return array (ref(sub), int)
sub conditionSub {
458
    my ( $class, $cond ) = @_;
Christophe Maudoux's avatar
WIP  
Christophe Maudoux committed
459
    $cond =~ s/\(\?#(\d+)\)$//;
460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
    my ( $OK, $NOK ) = ( sub { 1 }, sub { 0 } );

    # Simple cases : accept and deny
    return ( $OK, 0 )
      if ( $cond =~ /^accept$/i );
    return ( $NOK, 0 )
      if ( $cond =~ /^deny$/i );

    # Cases unprotect and skip : 2nd value is 1 or 2
    return ( $OK, UNPROTECT )
      if ( $cond =~ /^unprotect$/i );
    return ( $OK, SKIP )
      if ( $cond =~ /^skip$/i );

    # Case logout
    if ( $cond =~ /^logout(?:_sso)?(?:\s+(.*))?$/i ) {
        my $url = $1;
        return (
            $url
            ? (
                sub {
481
                    $_[1]->{_logout} = $url;
482 483 484 485 486 487
                    return 0;
                },
                0
              )
            : (
                sub {
488
                    $_[1]->{_logout} = $class->tsv->{portal}->();
489 490 491 492 493 494 495 496 497 498
                    return 0;
                },
                0
            )
        );
    }

    # Since filter exists only with Apache>=2, logout_app and logout_app_sso
    # targets are available only for it.
    # This error can also appear with Manager configured as CGI script
499
    if ( $cond =~ /^logout_app/i
Xavier Guimard's avatar
Xavier Guimard committed
500
        and not $class->isa('Lemonldap::NG::Handler::ApacheMP2::Main') )
501
    {
502 503
        $class->logger->info(
            "Rules logout_app and logout_app_sso require Apache>=2");
504 505 506 507 508
        return ( sub { 1 }, 0 );
    }

    # logout_app
    if ( $cond =~ /^logout_app(?:\s+(.*))?$/i ) {
Xavier Guimard's avatar
Xavier Guimard committed
509
        my $u = $1 || $class->tsv->{portal}->();
510 511 512
        eval 'use Apache2::Filter' unless ( $INC{"Apache2/Filter.pm"} );
        return (
            sub {
Xavier Guimard's avatar
Xavier Guimard committed
513
                $_[0]->{env}->{'psgi.r'}->add_output_filter(
514
                    sub {
Xavier Guimard's avatar
#994  
Xavier Guimard committed
515
                        return $class->redirectFilter( $u, @_ );
516
                    }
517
                );
518 519 520 521 522 523
                1;
            },
            0
        );
    }
    elsif ( $cond =~ /^logout_app_sso(?:\s+(.*))?$/i ) {
Xavier Guimard's avatar
Xavier Guimard committed
524
        my $u = $1 || $class->tsv->{portal}->();
Xavier Guimard's avatar
Xavier Guimard committed
525
        eval 'use Apache2::Filter' unless ( $INC{"Apache2/Filter.pm"} );
526 527
        return (
            sub {
Xavier Guimard's avatar
#994  
Xavier Guimard committed
528

529
                my ($req) = @_;
Xavier Guimard's avatar
#994  
Xavier Guimard committed
530
                $class->localUnlog;
531
                $req->{env}->{'psgi.r'}->add_output_filter(
532
                    sub {
Xavier Guimard's avatar
#994  
Xavier Guimard committed
533 534
                        my $r = $_[0]->r;
                        return $class->redirectFilter(
535
                            &{ $class->tsv->{portal} }() . "?url="
536
                              . $class->encodeUrl( $req, $u )
537 538 539 540
                              . "&logout=1",
                            @_
                        );
                    }
541
                );
542 543 544 545 546 547 548
                1;
            },
            0
        );
    }

    # Replace some strings in condition
549
    $cond = $class->substitute($cond);
550
    my $sub;
Xavier Guimard's avatar
Xavier Guimard committed
551
    unless ( $sub = $class->buildSub($cond) ) {
552 553
        $class->logger->error( "$class: Unable to build condition ($cond): "
              . $class->tsv->{jail}->error );
554
    }
555 556 557 558 559

    # Return sub and protected flag
    return ( $sub, 0 );
}

560
## @method arrayref aliasInit
561 562
# @param options vhostOptions configuration item
# @return arrayref of vhost and aliases
563
sub aliasInit {
564
    my ( $class, $conf ) = @_;
565

566
    foreach my $vhost ( keys %{ $conf->{vhostOptions} || {} } ) {
Xavier Guimard's avatar
Xavier Guimard committed
567
        if ( my $aliases = $conf->{vhostOptions}->{$vhost}->{vhostAliases} ) {
568
            foreach ( split /\s+/, $aliases ) {
569
                $class->tsv->{vhostAlias}->{$_} = $vhost;
570
                $class->logger->debug("Registering $_ as alias of $vhost");
571
            }
572 573
        }
    }
574
    return 1;
575
}
Clément OUDOT's avatar
Clément OUDOT committed
576

577
# TODO: support wildcards in aliases
578

579
sub substitute {
580
    my ( $class, $expr ) = @_;
581

582
    # substitute special vars, just for retro-compatibility
583
    $expr =~ s/\$date\b/&date/sg;
584 585
    $expr =~ s/\$vhost\b/\$ENV{HTTP_HOST}/sg;
    $expr =~ s/\$ip\b/\$ENV{REMOTE_ADDR}/sg;
586

Xavier Guimard's avatar
Xavier Guimard committed
587
    # substitute vars with session data, excepts special vars $_ and $\d+
588
    $expr =~ s/\$(?!(?:ENV|env|_rulematch)\b)(_\w+|[a-zA-Z]\w*)/\$s->{$1}/sg;
589
    $expr =~ s/\$ENV\{/\$r->{env}->\{/g;
590
    $expr =~ s/\$env->\{/\$r->{env}->\{/g;
591
    $expr =~ s/\$_rulematch\[/\$m->\[/g;
592 593

    return $expr;
594 595
}

Xavier Guimard's avatar
Xavier Guimard committed
596 597
sub buildSub {
    my ( $class, $val ) = @_;
Xavier Guimard's avatar
Xavier Guimard committed
598
    my $res =
599
      $class->tsv->{jail}->jail_reval("sub{my (\$r,\$s,\$m)=\@_;return($val)}");
Xavier Guimard's avatar
Xavier Guimard committed
600 601 602 603
    unless ($res) {
        $class->logger->error( $class->tsv->{jail}->error );
    }
    return $res;
Xavier Guimard's avatar
Xavier Guimard committed
604 605
}

606
1;