Run.pm 26.7 KB
Newer Older
1
# Main running methods file
2 3
package Lemonldap::NG::Handler::Main::Run;

4
our $VERSION = '2.0.3';
5 6 7

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

8 9 10 11 12 13 14
use strict;

#use AutoLoader 'AUTOLOAD';
use MIME::Base64;
use URI::Escape;
use Lemonldap::NG::Common::Session;

15
# Methods that must be overloaded
16 17 18

sub handler {
    die "Must be overloaded" unless ($#_);
Xavier Guimard's avatar
Xavier Guimard committed
19 20
    my ($res) = $_[0]->run( $_[1] );
    return $res;
21 22 23 24 25
}

sub logout {
    my $class;
    $class = $#_ ? shift : __PACKAGE__;
26
    return $class->unlog(@_);
27 28 29 30 31
}

sub status {
    my $class;
    $class = $#_ ? shift : __PACKAGE__;
32
    return $class->getStatus(@_);
33 34 35 36
}

# Public methods

37
# Return Handler::Lib::Status output
38
sub getStatus {
39
    my ( $class, $req ) = @_;
40
    $class->logger->debug("Request for status");
41 42
    my $statusPipe = $class->tsv->{statusPipe};
    my $statusOut  = $class->tsv->{statusOut};
43 44 45 46
    my $args       = '';
    if ( $ENV{LLNGSTATUSHOST} ) {
        require IO::Socket::INET;
        foreach ( 64322 .. 64331 ) {
Xavier Guimard's avatar
Xavier Guimard committed
47 48
            if ( $statusOut =
                IO::Socket::INET->new( Proto => 'udp', LocalPort => $_ ) )
49
            {
Xavier Guimard's avatar
Xavier Guimard committed
50 51
                $args =
                  ' host=' . ( $ENV{LLNGSTATUSCLIENT} || 'localhost' ) . ":$_";
52 53 54 55
                last;
            }
        }
        return $class->abort( $req,
Xavier Guimard's avatar
Xavier Guimard committed
56 57
            "$class: status page can not be displayed, unable to open socket" )
          unless ($statusOut);
58
    }
59
    return $class->abort( $req, "$class: status page can not be displayed" )
Xavier Guimard's avatar
Xavier Guimard committed
60
      unless ( $statusPipe and $statusOut );
Xavier Guimard's avatar
Xavier Guimard committed
61 62 63 64 65
    my $q = $req->{env}->{QUERY_STRING} || '';
    if ( $q =~ /\s/ ) {
        $class->logger->error("Bad characters in query");
        return $class->FORBIDDEN;
    }
66
    $statusPipe->print(
67
        "STATUS " . ( $req->{env}->{QUERY_STRING} || '' ) . "$args\n" );
68 69
    my $buf;

70
    while ( $_ = $statusOut->getline ) {
71 72 73
        last if (/^END$/);
        $buf .= $_;
    }
74 75 76
    $class->set_header_out( $req,
        "Content-Type" => "text/html; charset=UTF-8" );
    $class->print( $req, $buf );
77 78 79
    return $class->OK;
}

80 81
# Method that must be called by base packages (Handler::ApacheMP2,...) to get
# type of handler to call (Main, AuthBasic,...)
82 83 84 85 86
sub checkType {
    my ( $class, $req ) = @_;

    if ( time() - $class->lastCheck > $class->checkTime ) {
        die("$class: No configuration found")
Xavier Guimard's avatar
Xavier Guimard committed
87
          unless ( $class->checkConf );
88
    }
89
    my $vhost = $class->resolveAlias($req);
90
    return ( defined $class->tsv->{type}->{$vhost} )
Xavier Guimard's avatar
Xavier Guimard committed
91 92
      ? $class->tsv->{type}->{$vhost}
      : 'Main';
93 94
}

95 96 97 98 99 100 101 102 103
## @rmethod int run
# Check configuration and launch Lemonldap::NG::Handler::Main::run().
# Each $checkTime, the Apache child verify if its configuration is the same
# as the configuration stored in the local storage.
# @param $rule optional Perl expression to grant access
# @return Apache constant

sub run {
    my ( $class, $req, $rule, $protection ) = @_;
104 105
    my ( $id, $session );

106
    return $class->DECLINED unless ( $class->is_initial_req($req) );
107

Christophe Maudoux's avatar
Christophe Maudoux committed
108
    # Direct return if maintenance mode is enabled
109
    if ( $class->checkMaintenanceMode($req) ) {
110 111

        if ( $class->tsv->{useRedirectOnError} ) {
112
            $class->logger->debug("Go to portal with maintenance error code");
113
            return $class->goToError( $req, '/', $class->MAINTENANCE );
114 115
        }
        else {
116
            $class->logger->debug("Return maintenance error code");
117 118 119 120 121
            return $class->MAINTENANCE;
        }
    }

    # Cross domain authentication
122
    my $uri = $req->{env}->{REQUEST_URI};
123

124
    $uri = $req->{env}->{REQUEST_URI};
125 126
    my ($cond);
    ( $cond, $protection ) = $class->conditionSub($rule) if ($rule);
127
    $protection = $class->isUnprotected( $req, $uri ) || 0
Xavier Guimard's avatar
Xavier Guimard committed
128
      unless ( defined $protection );
129 130

    if ( $protection == $class->SKIP ) {
131
        $class->logger->debug("Access control skipped");
132 133 134
        $class->updateStatus( $req, 'SKIP' );
        $class->hideCookie($req);
        $class->cleanHeaders($req);
135 136 137 138
        return $class->OK;
    }

    # Try to recover cookie and user session
139 140
    if (    $id = $class->fetchId($req)
        and $session = $class->retrieveSession( $req, $id ) )
141
    {
142 143 144 145

        # AUTHENTICATION done

        # Local macros
Xavier Guimard's avatar
Xavier Guimard committed
146
        my $kc = keys %{$session};    # in order to detect new local macro
147 148

        # ACCOUNTING (1. Inform web server)
149
        $class->set_user( $req, $session->{ $class->tsv->{whatToTrace} } );
150 151

        # AUTHORIZATION
152
        return ( $class->forbidden( $req, $session ), $session )
Xavier Guimard's avatar
Xavier Guimard committed
153
          unless ( $class->grant( $req, $session, $uri, $cond ) );
154 155
        $class->updateStatus( $req, 'OK',
            $session->{ $class->tsv->{whatToTrace} } );
156 157

        # ACCOUNTING (2. Inform remote application)
158
        $class->sendHeaders( $req, $session );
159 160

        # Store local macros
Xavier Guimard's avatar
Xavier Guimard committed
161
        if ( keys %$session > $kc ) {
162
            $class->logger->debug("Update local cache");
Xavier Guimard's avatar
Xavier Guimard committed
163
            $req->data->{session}->update( $session, { updateCache => 2 } );
164 165 166
        }

        # Hide Lemonldap::NG cookie
167
        $class->hideCookie($req);
168 169

        # Log access granted
170
        $class->logger->debug( "User "
Xavier Guimard's avatar
Xavier Guimard committed
171 172
              . $session->{ $class->tsv->{whatToTrace} }
              . " was granted to access to $uri" );
173 174

        #  Catch POST rules
175 176
        $class->postOutputFilter( $req, $session, $uri );
        $class->postInputFilter( $req, $session, $uri );
177

Xavier Guimard's avatar
Xavier Guimard committed
178
        return ( $class->OK, $session );
179 180 181 182 183
    }

    elsif ( $protection == $class->UNPROTECT ) {

        # Ignore unprotected URIs
184
        $class->logger->debug("No valid session but unprotected access");
185 186 187
        $class->updateStatus( $req, 'UNPROTECT' );
        $class->hideCookie($req);
        $class->cleanHeaders($req);
188 189 190 191 192 193
        return $class->OK;
    }

    else {

        # Redirect user to the portal
194
        $class->logger->info("No cookie found")
Xavier Guimard's avatar
Xavier Guimard committed
195
          unless ($id);
196 197

        # if the cookie was fetched, a log is sent by retrieveSession()
198 199
        $class->updateStatus( $req, $id ? 'EXPIRED' : 'REDIRECT' );
        return $class->goToPortal( $req, $req->{env}->{REQUEST_URI} );
200 201 202
    }
}

203 204 205 206
## @rmethod protected int unlog()
# Call localUnlog() then goToPortal() to unlog the current user.
# @return Constant value returned by goToPortal()
sub unlog {
207 208 209 210
    my ( $class, $req ) = @_;
    $class->localUnlog( $req, @_ );
    $class->updateStatus( $req, 'LOGOUT' );
    return $class->goToPortal( $req, '/', 'logout=1' );
211 212
}

213 214 215 216 217 218 219 220
# INTERNAL METHODS

## @rmethod protected void updateStatus(string action,string user,string url)
# Inform the status process of the result of the request if it is available
# @param action string Result of access control (as $class->OK, $class->SKIP, LOGOUT...)
# @param optional user string Username to log, if undefined defaults to remote IP
# @param optional url string URL to log, if undefined defaults to request URI
sub updateStatus {
221
    my ( $class, $req, $action, $user, $url ) = @_;
222
    my $statusPipe = $class->tsv->{statusPipe} or return;
223 224
    $user ||= $req->{env}->{REMOTE_ADDR};
    $url  ||= $req->{env}->{REQUEST_URI};
225
    eval {
226 227
        $statusPipe->print(
            "$user => " . $req->{env}->{HTTP_HOST} . "$url $action\n" );
228 229 230 231 232 233 234 235 236
    };
}

## @rmethod void lmLog(string msg, string level)
# Wrapper for Apache log system
# @param $msg message to log
# @param $level string (emerg|alert|crit|error|warn|notice|info|debug)
sub lmLog {
    my ( $class, $msg, $level ) = @_;
237
    return $class->logger->$level($msg);
238 239 240 241
}

## @rmethod protected boolean checkMaintenanceMode
# Check if we are in maintenance mode
Christophe Maudoux's avatar
Christophe Maudoux committed
242
# @return true if maintenance mode is enabled
243
sub checkMaintenanceMode {
244 245
    my ( $class, $req ) = @_;
    my $vhost = $class->resolveAlias($req);
Xavier Guimard's avatar
Xavier Guimard committed
246 247 248 249
    my $_maintenance =
      ( defined $class->tsv->{maintenance}->{$vhost} )
      ? $class->tsv->{maintenance}->{$vhost}
      : $class->tsv->{maintenance}->{_};
250 251

    if ($_maintenance) {
Christophe Maudoux's avatar
Christophe Maudoux committed
252
        $class->logger->debug("Maintenance mode enabled");
253 254 255 256 257 258 259 260 261 262 263
        return 1;
    }
    return 0;
}

## @rmethod boolean grant(string uri, string cond)
# Grant or refuse client using compiled regexp and functions
# @param $uri URI
# @param $cond optional Function granting access
# @return True if the user is granted to access to the current URL
sub grant {
264 265
    my ( $class, $req, $session, $uri, $cond, $vhost ) = @_;
    return $cond->( $req, $session ) if ($cond);
266

267
    $vhost ||= $class->resolveAlias($req);
268 269 270 271 272 273
    if ( my $level = $class->tsv->{authnLevel}->{$vhost} ) {
        if ( $session->{authenticationLevel} < $level ) {
            $session->{_upgrade} = 1;
            return 0;
        }
    }
Xavier Guimard's avatar
Xavier Guimard committed
274
    for (
Xavier Guimard's avatar
Xavier Guimard committed
275 276
        my $i = 0 ;
        $i < ( $class->tsv->{locationCount}->{$vhost} || 0 ) ;
Xavier Guimard's avatar
Xavier Guimard committed
277
        $i++
Xavier Guimard's avatar
Xavier Guimard committed
278
      )
Xavier Guimard's avatar
Xavier Guimard committed
279
    {
280
        if ( $uri =~ $class->tsv->{locationRegexp}->{$vhost}->[$i] ) {
281
            $class->logger->debug( 'Regexp "'
Xavier Guimard's avatar
Xavier Guimard committed
282 283
                  . $class->tsv->{locationConditionText}->{$vhost}->[$i]
                  . '" match' );
284
            return $class->tsv->{locationCondition}->{$vhost}->[$i]
Xavier Guimard's avatar
Xavier Guimard committed
285
              ->( $req, $session );
286 287 288
        }
    }
    unless ( $class->tsv->{defaultCondition}->{$vhost} ) {
289 290
        $class->logger->warn(
            "User rejected because VirtualHost \"$vhost\" has no configuration"
291 292 293
        );
        return 0;
    }
294
    $class->logger->debug("$vhost: Apply default rule");
295
    return $class->tsv->{defaultCondition}->{$vhost}->( $req, $session );
296 297 298 299
}

## @rmethod protected int forbidden(string uri)
# Used to reject non authorized requests.
Christophe Maudoux's avatar
Christophe Maudoux committed
300
# Inform the status process and call logForbidden().
301 302 303
# @param $uri URI
# @return Constant $class->FORBIDDEN
sub forbidden {
304 305 306
    my ( $class, $req, $session, $vhost ) = @_;
    my $uri = $req->{env}->{REQUEST_URI};
    $vhost ||= $class->resolveAlias($req);
307

Xavier Guimard's avatar
Xavier Guimard committed
308
    if ( $session->{_logout} ) {
309
        $class->updateStatus( $req, 'LOGOUT',
Xavier Guimard's avatar
Xavier Guimard committed
310 311
            $session->{ $class->tsv->{whatToTrace} } );
        my $u = $session->{_logout};
312 313
        $class->localUnlog($req);
        return $class->goToPortal( $req, $u, 'logout=1' );
314 315
    }

316
    if ( $session->{_upgrade} ) {
317
        return $class->goToPortal( $req, $uri, undef, '/upgradesession' );
318 319
    }

320
    # Log forbidding
321
    $class->userLogger->notice( "User "
Xavier Guimard's avatar
Xavier Guimard committed
322 323
          . $session->{ $class->tsv->{whatToTrace} }
          . " was forbidden to access to $vhost$uri" );
324 325
    $class->updateStatus( $req, 'REJECT',
        $session->{ $class->tsv->{whatToTrace} } );
326 327 328

    # Redirect or Forbidden?
    if ( $class->tsv->{useRedirectOnForbidden} ) {
329
        $class->logger->debug("Use redirect for forbidden access");
330
        return $class->goToError( $req, $uri, 403 );
331 332
    }
    else {
333
        $class->logger->debug("Return forbidden access");
334 335 336 337 338 339 340
        return $class->FORBIDDEN;
    }
}

## @rmethod protected void hideCookie()
# Hide Lemonldap::NG cookie to the protected application.
sub hideCookie {
341
    my ( $class, $req ) = @_;
342
    $class->logger->debug("removing cookie");
343
    my $cookie = $req->env->{HTTP_COOKIE};
Christophe Maudoux's avatar
Christophe Maudoux committed
344 345 346 347 348 349
    $class->logger->debug("Cookies -> $cookie");
    my $cn = $class->tsv->{cookieName};
    $class->logger->debug("CookieName -> $cn");
    $cookie =~ s/\b$cn(http)?=[^,;]*[,;\s]*//og;
    $class->logger->debug("newCookies -> $cookie");

350
    if ($cookie) {
351
        $class->set_header_in( $req, 'Cookie' => $cookie );
352 353
    }
    else {
354
        $class->unset_header_in( $req, 'Cookie' );
355 356 357 358
    }
}

## @rmethod protected string encodeUrl(string url)
Christophe Maudoux's avatar
Christophe Maudoux committed
359
# Encode URL in the format used by Lemonldap::NG::Portal for redirections.
360 361
# @return Base64 encoded string
sub encodeUrl {
362 363
    my ( $class, $req, $url ) = @_;
    $url = $class->_buildUrl( $req, $url ) if ( $url !~ m#^https?://# );
364 365 366 367 368 369 370 371 372
    return encode_base64( $url, '' );
}

## @rmethod protected int goToPortal(string url, string arg)
# Redirect non-authenticated users to the portal by setting "Location:" header.
# @param $url Url requested
# @param $arg optionnal GET parameters
# @return Constant $class->REDIRECT
sub goToPortal {
373
    my ( $class, $req, $url, $arg, $path ) = @_;
374
    $path ||= '';
375
    my ( $ret, $msg );
376
    my $urlc_init = $class->encodeUrl( $req, $url );
377
    $class->logger->debug(
378 379
        "Redirect $req->{env}->{REMOTE_ADDR} to portal (url was $url)");
    $class->set_header_out( $req,
Xavier Guimard's avatar
Xavier Guimard committed
380 381 382
            'Location' => $class->tsv->{portal}->()
          . "$path?url=$urlc_init"
          . ( $arg ? "&$arg" : "" ) );
383 384 385
    return $class->REDIRECT;
}

386
sub goToError {
387 388
    my ( $class, $req, $url, $code ) = @_;
    my $urlc_init = $class->encodeUrl( $req, $url );
389
    $class->logger->debug(
390 391
        "Redirect $req->{env}->{REMOTE_ADDR} to lmError (url was $url)");
    $class->set_header_out( $req,
Xavier Guimard's avatar
Xavier Guimard committed
392 393 394
            'Location' => $class->tsv->{portal}->()
          . "/lmerror/$code"
          . "?url=$urlc_init" );
395 396 397
    return $class->REDIRECT;
}

398 399 400 401
## @rmethod protected fetchId()
# Get user cookies and search for Lemonldap::NG cookie.
# @return Value of the cookie if found, 0 else
sub fetchId {
402 403 404
    my ( $class, $req ) = @_;
    my $t                 = $req->{env}->{HTTP_COOKIE} or return 0;
    my $vhost             = $class->resolveAlias($req);
405
    my $lookForHttpCookie = ( $class->tsv->{securedCookie} =~ /^(2|3)$/
Xavier Guimard's avatar
Xavier Guimard committed
406
          and not $class->_isHttps( $req, $vhost ) );
407
    my $cn = $class->tsv->{cookieName};
Xavier Guimard's avatar
Xavier Guimard committed
408 409 410 411
    my $value =
      $lookForHttpCookie
      ? ( $t =~ /${cn}http=([^,; ]+)/o ? $1 : 0 )
      : ( $t =~ /$cn=([^,; ]+)/o ? $1 : 0 );
412

413 414 415 416 417 418
    if ( $value && $lookForHttpCookie && $class->tsv->{securedCookie} == 3 ) {
        $value = $class->tsv->{cipher}->decryptHex( $value, "http" );
    }
    elsif ( $value =~ s/^c:// ) {
        $value = $class->tsv->{cipher}->decrypt($value);
        unless ( $value =~ s/^(.*)? (.*)$/$1/ and $2 eq $vhost ) {
419 420
            $class->userLogger->error(
                "Bad CDA cookie: available for $2 instead od $vhost");
421 422 423
            return undef;
        }
    }
424 425 426 427 428 429 430
    return $value;
}

## @rmethod protected boolean retrieveSession(id)
# Tries to retrieve the session whose index is id
# @return true if the session was found, false else
sub retrieveSession {
431
    my ( $class, $req, $id ) = @_;
432 433 434 435
    my $now = time();

    # 1. Search if the user was the same as previous (very efficient in
    # persistent connection).
436 437
    # NB: timout is here the same value as current HTTP/1.1 Keep-Alive timeout
    #     (15 seconds)
Xavier Guimard's avatar
Xavier Guimard committed
438 439
    if (    defined $class->data->{_session_id}
        and $id eq $class->data->{_session_id}
Christophe Maudoux's avatar
Christophe Maudoux committed
440 441
        and
        ( $now - $class->dataUpdate < $class->tsv->{handlerInternalCache} ) )
442
    {
443
        $class->logger->debug("Get session $id from Handler internal cache");
Xavier Guimard's avatar
Xavier Guimard committed
444
        return $class->data;
445 446 447
    }

    # 2. Get the session from cache or backend
Xavier Guimard's avatar
Xavier Guimard committed
448
    my $session = $req->data->{session} = (
Xavier Guimard's avatar
Xavier Guimard committed
449 450
        Lemonldap::NG::Common::Session->new( {
                storageModule        => $class->tsv->{sessionStorageModule},
451 452 453 454 455 456 457 458 459
                storageModuleOptions => $class->tsv->{sessionStorageOptions},
                cacheModule          => $class->tsv->{sessionCacheModule},
                cacheModuleOptions   => $class->tsv->{sessionCacheOptions},
                id                   => $id,
                kind                 => "SSO",
            }
        )
    );

Xavier Guimard's avatar
Xavier Guimard committed
460
    unless ( $session->error ) {
461

Xavier Guimard's avatar
Xavier Guimard committed
462
        $class->data( $session->data );
463
        $class->logger->debug("Get session $id from Handler::Main::Run");
464

465
        # Verify that session is valid
466
        $class->logger->error(
Xavier Guimard's avatar
Xavier Guimard committed
467
"_utime is not defined. This should not happen. Check if it is well transmitted to handler"
468
        ) unless $session->data->{_utime};
469

470
        $class->logger->debug("Check session validity from Handler");
Xavier Guimard's avatar
Xavier Guimard committed
471
        $class->logger->debug( "Session timeout -> " . $class->tsv->{timeout} );
472
        $class->logger->debug( "Session timeoutActivity -> "
Xavier Guimard's avatar
Xavier Guimard committed
473 474 475
              . $class->tsv->{timeoutActivity}
              . "s" )
          if ( $class->tsv->{timeoutActivity} );
476 477 478 479
        $class->logger->debug(
            "Session _utime -> " . $session->data->{_utime} );
        $class->logger->debug( "now -> " . $now );
        $class->logger->debug( "_lastSeen -> " . $session->data->{_lastSeen} )
Xavier Guimard's avatar
Xavier Guimard committed
480
          if ( $session->data->{_lastSeen} );
Xavier Guimard's avatar
Xavier Guimard committed
481
        my $delta = $now - $session->data->{_lastSeen}
Xavier Guimard's avatar
Xavier Guimard committed
482
          if ( $session->data->{_lastSeen} );
483
        $class->logger->debug( "now - _lastSeen = " . $delta )
Xavier Guimard's avatar
Xavier Guimard committed
484
          if ( $session->data->{_lastSeen} );
485
        $class->logger->debug( "Session timeoutActivityInterval -> "
Xavier Guimard's avatar
Xavier Guimard committed
486 487
              . $class->tsv->{timeoutActivityInterval} )
          if ( $class->tsv->{timeoutActivityInterval} );
488 489 490
        my $ttl = $class->tsv->{timeout} - $now + $session->data->{_utime};
        $class->logger->debug( "Session TTL = " . $ttl );

Xavier Guimard's avatar
Xavier Guimard committed
491 492
        if (
            $now - $session->data->{_utime} > $class->tsv->{timeout}
493 494
            or (    $class->tsv->{timeoutActivity}
                and $session->data->{_lastSeen}
495
                and $delta > $class->tsv->{timeoutActivity} )
Xavier Guimard's avatar
Xavier Guimard committed
496
          )
497 498 499 500
        {
            $class->logger->info("Session $id expired");

            # Clean cached data
Xavier Guimard's avatar
Xavier Guimard committed
501
            $class->data( {} );
502 503 504
            return 0;
        }

505
        # Update the session to notify activity, if necessary
Xavier Guimard's avatar
Xavier Guimard committed
506 507 508 509 510
        if (
            $class->tsv->{timeoutActivity}
            and ( $now - $session->data->{_lastSeen} >
                $class->tsv->{timeoutActivityInterval} )
          )
511 512 513 514 515 516 517 518 519 520 521 522 523
        {
            $req->data->{session}->update( { '_lastSeen' => $now } );
            $class->data( $session->data );

            if ( $session->error ) {
                $class->logger->error("Cannot update session $id");
                $class->logger->error( $req->data->{session}->error );
            }
            else {
                $class->logger->debug("Update _lastSeen with $now");
            }
        }

Xavier Guimard's avatar
Xavier Guimard committed
524
        $class->dataUpdate($now);
Xavier Guimard's avatar
Xavier Guimard committed
525
        return $session->data;
526 527
    }
    else {
528 529
        $class->logger->info("Session $id can't be retrieved");
        $class->logger->info( $session->error );
530 531 532 533 534

        return 0;
    }
}

535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580
## @cmethod private int _getPort(string s)
# Returns the port on which this vhost is accessed
# @param $s VHost name
# @return PORT

sub _getPort {

    my ( $class, $req, $vhost ) = @_;

    if ( defined $class->tsv->{port}->{$vhost}
        and ( $class->tsv->{port}->{$vhost} > 0 ) )
    {
        return $class->tsv->{port}->{$vhost};
    }
    else {
        if ( defined $class->tsv->{port}->{_}
            and ( $class->tsv->{port}->{_} > 0 ) )
        {
            return $class->tsv->{port}->{_};
        }
        else {
            return $req->{env}->{SERVER_PORT};
        }
    }
}
## @cmethod private boot _isHttps(string s)
# Returns whether this VHost should he accessed
# via HTTPS
# @param $s VHost name
# @return RUE if the vhost should be accessed over HTTPS
sub _isHttps {

    my ( $class, $req, $vhost ) = @_;

    if ( defined $class->tsv->{https}->{$vhost}
        and ( $class->tsv->{https}->{$vhost} > -1 ) )
    {
        return $class->tsv->{https}->{$vhost};
    }
    else {
        if ( defined $class->tsv->{https}->{_}
            and ( $class->tsv->{https}->{_} > -1 ) )
        {
            return $class->tsv->{https}->{_};
        }
        else {
Xavier Guimard's avatar
Xavier Guimard committed
581
            return ( ( uc( $req->{env}->{HTTPS} ) || "OFF" ) eq "ON" );
582 583 584 585
        }
    }
}

586 587 588 589 590
## @cmethod private string _buildUrl(string s)
# Transform /<s> into http(s?)://<host>:<port>/s
# @param $s path
# @return URL
sub _buildUrl {
591
    my ( $class, $req, $s ) = @_;
592 593 594 595
    my $realvhost  = $req->{env}->{HTTP_HOST};
    my $vhost      = $class->resolveAlias($req);
    my $_https     = $class->_isHttps( $req, $vhost );
    my $portString = $class->_getPort( $req, $vhost );
596
    $portString = (
Xavier Guimard's avatar
Xavier Guimard committed
597 598 599
             ( $realvhost =~ /:\d+/ )
          or ( $_https  && $portString == 443 )
          or ( !$_https && $portString == 80 )
600
    ) ? '' : ":$portString";
601
    my $url = "http" . ( $_https ? "s" : "" ) . "://$realvhost$portString$s";
602
    $class->logger->debug("Build URL $url");
603 604 605 606 607 608 609
    return $url;
}

## @rmethod protected int isUnprotected()
# @param $uri URI
# @return 0 if URI is protected,
# $class->UNPROTECT if it is unprotected by "unprotect",
Christophe Maudoux's avatar
Christophe Maudoux committed
610
# SKIP if unprotected by "skip"
611
sub isUnprotected {
612 613
    my ( $class, $req, $uri ) = @_;
    my $vhost = $class->resolveAlias($req);
Xavier Guimard's avatar
Xavier Guimard committed
614
    for (
Xavier Guimard's avatar
Xavier Guimard committed
615 616
        my $i = 0 ;
        $i < ( $class->tsv->{locationCount}->{$vhost} || 0 ) ;
Xavier Guimard's avatar
Xavier Guimard committed
617
        $i++
Xavier Guimard's avatar
Xavier Guimard committed
618
      )
Xavier Guimard's avatar
Xavier Guimard committed
619
    {
620 621 622 623 624 625 626 627 628 629
        if ( $uri =~ $class->tsv->{locationRegexp}->{$vhost}->[$i] ) {
            return $class->tsv->{locationProtection}->{$vhost}->[$i];
        }
    }
    return $class->tsv->{defaultProtection}->{$vhost};
}

## @rmethod void sendHeaders()
# Launch function compiled by forgeHeadersInit() for the current virtual host
sub sendHeaders {
630 631
    my ( $class, $req, $session ) = @_;
    my $vhost = $class->resolveAlias($req);
Xavier Guimard's avatar
Xavier Guimard committed
632
    if ( defined $class->tsv->{forgeHeaders}->{$vhost} ) {
633 634

        # Log headers in debug mode
Xavier Guimard's avatar
Xavier Guimard committed
635 636
        my %headers =
          $class->tsv->{forgeHeaders}->{$vhost}->( $req, $session );
Xavier Guimard's avatar
Xavier Guimard committed
637 638
        foreach my $h ( sort keys %headers ) {
            if ( defined( my $v = $headers{$h} ) ) {
639
                $class->logger->debug("Send header $h with value $v");
640 641
            }
            else {
642
                $class->logger->debug("Send header $h with empty value");
643 644
            }
        }
645
        $class->set_header_in( $req, %headers );
646 647 648
    }
}

Christophe Maudoux's avatar
Christophe Maudoux committed
649 650
## @rfunction array ref checkHeaders()
# Return computed headers by forgeHeadersInit() for the current virtual host
651
# [ { key => 'header1', value => 'value1' }, { key => 'header2', value => 'value2' }, ...]
652 653
sub checkHeaders {
    my ( $class, $req, $session ) = @_;
Christophe Maudoux's avatar
Christophe Maudoux committed
654
    my $vhost         = $class->resolveAlias($req);
655 656 657 658
    my $array_headers = [];
    if ( defined $class->tsv->{forgeHeaders}->{$vhost} ) {

        # Create array of hashes with headers
Xavier Guimard's avatar
Xavier Guimard committed
659 660
        my %headers =
          $class->tsv->{forgeHeaders}->{$vhost}->( $req, $session );
661
        foreach my $h ( sort keys %headers ) {
662
            defined $headers{$h}
Xavier Guimard's avatar
Xavier Guimard committed
663 664
              ? push @$array_headers, { key => $h, value => $headers{$h} }
              : push @$array_headers, { key => $h, value => '' };
665 666 667 668 669
        }
    }
    return $array_headers;
}

670 671 672
## @rmethod void cleanHeaders()
# Unset HTTP headers, when sendHeaders is skipped
sub cleanHeaders {
673 674
    my ( $class, $req ) = @_;
    my $vhost = $class->resolveAlias($req);
675
    if ( defined( $class->tsv->{headerList}->{$vhost} ) ) {
676 677
        $class->unset_header_in( $req,
            @{ $class->tsv->{headerList}->{$vhost} } );
678 679 680 681 682 683
    }
}

## @rmethod string resolveAlias
# returns vhost whose current hostname is an alias
sub resolveAlias {
684
    my ( $class, $req ) = @_;
685
    my $vhost = ref $req ? $req->{env}->{HTTP_HOST} : $req;
Xavier Guimard's avatar
Xavier Guimard committed
686 687

    $vhost =~ s/:\d+//;
688
    return $class->tsv->{vhostAlias}->{$vhost}
Xavier Guimard's avatar
Xavier Guimard committed
689
      if ( $class->tsv->{vhostAlias}->{$vhost} );
690 691 692 693 694 695 696
    return $vhost if ( $class->tsv->{defaultCondition}->{$vhost} );
    my $v = $vhost;
    while ( $v =~ s/[\w\-]+/\*/ ) {
        return $v if ( $class->tsv->{defaultCondition}->{$v} );
        $v =~ s/^\*\.*//;
    }
    return $vhost;
697 698 699 700 701 702 703 704 705 706
}

#__END__

## @rmethod int abort(string msg)
# Logs message and exit or redirect to the portal if "useRedirectOnError" is
# set to true.
# @param $msg Message to log
# @return Constant ($class->REDIRECT, $class->SERVER_ERROR)
sub abort {
707
    my ( $class, $req, $msg ) = @_;
708 709 710

    # If abort is called without a valid request, fall to die
    eval {
711
        my $uri = $req->{env}->{REQUEST_URI};
712

713
        $class->logger->error($msg);
714 715 716

        # Redirect or die
        if ( $class->tsv->{useRedirectOnError} ) {
717
            $class->logger->debug("Use redirect for error");
718
            return $class->goToError( $req, $uri, 500 );
719 720 721 722 723 724 725 726 727 728 729
        }
        else {
            return $class->SERVER_ERROR;
        }
    };
    die $msg if ($@);
}

## @rmethod protected void localUnlog()
# Delete current user from local cache entry.
sub localUnlog {
730
    my ( $class, $req, $id ) = @_;
731
    $class->logger->debug('Local handler logout');
732
    if ( $id //= $class->fetchId($req) ) {
733

Xavier Guimard's avatar
Xavier Guimard committed
734 735 736
        # Delete thread data
        if (    $class->data->{_session_id}
            and $id eq $class->data->{_session_id} )
737
        {
Xavier Guimard's avatar
Xavier Guimard committed
738
            $class->data( {} );
739
        }
Xavier Guimard's avatar
Xavier Guimard committed
740
        delete $req->data->{session};
741 742 743 744 745 746 747 748 749 750 751 752 753 754

        # Delete local cache
        if (    $class->tsv->{refLocalStorage}
            and $class->tsv->{refLocalStorage}->get($id) )
        {
            $class->tsv->{refLocalStorage}->remove($id);
        }
    }
}

## @rmethod protected postOutputFilter(string uri)
# Add a javascript to html page in order to fill html form with fake data
# @param uri URI to catch
sub postOutputFilter {
755 756
    my ( $class, $req, $session, $uri ) = @_;
    my $vhost = $class->resolveAlias($req);
757 758

    if ( defined( $class->tsv->{outputPostData}->{$vhost}->{$uri} ) ) {
759
        $class->logger->debug("Filling a html form with fake data");
760

761
        $class->unset_header_in( $req, "Accept-Encoding" );
Xavier Guimard's avatar
Xavier Guimard committed
762 763
        my %postdata =
          $class->tsv->{outputPostData}->{$vhost}->{$uri}->( $req, $session );
764
        my $formParams = $class->tsv->{postFormParams}->{$vhost}->{$uri};
765 766
        my $js = $class->postJavascript( $req, \%postdata, $formParams );
        $class->addToHtmlHead( $req, $js );
767 768 769 770
    }
}

## @rmethod protected postInputFilter(string uri)
Xavier Guimard's avatar
Xavier Guimard committed
771
# Replace request body with form data defined in configuration
772 773
# @param uri URI to catch
sub postInputFilter {
774 775
    my ( $class, $req, $session, $uri ) = @_;
    my $vhost = $class->resolveAlias($req);
776 777

    if ( defined( $class->tsv->{inputPostData}->{$vhost}->{$uri} ) ) {
778
        $class->logger->debug("Replacing fake data with real form data");
779

Xavier Guimard's avatar
Xavier Guimard committed
780 781
        my %data =
          $class->tsv->{inputPostData}->{$vhost}->{$uri}->( $req, $session );
782
        foreach ( keys %data ) {
783 784 785 786 787
            my $post_key   = uri_escape($_);
            my $post_value = uri_escape( $data{$_} );
            delete $data{$_};
            $data{$post_key} = $post_value;
            $class->logger->debug("Send key $post_key with value $post_value");
788
        }
789
        $class->setPostParams( $req, \%data );
790 791 792 793 794 795 796
    }
}

## @rmethod protected postJavascript(hashref data)
# build a javascript to fill a html form with fake data
# @param data hashref containing input => value
sub postJavascript {
797
    my ( $class, $req, $data, $formParams ) = @_;
798 799 800 801 802 803 804

    my $form = $formParams->{formSelector} || "form";

    my $filler;
    foreach my $name ( keys %$data ) {
        use bytes;
        my $value = "x" x bytes::length( $data->{$name} );
Xavier Guimard's avatar
Xavier Guimard committed
805 806
        $filler .=
"form.find('input[name=\"$name\"], select[name=\"$name\"], textarea[name=\"$name\"]').val('$value')\n";
807 808
    }

Xavier Guimard's avatar
Xavier Guimard committed
809 810 811 812 813
    my $submitter =
        $formParams->{buttonSelector} eq "none" ? ""
      : $formParams->{buttonSelector}
      ? "form.find('$formParams->{buttonSelector}').click();\n"
      : "form.submit();\n";
814 815

    my $jqueryUrl = $formParams->{jqueryUrl} || "";
816 817
    $jqueryUrl =
      &{ $class->tsv->{portal} } . "static/bwr/jquery/dist/jquery.min.js"
Xavier Guimard's avatar
Xavier Guimard committed
818
      if ( $jqueryUrl eq "default" );
819
    $jqueryUrl = "<script type='text/javascript' src='$jqueryUrl'></script>\n"
Xavier Guimard's avatar
Xavier Guimard committed
820
      if ($jqueryUrl);
821 822

    return
Xavier Guimard's avatar
Xavier Guimard committed
823 824 825 826 827 828 829 830 831
        $jqueryUrl
      . "<script type='text/javascript'>\n"
      . "/* script added by Lemonldap::NG */\n"
      . "jQuery(window).on('load', function() {\n"
      . "var form = jQuery('$form');\n"
      . "form.attr('autocomplete', 'off');\n"
      . $filler
      . $submitter . "})\n"
      . "</script>\n";
832 833 834
}

1;