Simple.pm 35.1 KB
Newer Older
1 2 3 4 5 6
## @file
# Base file for Lemonldap::NG handlers
#
# @copy 2005, 2006, 2007, 2008 Xavier Guimard <x.guimard@free.fr>

## @class
7 8 9 10 11 12 13 14 15
# Base class for Lemonldap::NG handlers.
# All methods in handler are class methods: in ModPerl environment, handlers
# are always launched without object created.
#
# The main method is run() who is called by Apache for each requests (using
# handler() wrapper).
#
# The main initialization subroutine is init() who launch localInit() and
# globalInit().
16 17 18 19 20 21
package Lemonldap::NG::Handler::Simple;

use strict;

use MIME::Base64;
use Exporter 'import';
Xavier Guimard's avatar
Xavier Guimard committed
22
use Safe;
23
require Data::Dumper;
24
require POSIX;
25

26
our $VERSION = '0.9';
27 28

our %EXPORT_TAGS;
29

30
our @EXPORT_OK;
31

32
our @EXPORT;
33 34 35

# Shared variables
our (
36 37 38 39 40
    $locationRegexp,      $locationCondition,    $defaultCondition,
    $forgeHeaders,        $apacheRequest,        $locationCount,
    $cookieName,          $portal,               $datas,
    $globalStorage,       $globalStorageOptions, $localStorage,
    $localStorageOptions, $whatToTrace,          $https,
Xavier Guimard's avatar
Xavier Guimard committed
41
    $refLocalStorage,     $safe,                 $cookieSecured,
42
    $port,                $statusPipe,           $statusOut,
43
    $customFunctions,
44 45 46 47 48 49 50
);

##########################################
# COMPATIBILITY WITH APACHE AND APACHE 2 #
##########################################

BEGIN {
51
    %EXPORT_TAGS = (
52 53
        localStorage =>
          [qw( $localStorage $localStorageOptions $refLocalStorage )],
54 55 56 57 58
        globalStorage => [qw( $globalStorage $globalStorageOptions )],
        locationRules => [
            qw(
              $locationCondition $defaultCondition $locationCount
              $locationRegexp $apacheRequest $datas $safe $portal
59
              safe $customFunctions
60 61 62 63 64 65 66 67 68 69
              )
        ],
        import  => [qw( import @EXPORT_OK @EXPORT %EXPORT_TAGS )],
        headers => [
            qw(
              $forgeHeaders lmHeaderIn lmSetHeaderIn lmHeaderOut
              lmSetHeaderOut lmSetErrHeaderOut $cookieName $cookieSecured
              $https $port
              )
        ],
70
        log    => [qw(lmSetApacheUser)],
71
        traces => [qw( $whatToTrace $statusPipe $statusOut )],
72 73 74
        apache => [qw( MP OK REDIRECT FORBIDDEN DONE DECLINED SERVER_ERROR )],
    );
    push( @EXPORT_OK, @{ $EXPORT_TAGS{$_} } ) foreach ( keys %EXPORT_TAGS );
Xavier Guimard's avatar
Xavier Guimard committed
75
    $EXPORT_TAGS{all} = \@EXPORT_OK;
76
    if ( exists $ENV{MOD_PERL} ) {
77
        if ( $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 ) {
78
            eval 'use constant MP => 2;';
79 80
        }
        else {
81
            eval 'use constant MP => 1;';
82 83 84
        }
    }
    else {
85
        eval 'use constant MP => 0;';
86 87
    }
    if ( MP() == 2 ) {
88 89 90
        require Apache2::Log;
        require Apache2::RequestUtil;
        Apache2::RequestUtil->import();
91 92
        require Apache2::RequestRec;
        Apache2::RequestRec->import();
93 94 95 96
        require Apache2::ServerUtil;
        Apache2::ServerUtil->import();
        require Apache2::Connection;
        Apache2::Connection->import();
97 98
        require Apache2::RequestIO;
        Apache2::RequestIO->import();
99 100
        require APR::Table;
        APR::Table->import();
101 102
        require Apache2::Const;
        Apache2::Const->import( '-compile', qw(:common :log) );
103 104 105 106 107 108 109 110
        eval '
        use constant FORBIDDEN    => Apache2::Const::FORBIDDEN;
        use constant REDIRECT     => Apache2::Const::REDIRECT;
        use constant OK           => Apache2::Const::OK;
        use constant DECLINED     => Apache2::Const::DECLINED;
        use constant DONE         => Apache2::Const::DONE;
        use constant SERVER_ERROR => Apache2::Const::SERVER_ERROR;
        ';
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
        eval {
            require threads::shared;
            threads::shared::share($locationRegexp);
            threads::shared::share($locationCondition);
            threads::shared::share($defaultCondition);
            threads::shared::share($forgeHeaders);
            threads::shared::share($locationCount);
            threads::shared::share($cookieName);
            threads::shared::share($portal);
            threads::shared::share($globalStorage);
            threads::shared::share($globalStorageOptions);
            threads::shared::share($localStorage);
            threads::shared::share($localStorageOptions);
            threads::shared::share($whatToTrace);
            threads::shared::share($https);
126
            threads::shared::share($port);
127
            threads::shared::share($refLocalStorage);
128 129
            threads::shared::share($statusPipe);
            threads::shared::share($statusOut);
130 131 132 133 134 135 136 137 138
        };
    }
    elsif ( MP() == 1 ) {
        require Apache;
        require Apache::Log;
        require Apache::Constants;
        Apache::Constants->import(':common');
        Apache::Constants->import(':response');
    }
Xavier Guimard's avatar
Xavier Guimard committed
139
    else {    # For Test or CGI
140
        eval '
141 142 143 144 145 146
        use constant FORBIDDEN    => 1;
        use constant REDIRECT     => 1;
        use constant OK           => 1;
        use constant DECLINED     => 1;
        use constant DONE         => 1;
        use constant SERVER_ERROR => 1;
147 148 149
        ';
    }
    *handler = ( MP() == 2 ) ? \&handler_mp2 : \&handler_mp1;
150
    *logout  = ( MP() == 2 ) ? \&logout_mp2  : \&logout_mp1;
151 152
}

