Commit b3d05721 authored by dcoutadeur dcoutadeur's avatar dcoutadeur dcoutadeur

- Merging branch lemonldap-ng-experimental/Handler-Mouse with with trunk

code impacted:
* lemonldap-ng-handler/*: handler code,
* lemonldap-ng-handler/example/*.pm: handler aliases to libraries,
* _example/etc/*.conf: virtual host templates
(references #630, #LEMONLDAP-386)

(second part of incomplete r3251 commit)

parent 87b25795
## @file
# Base file for Lemonldap::NG handlers
## @class
# 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().
package Lemonldap::NG::Handler::Initialization::LocalInit;
use Mouse;
use Lemonldap::NG::Handler::Main::Logger;
our $VERSION = '1.3.0';
# Mouse attributes
##################
# default attributes from constructor
has localStorage => ( is => 'rw', isa => 'Maybe[Str]', required => 1 );
has refLocalStorage => ( is => 'rw', required => 1 );
has localStorageOptions =>
( is => 'rw', isa => 'Maybe[HashRef]', required => 1 );
has childInitDone => ( is => 'rw' );
# attributes built and returned
has [ 'statusPipe', 'statusOut' ] => ( is => 'rw' );
BEGIN {
if ( exists $ENV{MOD_PERL} ) {
if ( $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 ) {
eval 'use constant MP => 2;';
}
else {
eval 'use constant MP => 1;';
}
}
else {
eval 'use constant MP => 0;';
}
if ( MP() == 2 ) {
require Apache2::Log;
require Apache2::RequestUtil;
Apache2::RequestUtil->import();
require Apache2::RequestRec;
Apache2::RequestRec->import();
require Apache2::ServerUtil;
Apache2::ServerUtil->import();
require Apache2::Connection;
Apache2::Connection->import();
require Apache2::RequestIO;
Apache2::RequestIO->import();
require APR::Table;
APR::Table->import();
require Apache2::URI;
Apache2::URI->import();
require Apache2::Const;
Apache2::Const->import( '-compile', qw(:common :log) );
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;
';
}
elsif ( MP() == 1 ) {
require Apache;
require Apache::Log;
require Apache::Constants;
Apache::Constants->import(':common');
Apache::Constants->import(':response');
}
else { # For Test or CGI
eval '
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;
';
}
}
# Mouse methods
###############
## @imethod void localInit(hashRef args)
# Call purgeCache() to purge the local cache, launch the status process
# (statusProcess()) in wanted and launch childInit().
# @param $args reference to the initialization hash
sub localInit($$) {
my ( $self, $args ) = splice @_;
if ( $self->{localStorage} = $args->{localStorage} ) {
$self->{localStorageOptions} = $args->{localStorageOptions};
$self->{localStorageOptions}->{default_expires_in} ||= 600;
$self->purgeCache();
}
if ( $args->{status} ) {
if ( defined $self->{localStorage} ) {
$self->statusProcess();
}
else {
# localStorage is mandatory for status module
Lemonldap::NG::Handler::Main::Logger->lmLog(
"Status module can not be loaded without localStorage parameter",
'warn'
);
}
}
$self->childInit($args);
return (
$self->{localStorage}, $self->{refLocalStorage},
$self->{localStorageOptions}, $self->{statusPipe},
$self->{statusOut}, $self->{childInitDone}
);
}
## @imethod protected void purgeCache()
# Purge the local cache.
# Launched at Apache startup.
sub purgeCache {
my $self = shift;
eval "use $self->{localStorage};";
die("Unable to load $self->{localStorage}: $@") if ($@);
# At each Apache (re)start, we've to clear the cache to avoid living
# with old datas
eval '$self->{refLocalStorage} = new '
. $self->{localStorage}
. '($self->{localStorageOptions});';
if ( defined $self->{refLocalStorage} ) {
$self->{refLocalStorage}->clear();
}
else {
Lemonldap::NG::Handler::Main::Logger->lmLog(
"Unable to clear local cache: $@", 'error' );
}
}
# Status daemon creation
## @ifn protected void statusProcess()
# Launch the status processus.
sub statusProcess {
my $self = shift;
require IO::Pipe;
$self->{statusPipe} = IO::Pipe->new;
$self->{statusOut} = IO::Pipe->new;
if ( my $pid = fork() ) {
$self->{statusPipe}->writer();
$self->{statusOut}->reader();
$self->{statusPipe}->autoflush(1);
}
else {
require Data::Dumper;
$self->{statusPipe}->reader();
$self->{statusOut}->writer();
my $fdin = $self->{statusPipe}->fileno;
my $fdout = $self->{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('
. $self->{localStorage} . ','
. Data::Dumper->new( [ $self->{localStorageOptions} ] )->Terse(1)
->Dump . ');';
}
}
## @imethod protected boolean childInit()
# Indicates to Apache that it has to launch:
# - initLocalStorage() for each child process (after fork and uid change)
# - cleanLocalStorage() after each requests
# @return True
sub childInit {
my ( $self, $args ) = splice @_;
return 1 if ( $self->{childInitDone} );
# 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 ) {
$s = Apache2::ServerUtil->server;
$s->push_handlers( PerlChildInitHandler =>
sub { return $self->initLocalStorage( $_[1], $_[0] ); } );
$s->push_handlers(
PerlPostConfigHandler => sub {
my ( $c, $l, $t, $s ) = splice @_;
$s->add_version_component(
'Lemonldap::NG::Handler/' . $VERSION );
}
) unless ( $args->{hideSignature} );
}
elsif ( MP() == 1 ) {
Apache->push_handlers(
PerlChildInitHandler => sub { return $self->initLocalStorage(@_); }
);
}
$self->{childInitDone}++;
1;
}
## @imethod protected int initLocalStorage()
# Prepare local cache (if not done before by Lemonldap::NG::Common::Conf)
# @return Apache2::Const::DECLINED
sub initLocalStorage {
my ( $self, $r ) = splice @_;
if ( $self->{localStorage} and not $self->{refLocalStorage} ) {
eval
"use $self->{localStorage};\$self->{refLocalStorage} = new $self->{localStorage}(\$self->{localStorageOptions});";
Lemonldap::NG::Handler::Main::Logger->lmLog(
"Local cache initialization failed: $@", 'error' )
unless ( defined $self->{refLocalStorage} );
}
return DECLINED;
}
1;
This diff is collapsed.
package Lemonldap::NG::Handler::Main::Headers;
use strict;
use Lemonldap::NG::Handler::Main qw( :apache ); # for importing MP function
use Lemonldap::NG::Handler::Main::Logger;
our $VERSION = '1.3.1';
BEGIN {
if ( MP() == 2 ) {
require Apache2::Log;
require Apache2::RequestUtil;
Apache2::RequestUtil->import();
require Apache2::RequestRec;
Apache2::RequestRec->import();
require Apache2::ServerUtil;
Apache2::ServerUtil->import();
require Apache2::Connection;
Apache2::Connection->import();
require Apache2::RequestIO;
Apache2::RequestIO->import();
require APR::Table;
APR::Table->import();
require Apache2::URI;
Apache2::URI->import();
require Apache2::Const;
Apache2::Const->import( '-compile', qw(:common :log) );
}
elsif ( MP() == 1 ) {
require Apache;
require Apache::Log;
require Apache::Constants;
Apache::Constants->import(':common');
Apache::Constants->import(':response');
}
}
## @rmethod void lmSetHeaderIn(Apache2::RequestRec r, hash headers)
# Set HTTP headers in the HTTP request.
# @param $r Current request
# @param %headers Hash of header names and values
sub lmSetHeaderIn {
my ( $self, $r, %headers ) = splice @_;
while ( my ( $h, $v ) = each %headers ) {
if ( MP() == 2 ) {
$r->headers_in->set( $h => $v );
}
elsif ( MP() == 1 ) {
$r->header_in( $h => $v );
}
Lemonldap::NG::Handler::Main::Logger->lmLog(
"Send header $h with value $v", 'debug' );
}
}
## @rmethod void lmUnsetHeaderIn(Apache2::RequestRec r, array headers)
# Unset HTTP headers in the HTTP request.
# @param $r Current request
# @param @headers Name of the headers
sub lmUnsetHeaderIn {
my ( $self, $r, @headers ) = splice @_;
foreach my $h (@headers) {
if ( MP() == 2 ) {
$r->headers_in->unset($h);
}
elsif ( MP() == 1 ) {
$r->header_in( $h => "" )
if ( $r->header_in($h) );
}
Lemonldap::NG::Handler::Main::Logger->lmLog( "Unset header $h",
'debug' );
}
}
## @rfn string lmHeaderIn(Apache2::RequestRec r, string h)
# Return an HTTP header value from the HTTP request.
# @param $r Current request
# @param $h Name of the header
# @return Value of the header
sub lmHeaderIn {
my ( $self, $r, $h ) = splice @_;
use Data::Dumper;
if ( MP() == 2 ) {
return $r->headers_in->{$h};
}
elsif ( MP() == 1 ) {
return $r->header_in($h);
}
}
## @rfn void lmSetErrHeaderOut(Apache2::RequestRec r, string h, string v)
# 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
sub lmSetErrHeaderOut {
my ( $self, $r, $h, $v ) = splice @_;
if ( MP() == 2 ) {
return $r->err_headers_out->set( $h => $v );
}
elsif ( MP() == 1 ) {
return $r->err_header_out( $h => $v );
}
}
## @rfn void lmSetHeaderOut(Apache2::RequestRec r, string h, string v)
# 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
sub lmSetHeaderOut {
my ( $self, $r, $h, $v ) = splice @_;
if ( MP() == 2 ) {
return $r->headers_out->set( $h => $v );
}
elsif ( MP() == 1 ) {
return $r->header_out( $h => $v );
}
}
## @rfn string lmHeaderOut(Apache2::RequestRec r, string h)
# Return an HTTP header value from the HTTP response.
# @param $r Current request
# @param $h Name of the header
# @return Value of the header
sub lmHeaderOut {
my ( $self, $r, $h, $v ) = splice @_;
if ( MP() == 2 ) {
return $r->headers_out->{$h};
}
elsif ( MP() == 1 ) {
return $r->header_out($h);
}
}
## @rmethod void sendHeaders()
# Launch function compiled by forgeHeadersInit() for the current virtual host
sub sendHeaders {
my ( $self, $apacheRequest, $forgeHeaders ) = splice @_;
my $vhost = $apacheRequest->hostname;
if ( defined( $forgeHeaders->{$vhost} ) ) {
lmSetHeaderIn( $self, $apacheRequest, &{ $forgeHeaders->{$vhost} } );
}
}
## @rmethod void cleanHeaders()
# Unset HTTP headers for the current virtual host, when sendHeaders is skipped
sub cleanHeaders {
my ( $self, $apacheRequest, $forgeHeaders, $headerList ) = splice @_;
my $vhost = $apacheRequest->hostname;
if ( defined( $forgeHeaders->{$vhost} ) ) {
lmUnsetHeaderIn( $self, $apacheRequest, @{ $headerList->{$vhost} } );
}
}
1;
package Lemonldap::NG::Handler::Main::Jail;
use strict;
use Safe;
use Lemonldap::NG::Common::Safelib; #link protected safe Safe object
use constant SAFEWRAP => ( Safe->can("wrap_code_ref") ? 1 : 0 );
use Mouse;
use Lemonldap::NG::Handler::Main::Logger;
has customFunctions => ( is => 'rw', isa => 'Maybe[Str]' );
has useSafeJail => ( is => 'rw', isa => 'Maybe[Int]' );
has safe => ( is => 'rw' );
our $VERSION = '1.3.1';
# for accessing $datas and $apacheRequest
use Lemonldap::NG::Handler::Main ':jailSharedVars';
## @imethod protected build_safe()
# Build and return the security jail used to compile rules and headers.
# @return Safe object
sub build_safe {
my $self = shift;
return $self->safe if ( $self->safe );
$self->useSafeJail(1) unless defined $self->useSafeJail;
my @t =
$self->customFunctions ? split( /\s+/, $self->customFunctions ) : ();
foreach (@t) {
Lemonldap::NG::Handler::Main::Logger->lmLog( "Custom function : $_",
'debug' );
my $sub = $_;
unless (/::/) {
$sub = "$self\::$_";
}
else {
s/^.*:://;
}
next if ( $self->can($_) );
eval "sub $_ {
my \$uri = \$Lemonldap::NG::Handler::Main::apacheRequest->unparsed_uri();
Apache2::URI::unescape_url(\$uri);
return $sub(\$uri, \@_)
}";
Lemonldap::NG::Handler::Main::Logger->lmLog( $@, 'error' ) if ($@);
}
if ( $self->useSafeJail ) {
$self->safe( Safe->new );
$self->safe->share_from( 'main', ['%ENV'] );
}
else {
$self->safe($self);
}
# Share objects with Safe jail
$self->safe->share_from( 'Lemonldap::NG::Common::Safelib',
$Lemonldap::NG::Common::Safelib::functions );
$self->safe->share_from( 'Lemonldap::NG::Handler::Main',
[ '$datas', '$apacheRequest', '&ip', '&portal' ] );
$self->safe->share(@t);
$self->safe->share_from( 'MIME::Base64', ['&encode_base64'] );
return $self->safe;
}
## @method reval
# Fake reval method if useSafeJail is off
sub reval {
my ( $self, $e ) = splice @_;
return eval $e;
}
## @method wrap_code_ref
# Fake wrap_code_ref method if useSafeJail is off
sub wrap_code_ref {
my ( $self, $e ) = splice @_;
return $e;
}
## @method share
# Fake share method if useSafeJail is off
sub share {
my ( $self, @vars ) = splice @_;
$self->share_from( scalar(caller), \@vars );
}
## @method share_from
# Fake share_from method if useSafeJail is off
sub share_from {
my ( $self, $pkg, $vars ) = splice @_;
no strict 'refs';
foreach my $arg (@$vars) {
my ( $var, $type );
$type = $1 if ( $var = $arg ) =~ s/^(\W)//;
for ( 1 .. 2 ) { # assign twice to avoid any 'used once' warnings
*{$var} =
( !$type ) ? \&{ $pkg . "::$var" }
: ( $type eq '&' ) ? \&{ $pkg . "::$var" }
: ( $type eq '$' ) ? \${ $pkg . "::$var" }
: ( $type eq '@' ) ? \@{ $pkg . "::$var" }
: ( $type eq '%' ) ? \%{ $pkg . "::$var" }
: ( $type eq '*' ) ? *{ $pkg . "::$var" }
: undef;
}
}
}
## @imethod protected jail_reval()
# Build and return restricted eval command with SAFEWRAP, if activated
# @return evaluation of $reval or $reval2
sub jail_reval {
my ( $self, $reval, $reval2 ) = splice @_;
return (
SAFEWRAP
? $self->safe->wrap_code_ref( $self->safe->reval($reval) )
: $self->safe->reval($reval2)
);
}
1;
package Lemonldap::NG::Handler::Main::Logger;
use Lemonldap::NG::Handler::Main qw( :apache );
## @rmethod void lmLog(string mess, string level)
# Wrapper for Apache log system
# @param $mess message to log
# @param $level string (debug, info, warning or error)
sub lmLog {
my ( $class, $mess, $level ) = splice @_;
die("Level is required") unless ($level);
my $call;
my @tmp = caller();
my $module = $tmp[0] =~ s/.+:://gr . "($tmp[2]): ";
unless ( $level eq 'debug' ) {
$call = "$tmp[1] $tmp[2]:";
}
if ( MP() == 2 ) {
Apache2::ServerRec->log->debug($call) if ($call);
Apache2::ServerRec->log->$level( $module . $mess );
}
elsif ( MP() == 1 ) {
Apache->server->log->debug($call) if ($call);
Apache->server->log->$level( $module . $mess );
}
else {
print STDERR "[$level] $module $mess\n";
}
}
1;
package Lemonldap::NG::Handler::Main::PostForm;
use strict;
# For importing MP function, $ntsv->{transform}, $apacheRequest,
# $ntsv->{safe}, $tsv->{useSafeJail}, $tsv->{customFunctions}
use Lemonldap::NG::Handler::Main qw( :apache :ntsv :tsv $apacheRequest );
use Lemonldap::NG::Handler::Main::Logger;
use Lemonldap::NG::Handler::Main::Jail;
our $VERSION = '1.3.1';
BEGIN {
if ( MP() == 2 ) {
require Apache2::URI;
Apache2::URI->import();
}
elsif ( MP() == 1 ) {
require Apache;
require Apache::Log;
require Apache::Constants;
Apache::Constants->import(':common');
Apache::Constants->import(':response');
}
}
## @rmethod protected transformUri(string uri)
# Transform URI to replay POST forms
# @param uri URI to catch
# @return Apache2::Const
sub transformUri {
my ( $class, $uri ) = splice @_;
my $vhost = $apacheRequest->hostname;
if ( defined( $ntsv->{transform}->{$vhost}->{$uri} ) ) {
return &{ $ntsv->{transform}->{$vhost}->{$uri} };
}
OK;
}
## @imethod protected buildPostForm(string url, int count)
# Build form that will be posted by client
# Fill an input hidden with fake value to
# reach the size of initial request
# @param url Target of POST
# @param count Fake input size
# @return Apache2::Const::OK
sub buildPostForm {
my $class = shift;
my $url = shift;
my $count = shift || 1000;
$apacheRequest->handler("perl-script");
$apacheRequest->add_config( ["SetHandler perl-script"] );
$apacheRequest->set_handlers(
'PerlResponseHandler' => sub {
my $r = shift;
$r->content_type('text/html; charset=UTF-8');
$r->print(
qq{<html><body onload="document.getElementById('f').submit()"><form id="f" method="post" action="$url" style="visibility:hidden"><input type=hidden name="a" value="}
. sprintf( "%0" . $count . "d", 1 )
. qq{"/><input type="submit" value="Ok"/></form></body></html>}
);
OK;
}
);
OK;
}
## @rmethod protected int postFilter(hashref data, Apache2::Filter f)
# POST data
# @param $data Data to POST
# @param $f Current Apache2::Filter object
# @return Apache2::Const::OK
sub postFilter {
my $class = shift;
my $data = shift;
my $f = shift;
my $l;
unless ( $f->ctx ) {
$f->ctx(1);
# Create the transformed form data
my $u = URI->new('http:');
my $jail = Lemonldap::NG::Handler::Main::Jail->new(
'safe' => $ntsv->{safe},
'useSafeJail' => $tsv->{useSafeJail},
'customFunctions' => $tsv->{customFunctions}
);
$ntsv->{safe} = $jail->build_safe();
$u->query_form( { $ntsv->{safe}->reval($data) } );
my $s = $u->query();
# Eat all fake data sent by client
$l = $f->r->headers_in->{'Content-Length'};
while ( $f->read( my $b, $l ) ) { }
# Send to application real data
$f->r->headers_in->set( 'Content-Length' => length($s) );
$f->r->headers_in->set(
'Content-Type' => 'application/x-www-form-urlencoded' );
$f->print($s);
Lemonldap::NG::Handler::Main::Logger->lmLog( "Send POST data $s",
'debug' );
# Mark this filter as done
$f->seen_eos(1);
}
return OK;
}