153
## @rmethod protected int handler_mp1()
154 155
# Launch run() when used under mod_perl version 1
# @return Apache constant
156
sub handler_mp1 ($$) { shift->run(@_); }
157

158
## @rmethod protected int handler_mp2()
159 160
# Launch run() when used under mod_perl version 2
# @return Apache constant
161 162 163
sub handler_mp2 : method {
    shift->run(@_);
}
164

165
## @rmethod protected int logout_mp1()
166 167
# Launch unlog() when used under mod_perl version 1
# @return Apache constant
168
sub logout_mp1 ($$) { shift->unlog(@_); }
169

170
## @rmethod protected int logout_mp2()
171 172
# Launch unlog() when used under mod_perl version 2
# @return Apache constant
173 174 175
sub logout_mp2 : method {
    shift->unlog(@_);
}
176

177
## @rmethod void lmLog(string mess, string level)
178 179 180
# Wrapper for Apache log system
# @param $mess message to log
# @param $level string (debug, info, warning or error)
Xavier Guimard's avatar
Xavier Guimard committed
181
sub lmLog {
182 183 184 185
    my ( $class, $mess, $level ) = @_;
    if ( MP() == 2 ) {
        Apache2::ServerRec->log->$level($mess);
    }
Xavier Guimard's avatar
Xavier Guimard committed
186
    elsif ( MP() == 1 ) {
187 188
        Apache->server->log->$level($mess);
    }
Xavier Guimard's avatar
Xavier Guimard committed
189 190 191
    else {
        print STDERR "$mess\n";
    }
192 193
}

194
## @rfn protected void lmSetApacheUser(Apache2::RequestRec r,string s)
195 196 197
# Inform Apache for the data to use as user for logs
# @param $r current request
# @param $s string to use
198 199 200
sub lmSetApacheUser {
    my ( $r, $s ) = @_;
    return unless ($s);
201
    $r->connection->user($s);
202 203
}

204
## @ifn protected string protected regRemoteIp(string str)
205 206 207
# Replaces $ip by the client IP address in the string
# @param $str string
# @return string
208 209
sub regRemoteIp {
    my ( $class, $str ) = @_;
210 211 212 213 214 215
    if( MP() == 2 ) {
        $str =~ s/\$datas->\{ip\}/\$apacheRequest->connection->remote_ip/g;
    }
    else {
        $str =~ s/\$datas->\{ip\}/\$apacheRequest->remote_ip/g;
    }
216 217 218
    return $str;
}

219
## @rfn void lmSetHeaderIn(Apache2::RequestRec r, string h, string v)
220 221 222 223
# Set an HTTP header in the HTTP request.
# @param $r Current request
# @param $h Name of the header
# @param $v Value of the header
224 225 226 227 228
sub lmSetHeaderIn {
    my ( $r, $h, $v ) = @_;
    if ( MP() == 2 ) {
        return $r->headers_in->set( $h => $v );
    }
Xavier Guimard's avatar
Xavier Guimard committed
229
    elsif ( MP() == 1 ) {
230 231 232 233
        return $r->header_in( $h => $v );
    }
}

234
## @rfn string lmtHeaderIn(Apache2::RequestRec r, string h)
235 236 237 238
# Return an HTTP header value from the HTTP request.
# @param $r Current request
# @param $h Name of the header
# @return Value of the header
239
sub lmHeaderIn {
240
    my ( $r, $h ) = @_;
241 242 243
    if ( MP() == 2 ) {
        return $r->headers_in->{$h};
    }
Xavier Guimard's avatar
Xavier Guimard committed
244
    elsif ( MP() == 1 ) {
245 246 247 248
        return $r->header_in($h);
    }
}

249
## @rfn void lmSetErrHeaderOut(Apache2::RequestRec r, string h, string v)
250 251 252 253
# Set an HTTP header in the HTTP response in error context
# @param $r Current request
# @param $h Name of the header
# @param $v Value of the header
254 255 256 257 258
sub lmSetErrHeaderOut {
    my ( $r, $h, $v ) = @_;
    if ( MP() == 2 ) {
        return $r->err_headers_out->set( $h => $v );
    }
Xavier Guimard's avatar
Xavier Guimard committed
259
    elsif ( MP() == 1 ) {
260
        return $r->err_header_out( $h => $v );
261 262 263
    }
}

264
## @rfn void lmSetHeaderOut(Apache2::RequestRec r, string h, string v)
265 266 267 268
# Set an HTTP header in the HTTP response in normal context
# @param $r Current request
# @param $h Name of the header
# @param $v Value of the header
269 270 271 272 273
sub lmSetHeaderOut {
    my ( $r, $h, $v ) = @_;
    if ( MP() == 2 ) {
        return $r->headers_out->set( $h => $v );
    }
Xavier Guimard's avatar
Xavier Guimard committed
274
    elsif ( MP() == 1 ) {
275 276 277 278
        return $r->header_out( $h => $v );
    }
}

279
## @rfn string lmtHeaderOut(Apache2::RequestRec r, string h)
280 281 282 283
# Return an HTTP header value from the HTTP response.
# @param $r Current request
# @param $h Name of the header
# @return Value of the header
284 285 286 287 288
sub lmHeaderOut {
    my ( $r, $h, $v ) = @_;
    if ( MP() == 2 ) {
        return $r->headers_out->{$h};
    }
Xavier Guimard's avatar
Xavier Guimard committed
289
    elsif ( MP() == 1 ) {
290 291 292 293
        return $r->header_out($h);
    }
}

294 295
# Status daemon creation

296
## @ifn protected void statusProcess()
297
# Launch the status processus.
298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325
sub statusProcess {
    require IO::Pipe;
    $statusPipe = IO::Pipe->new;
    $statusOut  = IO::Pipe->new;
    if ( my $pid = fork() ) {
        $statusPipe->writer();
        $statusOut->reader();
        $statusPipe->autoflush(1);
    }
    else {
        $statusPipe->reader();
        $statusOut->writer();
        my $fdin  = $statusPipe->fileno;
        my $fdout = $statusOut->fileno;
        open STDIN, "<&$fdin";
        open STDOUT, ">&$fdout";
        my @tmp = ();
        push @tmp, "-I$_" foreach (@INC);
        exec 'perl', '-MLemonldap::NG::Handler::Status',
          @tmp,
          '-e',
          '&Lemonldap::NG::Handler::Status::run('
          . $localStorage . ','
          . Data::Dumper->new( [$localStorageOptions] )->Terse(1)->Dump
          . ');';
    }
}

326 327 328 329
##############################
# Initialization subroutines #
##############################

330
## @imethod protected Safe safe()
331 332
# Build and return the security jail used to compile rules and headers.
# @return Safe object
333 334 335 336
sub safe {
    my $class = shift;
    return $safe if($safe);
    $safe = new Safe;
337
    my @t = $customFunctions ? split( /\s+/, $customFunctions ) : ();
338 339
    foreach(@t) {
        $class->lmLog("Custom function : $_",'debug');
340 341 342 343 344 345 346 347
        my $sub = $_;
        unless(/::/) {
            $sub = "$class\::$_";
        }
        else {
            s/^.*:://;
        }
        next if($class->can($_));
348
        eval "sub $_ {
349
            return $sub(\$apacheRequest->uri
350 351 352 353 354
                . ( \$apacheRequest->args ? '?' . \$apacheRequest->args : '' )
                , \@_)
            }";
        $class->lmLog($@,'error')if($@);
    }
355
    $safe->share( '&encode_base64', '$datas', '&lmSetHeaderIn', '$apacheRequest', @t );
356 357
    return $safe;
}
Xavier Guimard's avatar
Xavier Guimard committed
358

359
## @imethod void init(hashRef args)
360 361
# Calls localInit() and globalInit().
# @param $args reference to the initialization hash
362 363 364 365 366 367
sub init($$) {
    my $class = shift;
    $class->localInit(@_);
    $class->globalInit(@_);
}

368
## @imethod void localInit(hashRef args)
369 370 371
# Call purgeCache() to purge the local cache, launch the status process
# (statusProcess()) in wanted and launch childInit().
# @param $args reference to the initialization hash
372 373 374 375 376 377
sub localInit($$) {
    my ( $class, $args ) = @_;
    if ( $localStorage = $args->{localStorage} ) {
        $localStorageOptions = $args->{localStorageOptions};
        $localStorageOptions->{namespace}          ||= "lemonldap";
        $localStorageOptions->{default_expires_in} ||= 600;
378
        $class->purgeCache();
379
    }
380
    if ( $args->{status} ) {
381
        statusProcess();
382
    }
383 384 385
    $class->childInit();
}

386
## @imethod protected boolean childInit()
387
# Indicates to Apache that it has to launch:
388
# - initLocalStorage() for each child process (after fork and uid change)
389 390
# - cleanLocalStorage() after each requests
# @return True
391 392
sub childInit {
    my $class = shift;
393 394 395 396 397 398 399 400 401

    # We don't initialise local storage in the "init" subroutine because it can
    # be used at the starting of Apache and so with the "root" privileges. Local
    # Storage is also initialized just after Apache's fork and privilege lost.

    # Local storage is cleaned after giving the content of the page to increase
    # performances.
    no strict;
    if ( MP() == 2 ) {
402 403 404
        Apache2::ServerUtil->server->push_handlers( PerlChildInitHandler =>
              sub { return $class->initLocalStorage( $_[1], $_[0] ); } );
        Apache2::ServerUtil->server->push_handlers(
405 406
            PerlCleanupHandler => sub { return $class->cleanLocalStorage(@_); }
        );
407
    }
Xavier Guimard's avatar
Xavier Guimard committed
408
    elsif ( MP() == 1 ) {
409 410 411 412 413 414
        Apache->push_handlers(
            PerlChildInitHandler => sub { return $class->initLocalStorage(@_); }
        );
        Apache->push_handlers(
            PerlCleanupHandler => sub { return $class->cleanLocalStorage(@_); }
        );
415
    }
416
    1;
417 418
}

419
## @imethod protected void purgeCache()
420 421
# Purge the local cache.
# Launched at Apache startup.
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439
sub purgeCache {
    my $class = shift;
    eval "use $localStorage;";
    die("Unable to load $localStorage: $@") if ($@);

    # At each Apache (re)start, we've to clear the cache to avoid living
    # with old datas
    eval '$refLocalStorage = new '
      . $localStorage
      . '($localStorageOptions);';
    if ( defined $refLocalStorage ) {
        $refLocalStorage->clear();
    }
    else {
        $class->lmLog( "Unable to clear local cache: $@", 'error' );
    }
}

440
## @imethod void globalInit(hashRef args)
441 442 443 444 445 446 447
# Global initialization process. Launch :
# - locationRulesInit()
# - defaultValuesInit()
# - portalInit()
# - globalStorageInit()
# - forgeHeadersInit()
# @param $args reference to the configuration hash
448 449 450 451 452 453 454 455 456
sub globalInit {
    my $class = shift;
    $class->locationRulesInit(@_);
    $class->defaultValuesInit(@_);
    $class->portalInit(@_);
    $class->globalStorageInit(@_);
    $class->forgeHeadersInit(@_);
}

457
## @imethod protected void locationRulesInit(hashRef args)
458 459 460 461 462 463 464 465 466 467
# Compile rules.
# Rules are stored in $args->{locationRules} 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 arrays containing :
# - the list of the compiled regular expressions
# - the list of the compiled functions (compiled with conditionSub())
# @param $args reference to the configuration hash
468 469 470 471 472 473 474
sub locationRulesInit {
    my ( $class, $args ) = @_;
    $locationCount = 0;

    # Pre compilation : both regexp and conditions
    foreach ( keys %{ $args->{locationRules} } ) {
        if ( $_ eq 'default' ) {
475 476
            $defaultCondition =
              $class->conditionSub( $args->{locationRules}->{$_} );
477 478
        }
        else {
479 480 481
            $locationCondition->[$locationCount] =
              $class->conditionSub( $args->{locationRules}->{$_} );
            $locationRegexp->[$locationCount] = qr/$_/;
482 483 484 485 486 487 488
            $locationCount++;
        }
    }

    # Default police: all authenticated users are accepted
    $defaultCondition = $class->conditionSub('accept')
      unless ($defaultCondition);
489
    1;
490 491
}

492
## @imethod protected codeRef conditionSub(string cond)
493
# Returns a compiled function used to grant users (used by
494
# locationRulesInit().
495
# @param $cond The boolean expression to use
496 497 498 499 500 501
sub conditionSub {
    my ( $class, $cond ) = @_;
    return sub { 1 }
      if ( $cond =~ /^accept$/i );
    return sub { 0 }
      if ( $cond =~ /^deny$/i );
502 503 504
    if ( $cond =~ /^logout(?:_sso)?(?:\s+(.*))$/i ) {
        my $url = $1;
        return sub { $datas->{_logout} = $url; return 0 }
505
    }
506
    if ( MP() == 2 ) {
507 508
        if ( $cond =~ /^logout_app(?:\s+(.*))?$/i ) {
            my $u = $1;
509
            eval 'use Apache2::Filter' unless ( $INC{"Apache2/Filter.pm"} );
510
            return sub {
511 512
                $apacheRequest->add_output_filter(
                    sub {
513 514 515 516 517 518 519
                        return $class->redirectFilter( $u, @_ );
                    }
                );
                1;
            };
        }
        elsif ( $cond =~ /^logout_app_sso(?:\s+(.*))?$/i ) {
520 521
            eval 'use Apache2::Filter' unless ( $INC{"Apache2/Filter.pm"} );
            my $u = $1;
522 523
            return sub {
                $class->localUnlog;
524 525 526 527 528 529 530 531
                $apacheRequest->add_output_filter(
                    sub {
                        return $class->redirectFilter(
                            "$portal?url="
                              . $class->encodeUrl($u)
                              . "&logout=1",
                            @_
                        );
532 533 534 535 536 537
                    }
                );
                1;
            };
        }
    }
538
    $cond =~ s/\$date/&POSIX::strftime("%Y%m%d%H%M%S",localtime())/e;
539 540
    $cond =~ s/\$(\w+)/\$datas->{$1}/g;
    my $sub;
541
    $sub = $class->safe->reval("sub {return ( $cond )}");
542 543 544
    return $sub;
}

545
## @imethod protected void defaultValuesInit(hashRef args)
546 547
# Set default values for non-customized variables
# @param $args reference to the configuration hash
548 549 550 551
sub defaultValuesInit {
    my ( $class, $args ) = @_;

    # Other values
552 553 554
    $cookieName    = $args->{cookieName}    || 'lemonldap';
    $cookieSecured = $args->{cookieSecured} || 0;
    $whatToTrace   = $args->{whatToTrace}   || '$uid';
555
    $whatToTrace =~ s/\$//g;
556 557
    $https = $args->{https} unless defined($https);
    $https = 1 unless defined($https);
558
    $port = $args->{port} || 0 unless defined($port);
559
    $customFunctions = $args->{customFunctions};
560
    1;
561 562
}

563
## @imethod protected void portalInit(hashRef args)
564 565
# Verify that portal variable exists. Die unless
# @param $args reference to the configuration hash
566 567 568 569 570
sub portalInit {
    my ( $class, $args ) = @_;
    $portal = $args->{portal} or die("portal parameter required");
}

571
## @imethod protected void globalStorageInit(hashRef args)
572 573
# Initialize the Apache::Session::* module choosed to share user's variables.
# @param $args reference to the configuration hash
574 575 576 577 578 579 580 581
sub globalStorageInit {
    my ( $class, $args ) = @_;
    $globalStorage = $args->{globalStorage} or die "globalStorage required";
    eval "use $globalStorage;";
    die($@) if ($@);
    $globalStorageOptions = $args->{globalStorageOptions};
}

582
## @imethod protected void forgeHeadersInit(hashRef args)
583 584 585
# Create the &$forgeHeaders subroutine used to insert
# headers into the HTTP request.
# @param $args reference to the configuration hash
586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603
sub forgeHeadersInit {
    my ( $class, $args ) = @_;

    # Creation of the subroutine who will generate headers
    my %tmp;
    if ( $args->{exportedHeaders} ) {
        %tmp = %{ $args->{exportedHeaders} };
    }
    else {
        %tmp = ( 'User-Auth' => '$uid' );
    }
    foreach ( keys %tmp ) {
        $tmp{$_} =~ s/\$(\w+)/\$datas->{$1}/g;
        $tmp{$_} = $class->regRemoteIp( $tmp{$_} );
    }

    my $sub;
    foreach ( keys %tmp ) {
604 605 606
        $sub .=
          "lmSetHeaderIn(\$apacheRequest,'$_' => join('',split(/[\\r\\n]+/,"
          . $tmp{$_} . ")));";
607
    }
608
    $forgeHeaders = $class->safe->reval("sub {$sub};");
609 610
    $class->lmLog( "$class: Unable to forge headers: $@: sub {$sub}", 'error' )
      if ($@);
611
    1;
612 613
}

614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631
## @imethod protected int initLocalStorage()
# Prepare local cache (if not done before by Lemonldap::NG::Common::Conf)
# @return Apache2::Const::DECLINED
sub initLocalStorage {
    my ( $class, $r ) = @_;
    if ( $localStorage and not $refLocalStorage ) {
        eval "use $localStorage;\$refLocalStorage = new $localStorage(\$localStorageOptions);";
        $class->lmLog( "Local cache initialization failed: $@", 'error' )
          unless ( defined $refLocalStorage );
    }
    return DECLINED;
}

###################
# RUNNING METHODS #
###################

## @rmethod protected void updateStatus(string user,string url,string action)
632
# Inform the status process of the result of the request if it is available.
633
sub updateStatus {
634
    my ( $class, $user, $url, $action ) = @_;
635 636 637 638 639 640
    eval {
        print $statusPipe "$user => "
          . $apacheRequest->hostname
          . "$url $action\n"
          if ($statusPipe);
    };
641 642
}

643
## @rmethod protected boolean grant()
644 645
# Grant or refuse client using compiled regexp and functions
# @return True if the user is granted to access to the current URL
646 647 648 649 650 651
sub grant {
    my ( $class, $uri ) = @_;
    for ( my $i = 0 ; $i < $locationCount ; $i++ ) {
        return &{ $locationCondition->[$i] }($datas)
          if ( $uri =~ $locationRegexp->[$i] );
    }
652
    return &$defaultCondition($datas);
653 654
}

655
## @rmethod protected int forbidden()
656 657 658
# Used to reject non authorizated requests.
# Inform the status processus and call logForbidden().
# @return Apache2::Const::FORBIDDEN
659 660
sub forbidden {
    my $class = shift;
661
    if ( $datas->{_logout} ) {
662
        $class->updateStatus( $datas->{$whatToTrace}, $_[0], 'LOGOUT' );
663 664 665
        my $u = $datas->{_logout};
        $class->localUnlog;
        return $class->goToPortal( $u, 'logout=1' );
666
    }
667
    $class->updateStatus( $datas->{$whatToTrace}, $_[0], 'REJECT' );
668 669 670 671
    $class->logForbidden(@_);
    return FORBIDDEN;
}

672
## @rmethod protected void logForbidden()
673 674
# Insert a log in Apache errors log system to inform that the user was rejected.
# This method has to be overloaded to use different logs systems
675 676
sub logForbidden {
    my $class = shift;
677
    $class->lmLog(
678 679 680 681
        'The user "'
          . $datas->{$whatToTrace}
          . '" was reject when he tried to access to '
          . shift,
682 683
        'notice'
    );
684 685
}

686
## @rmethod protected void hideCookie()
687
# Hide Lemonldap::NG cookie to the protected application.
688
sub hideCookie {
689 690
    my $class = shift;
    $class->lmLog( "$class: removing cookie", 'debug' );
691 692 693 694 695
    my $tmp = lmHeaderIn( $apacheRequest, 'Cookie' );
    $tmp =~ s/$cookieName[^;]*;?//o;
    lmSetHeaderIn( $apacheRequest, 'Cookie' => $tmp );
}

696
## @rmethod protected string encodeUrl(string url)
697
# Encode URl in the format used by Lemonldap::NG::Portal for redirections.
698 699
sub encodeUrl {
    my ( $class, $url ) = @_;
700
    my $u = $url;
701
    if ( $url !~ m#^https?://# ) {
702 703
        my $portString = $port || $apacheRequest->get_server_port();
        $portString =
704
            ( $https  && $portString == 443 ) ? ''
705
          : ( !$https && $portString == 80 )  ? ''
706 707 708 709 710 711 712 713
          :                                     ':' . $portString;
        $u = "http"
          . ( $https ? "s" : "" ) . "://"
          . $apacheRequest->get_server_name()
          . $portString
          . $url;
    }
    $u = encode_base64($u);
714 715 716 717
    $u =~ s/[\r\n\s]//sg;
    return $u;
}

718
## @rmethod protected int goToPortal(string url, string arg)
719 720 721 722
# Redirect non-authenticated users to the portal by setting "Location:" header.
# @param $url Url requested
# @param $arg optionnal GET parameters
# @return Apache2::Const::REDIRECT
723
sub goToPortal {
724
    my ( $class, $url, $arg ) = @_;
725 726 727 728 729 730
    $class->lmLog(
        "Redirect "
          . $apacheRequest->connection->remote_ip
          . " to portal (url was $url)",
        'debug'
    );
731 732 733
    my $urlc_init = $class->encodeUrl($url);
    lmSetHeaderOut( $apacheRequest,
        'Location' => "$portal?url=$urlc_init" . ( $arg ? "&$arg" : "" ) );
734 735 736
    return REDIRECT;
}

737
## @rmethod protected $ fetchId()
738 739
# Get user cookies and search for Lemonldap::NG cookie.
# @return Value of the cookie if found, 0 else
740
sub fetchId {
741
    my $t = lmHeaderIn( $apacheRequest, 'Cookie' );
742
    return ( $t =~ /$cookieName=([^; ]+);?/o ) ? $1 : 0;
743 744
}

745
# MAIN SUBROUTINE called by Apache (using PerlHeaderParserHandler option)
746

747
## @rmethod int run(Apache2::RequestRec apacheRequest)
748 749 750 751 752 753 754 755 756 757 758
# Main method used to control access.
# Calls :
# - fetchId()
# - lmSetApacheUser()
# - grant()
# - forbidden() if user is rejected
# - sendHeaders() if user is granted
# - hideCookie()
# - updateStatus()
# @param $apacheRequest Current request
# @return Apache2::Const value (OK, FORBIDDEN, REDIRECT or SERVER_ERROR)
759 760 761 762
sub run ($$) {
    my $class;
    ( $class, $apacheRequest ) = @_;

763
    return DECLINED unless ( $apacheRequest->is_initial_req );
764 765
    my $uri = $apacheRequest->uri
      . ( $apacheRequest->args ? "?" . $apacheRequest->args : "" );
766 767 768 769

    # AUTHENTICATION
    # I - recover the cookie
    my $id;
770
    unless ( $id = $class->fetchId ) {
771
        $class->lmLog( "$class: No cookie found", 'info' );
772
        $class->updateStatus( $apacheRequest->connection->remote_ip, $apacheRequest->uri, 'REDIRECT' );
773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789
        return $class->goToPortal($uri);
    }

    # II - recover the user datas
    #  2.1 search if the user was the same as previous (very efficient in
    #      persistent connection).
    unless ( $id eq $datas->{_session_id} ) {

        # 2.2 search in the local cache if exists
        unless ( $refLocalStorage and $datas = $refLocalStorage->get($id) ) {

            # 2.3 search in the central cache
            my %h;
            eval { tie %h, $globalStorage, $id, $globalStorageOptions; };
            if ($@) {

                # The cookie isn't yet available
790 791
                $class->lmLog( "The cookie $id isn't yet available: $@",
                    'info' );
792
                $class->updateStatus( $apacheRequest->connection->remote_ip, $apacheRequest->uri, 'EXPIRED' );
793 794 795 796 797 798 799 800 801 802 803 804 805 806
                return $class->goToPortal($uri);
            }
            $datas->{$_} = $h{$_} foreach ( keys %h );

            # Store now the user in the local storage
            if ($refLocalStorage) {
                $refLocalStorage->set( $id, $datas, "10 minutes" );
            }
            untie %h;
        }
    }

    # ACCOUNTING
    # 1 - Inform Apache
807
    lmSetApacheUser( $apacheRequest, $datas->{$whatToTrace} );
808 809 810

    # AUTHORIZATION
    return $class->forbidden($uri) unless ( $class->grant($uri) );
811
    $class->updateStatus( $datas->{$whatToTrace}, $apacheRequest->uri, 'OK' );
812 813 814 815 816 817
    $class->lmLog(
        "User "
          . $datas->{$whatToTrace}
          . " was authorizated to access to $uri",
        'debug'
    );
818 819 820 821 822 823

    # ACCOUNTING
    # 2 - Inform remote application
    $class->sendHeaders;

    # SECURITY
824
    # Hide Lemonldap::NG cookie
825
    $class->hideCookie;
826 827 828
    OK;
}

829
## @rmethod protected void sendHeaders()
830
# Launch function compiled by forgeHeadersInit()
831 832 833 834
sub sendHeaders {
    &$forgeHeaders;
}

835
## @rmethod int unprotect()
836 837 838 839 840
# Used to unprotect an area.
# To use it, set "PerlHeaderParserHandler My::Package->unprotect" Apache
# configuration file.
# It replace run() by doing nothing.
# @return Apache2::Const::OK
Xavier Guimard's avatar
Xavier Guimard committed
841
sub unprotect {
Xavier Guimard's avatar
Xavier Guimard committed
842
    OK;
843 844
}

845
## @rmethod protected void localUnlog()
846
# Delete current user from local cache entry.
847 848
sub localUnlog {
    my $class = shift;
849
    if ( my $id = $class->fetchId ) {
850

851 852 853 854
        # Delete Apache thread datas
        if ( $id eq $datas->{_session_id} ) {
            $datas = {};
        }
855

856
        # Delete Apache local cache
857
        if ( $refLocalStorage and $refLocalStorage->get($id) ) {
858 859 860
            $refLocalStorage->remove($id);
        }
    }
861 862
}

863
## @rmethod protected int unlog(Apache::RequestRec apacheRequest)
864 865
# Call localUnlog() then goToPortal() to unlog the current user.
# @return Apache2::Const value returned by goToPortal()
866 867
sub unlog ($$) {
    my $class;
868
    ( $class, $apacheRequest ) = @_;
869
    $class->localUnlog;
870
    $class->updateStatus( $apacheRequest->connection->remote_ip, $apacheRequest->uri, 'LOGOUT' );
871
    return $class->goToPortal( '/', 'logout=1' );
Xavier Guimard's avatar
Xavier Guimard committed
872 873
}

874
## @rmethod protected int redirectFilter(string url, Apache2::Filter f)
875 876 877 878 879
# Launch the current HTTP request then redirects the user to $url.
# Used by logout_app and logout_app_sso targets
# @param $url URL to redirect the user
# @param $f Current Apache2::Filter object
# @return Apache2::Const::REDIRECT
880 881 882 883
sub redirectFilter {
    my $class = shift;
    my $url   = shift;
    my $f     = shift;
884
    unless ( $f->ctx ) {
885

886 887
        # Here, we can use Apache2 functions instead of lmSetHeaderOut because
        # this function is used only with Apache2.
888 889
        $f->r->status(REDIRECT);
        $f->r->status_line("302 Temporary Moved");
890
        $f->r->headers_out->unset('Location');
891
        $f->r->err_headers_out->set( 'Location' => $url );
892 893
        $f->ctx(1);
    }
894
    while ( $f->read( my $buffer, 1024 ) ) {
895
    }
896
    $class->updateStatus( ( $datas->{$whatToTrace} ? $datas->{$whatToTrace} : $f->r->connection->remote_ip ), 'filter', 'REDIRECT' );
897 898 899
    return REDIRECT;
}

900
## @rmethod int status(Apache2::RequestRec $r)
901 902 903 904
# Get the result from the status process and launch a PerlResponseHandler to
# display it.
# @param $r Current request
# @return Apache2::Const::OK
905 906 907
sub status($$) {
    my ( $class, $r ) = @_;
    $class->lmLog( "$class: request for status", 'debug' );
908
    return SERVER_ERROR unless ( $statusPipe and $statusOut );
909
    $r->handler("perl-script");
910
    print $statusPipe "STATUS" . ( $r->args ? " " . $r->args : '' ) . "\n";
911
    my $buf;
912 913
    while (<$statusOut>) {
        last if (/^END$/);
914 915 916
        $buf .= $_;
    }
    if ( MP() == 2 ) {
917 918 919
        $r->push_handlers(
            'PerlResponseHandler' => sub {
                my $r = shift;
920
                $r->content_type('text/html; charset=UTF-8');
921 922 923 924
                $r->print($buf);
                OK;
            }
        );
925 926
    }
    else {
927 928 929
        $r->push_handlers(
            'PerlHandler' => sub {
                my $r = shift;
930
                $r->content_type('text/html; charset=UTF-8');
931 932 933 934 935
                $r->send_http_header;
                $r->print($buf);
                OK;
            }
        );
936 937 938 939
    }
    return OK;
}

940 941 942 943
#################
# OTHER METHODS #
#################

944
## @rmethod protected int cleanLocalStorage()
945 946 947 948 949 950 951
# Clean expired values from the local cache.
# @return Apache2::Const::DECLINED
sub cleanLocalStorage {
    $refLocalStorage->purge() if ($refLocalStorage);
    return DECLINED;
}

952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968
1;
__END__

=head1 NAME

Lemonldap::NG::Handler::Simple - Perl base extension for building Lemonldap::NG
compatible handler.

=head1 SYNOPSIS

Create your own package:

  package My::Package;
  use Lemonldap::NG::Handler::Simple;

  our @ISA = qw(Lemonldap::NG::Handler::Simple);

969
  __PACKAGE__->init ({
970
         locationRules        => {
971
               default          => '$ou =~ /brh/'
972
         },
973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995
         globalStorage        => 'Apache::Session::MySQL',
         globalStorageOptions => {
               DataSource       => 'dbi:mysql:database=dbname;host=127.0.0.1',
               UserName         => 'db_user',
               Password         => 'db_password',
               TableName        => 'sessions',
               LockDataSource   => 'dbi:mysql:database=dbname;host=127.0.0.1',
               LockUserName     => 'db_user',
               LockPassword     => 'db_password',
           },
         localStorage         => 'Cache::DBFile',
         localStorageOptions  => {},
         portal               => 'https://portal/',
       });

More complete example

  package My::Package;
  use Lemonldap::NG::Handler::Simple;

  our @ISA = qw(Lemonldap::NG::Handler::Simple);

  __PACKAGE__->init ( { locationRules => {
996 997 998
             '^/pj/.*$'       => '$qualif="opj"',
             '^/rh/.*$'       => '$ou=~/brh/',
             '^/rh_or_opj.*$' => '$qualif="opj" or $ou=~/brh/',
999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026
             default => 'accept', # means that all authenticated users are greanted
           },
           globalStorage        => 'Apache::Session::MySQL',
           globalStorageOptions => {
               DataSource       => 'dbi:mysql:database=dbname;host=127.0.0.1',
               UserName         => 'db_user',
               Password         => 'db_password',
               TableName        => 'sessions',
               LockDataSource   => 'dbi:mysql:database=dbname;host=127.0.0.1',
               LockUserName     => 'db_user',
               LockPassword     => 'db_password',
           },
           localStorage         => 'Cache::DBFile',
           localStorageOptions  => {},
           cookieName           => 'lemon',
           portal               => 'https://portal/',
           whatToTrace          => '$uid',
           exportedHeaders      => {
               'Auth-User'      => '$uid',
               'Unit'           => '$ou',
           https                => 1,
         }
       );

Call your package in <apache-directory>/conf/httpd.conf

  PerlRequire MyFile
  # TOTAL PROTECTION
1027
  PerlHeaderParserHandler My::Package
1028 1029
  # OR SELECTED AREA
  <Location /protected-area>
1030
    PerlHeaderParserHandler My::Package
1031
  </Location>
Xavier Guimard's avatar
Xavier Guimard committed
1032
  
Xavier Guimard's avatar
Xavier Guimard committed
1033 1034
You can also unprotect an URI

Xavier Guimard's avatar
Xavier Guimard committed
1035 1036 1037
  <Files "*.gif">
    PerlHeaderParserHandler My::Package->unprotect
  </Files>
1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079

=head1 DESCRIPTION

Lemonldap::NG::Handler::Simple is designed to be overloaded. See
L<Lemonldap::NG::Handler> for more.

=head2 INITIALISATION PARAMETERS

This section presents the C<init> method parameters.

=over

=item B<locationRules> (required)

Reference to a hash that contains "url-regexp => perl-expression" entries to
manage authorizations.

=over

=item * "url-regexp" can be a perl regexp or the keyword 'default' which
corresponds to the default police (accept by default).

=item * "perl-expression" can be a perl condition or the keyword "accept" or the
keyword "deny". All the variables announced by $<name of the variable> are
replaced by the values resulting from the global session store.

=back

=item B<globalStorage> E<amp> B<globalStorageOptions> (required)

Name and parameters of the Apache::Session::* module used by the portal to
store user's datas. See L<Lemonldap::NG::Portal(3)> for more explanations.

=item B<localStorage> E<amp> B<localStorageOptions>

Name and parameters of the optional but recommanded Cache::* module used to
share user's datas between Apache processes. There is no need to set expires
options since L<Lemonldap::NG::Handler::Simple> call the Cache::*::purge
method itself.

=item B<cookieName> (default: lemon)

1080
Name of the cookie used by the Lemonldap::NG infrastructure.
1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101

=item B<portal> (required)

Url of the portal used to authenticate users.

=item B<whatToTrace> (default: uid)

Stored user variable to use in Apache logs.

=item B<exportedHeaders>

Reference to a hash that contains "Name => value" entries. Those headers are
calculated for each user by replacing the variables announced by "$" by their
values resulting from the global session store.

=item B<https> (default: 1)

Indicates if the protected server is protected by SSL. It is used to build
redirections, so you have to set it to avoid bad redirections after
authentication.

1102 1103 1104 1105
=item B<port> (default: undef)

If port is not well defined in redirection, you can fix listen port here.

1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132
=back

=head2 EXPORT

None by default. You can import the following tags for inheritance:

=over

=item * B<:localStorage> : variables used to manage local storage

=item * B<:globalStorage> : variables used to manage global storage

=item * B<:locationRules> : variables used to manage area protection

=item * B<:import> : import function inherited from L<Exporter> and related
variables

=item * B<:headers> : functions and variables used to manage custom HTTP
headers exported to the applications

=item * B<apache> : functions and variables used to dialog with mod_perl.
This is done to be compatible both with Apache 1 and 2.

=back

=head1 SEE ALSO

1133 1134
L<Lemonldap::NG::Handler>, L<Lemonldap::NG::Portal>,
http://wiki.lemonldap.objectweb.org/xwiki/bin/view/NG/Presentation
1135 1136 1137 1138 1139

=head1 AUTHOR

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

Xavier Guimard's avatar
Xavier Guimard committed
1140 1141 1142 1143 1144 1145 1146 1147 1148 1149
=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>

1150 1151
=head1 COPYRIGHT AND LICENSE

1152
Copyright (C) 2005-2007 by Xavier Guimard E<lt>x.guimard@free.frE<gt>
1153 1154 1155 1156 1157 1158

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.4 or,
at your option, any later version of Perl 5 you may have available.

=cut