Commit 3e2322fe authored by Xavier Guimard's avatar Xavier Guimard
parent ab0b6e71
......@@ -11,10 +11,11 @@ use strict;
use AutoLoader 'AUTOLOAD';
use Apache::Session;
use base qw(Apache::Session);
use Lemonldap::NG::Common::Apache::Session::Serialize::JSON;
use Lemonldap::NG::Common::Apache::Session::Store;
use Lemonldap::NG::Common::Apache::Session::Lock;
our $VERSION = '1.4.4';
our $VERSION = '1.5.99';
sub _load {
my $backend = shift;
......@@ -34,7 +35,6 @@ sub populate {
$self = $self->$backend(@_);
}
if ( $self->{args}->{jsonSerialize} ) {
require Lemonldap::NG::Common::Apache::Session::Serialize::JSON;
$self->{serialize} =
\&Lemonldap::NG::Common::Apache::Session::Serialize::JSON::serialize;
$self->{unserialize} =
......
#######################################################
#
# Lemonldap::NG::Common::Apache::Session::Serialize::JSON
# Serializes session objects using JSON
# Copyright(c) 2015 Xavier Guimard (x.guimard@free.fr)
# Distribute under the GPL2 License
#
#######################################################
package Lemonldap::NG::Common::Apache::Session::Serialize::JSON;
use strict;
......@@ -35,6 +26,8 @@ sub unserialize {
=head1 NAME
=encoding utf8
Lemonldap::NG::Common::Apache::Session::Serialize::JSON - Use JSON to zip up data
=head1 SYNOPSIS
......@@ -50,11 +43,54 @@ This module fulfills the serialization interface of Apache::Session.
It serializes the data in the session object by use of JSON C<encode_json>
and C<decode_json>. The serialized data is UTF-8 text.
=head1 AUTHOR
This module was written by Xavier Guimard <x.guimard@free.fr> using other
Apache::Session serializer written by Jeffrey William Baker <jwbaker@acm.org>.
=head1 SEE ALSO
L<JSON>, L<Apache::Session>
=head1 AUTHORS
=over
=item Clement Oudot, E<lt>clem.oudot@gmail.comE<gt>
=item François-Xavier Deltombe, E<lt>fxdeltombe@gmail.com.E<gt>
=item Xavier Guimard, E<lt>x.guimard@free.frE<gt>
=item Thomas Chemineau, E<lt>thomas.chemineau@gmail.comE<gt>
=back
=head1 BUG REPORT
Use OW2 system to report bug or ask for features:
L<http://jira.ow2.org>
=head1 DOWNLOAD
Lemonldap::NG is available at
L<http://forge.objectweb.org/project/showfiles.php?group_id=274>
=head1 COPYRIGHT AND LICENSE
=over
=item Copyright (C) 2015 by Xavier Guimard, E<lt>x.guimard@free.frE<gt>
=back
This library is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see L<http://www.gnu.org/licenses/>.
=cut
......@@ -10,7 +10,9 @@ package Lemonldap::NG::Common::Conf;
use strict;
no strict 'refs';
use Lemonldap::NG::Common::Conf::Constants; #inherits
use Lemonldap::NG::Common::Conf::Attributes; #inherits
# TODO: don't import this big file, use a proxy
use Lemonldap::NG::Common::Conf::DefaultValues; #inherits
use Lemonldap::NG::Common::Crypto
; #link protected cipher Object "cypher" in configuration hash
use Config::IniFiles;
......@@ -20,7 +22,7 @@ use Config::IniFiles;
#inherits Lemonldap::NG::Common::Conf::SOAP
#inherits Lemonldap::NG::Common::Conf::LDAP
our $VERSION = '1.4.4';
our $VERSION = '1.5.99';
our $msg = '';
our $iniObj;
......@@ -108,12 +110,12 @@ sub new {
# @param $conf Lemonldap::NG configuration hashRef
# @return Number of the saved configuration, 0 if case of error.
sub saveConf {
my ( $self, $conf ) = @_;
my ( $self, $conf, %args ) = @_;
my $last = $self->lastCfg;
# If configuration was modified, return an error
if ( not $self->{force} ) {
if ( not $args{force} ) {
return CONFIG_WAS_CHANGED if ( $conf->{cfgNum} != $last );
return DATABASE_LOCKED if ( $self->isLocked() or not $self->lock() );
}
......@@ -169,24 +171,31 @@ sub getConf {
else {
eval { $r = $self->{refLocalStorage}->get('conf') } if ($>);
$msg = "Warn: $@" if ($@);
if ( ref($r) and $r->{cfgNum} == $args->{cfgNum} ) {
if ( ref($r)
and $r->{cfgNum}
and $args->{cfgNum}
and $r->{cfgNum} == $args->{cfgNum} )
{
$msg .=
"Configuration unchanged, get configuration from cache.\n";
$args->{noCache} = 1;
}
else {
$r = $self->getDBConf($args);
return undef unless ( ref($r) );
return undef unless ( $r->{cfgNum} );
# Adapt some values before storing in local cache
# Get default values
my $confAttributes =
Lemonldap::NG::Common::Conf::Attributes->new();
# TODO: default values may not be set here
unless ( $args->{raw} ) {
my @attributes = $confAttributes->meta()->get_attribute_list();
# Adapt some values before storing in local cache
# Get default values
my $defaultValues =
Lemonldap::NG::Common::Conf::DefaultValues
->defaultValues();
foreach my $name (@attributes) {
$r->{$name} //= $confAttributes->$name;
foreach my $k ( keys %$defaultValues ) {
$r->{$k} //= $defaultValues->{$k};
}
}
# Convert old option useXForwardedForIP into trustedProxies
......@@ -211,15 +220,20 @@ sub getConf {
# Store modified configuration in cache
$self->setLocalConf($r)
if ( $self->{refLocalStorage} and not( $args->{noCache} ) );
if ( $self->{refLocalStorage}
and not( $args->{noCache} or $args->{raw} ) );
}
}
# Create cipher object
eval { $r->{cipher} = Lemonldap::NG::Common::Crypto->new( $r->{key} ); };
if ($@) {
$msg .= "Bad key: $@. \n";
unless ( $args->{raw} ) {
eval {
$r->{cipher} = Lemonldap::NG::Common::Crypto->new( $r->{key} );
};
if ($@) {
$msg .= "Bad key: $@. \n";
}
}
# Return configuration hash
......@@ -345,7 +359,8 @@ sub getDBConf {
: $a[0];
}
my $conf = $self->load( $args->{cfgNum} );
$msg .= "Get configuration $conf->{cfgNum}.\n";
$msg .= "Get configuration $conf->{cfgNum}.\n"
if ( defined $conf->{cfgNum} );
$self->setLocalConf($conf)
if ( ref($conf)
and $self->{refLocalStorage}
......@@ -418,7 +433,7 @@ sub load {
sub delete {
my ( $self, $c ) = @_;
my @a = $self->available();
return 0 unless ( grep {$_ eq $c} @a );
return 0 unless ( grep { $_ eq $c } @a );
return &{ $self->{type} . '::delete' }( $self, $c );
}
......
......@@ -2,12 +2,30 @@ package Lemonldap::NG::Common::Conf::File;
use strict;
use Lemonldap::NG::Common::Conf::Constants; #inherits
use Lemonldap::NG::Common::Conf::Serializer;
our $VERSION = '1.4.0';
our $initDone;
sub Lemonldap::NG::Common::Conf::_lock {
my ( $self, $cfgNum ) = splice @_;
return "$self->{dirName}/lmConf.lock";
}
sub Lemonldap::NG::Common::Conf::_file {
my ( $self, $cfgNum ) = splice @_;
return "$self->{dirName}/lmConf-$cfgNum.js";
}
sub prereq {
my $self = shift;
unless ($initDone) {
eval "use JSON";
if ($@) {
$Lemonldap::NG::Common::Conf::msg .= "Unable to load JSON: $@\n";
return 0;
}
$initDone++;
}
unless ( $self->{dirName} ) {
$Lemonldap::NG::Common::Conf::msg .=
'"dirName" is required in "File" configuration type ! \n';
......@@ -26,7 +44,9 @@ sub available {
opendir D, $self->{dirName};
my @conf = readdir(D);
closedir D;
@conf = sort { $a <=> $b } map { /lmConf-(\d+)/ ? $1 : () } @conf;
@conf =
sort { $a <=> $b }
map { /lmConf-(\d+)(?:\.js)?/ ? ( $1 + 0 ) : () } @conf;
return @conf;
}
......@@ -42,9 +62,9 @@ sub lock {
sleep 2;
return 0 if ( $self->isLocked );
}
unless ( open F, ">" . $self->{dirName} . "/lmConf.lock" ) {
unless ( open F, ">" . $self->_lock ) {
$Lemonldap::NG::Common::Conf::msg .=
"Unable to lock (" . $self->{dirName} . "/lmConf.lock) \n";
"Unable to lock (" . $self->_lock . ") \n";
return 0;
}
print F $$;
......@@ -54,30 +74,25 @@ sub lock {
sub isLocked {
my $self = shift;
-e $self->{dirName} . "/lmConf.lock";
-e $self->_lock;
}
sub unlock {
my $self = shift;
unlink $self->{dirName} . "/lmConf.lock";
unlink $self->_lock;
1;
}
sub store {
my ( $self, $fields ) = @_;
$fields = $self->serialize($fields);
my $mask = umask;
umask( oct('0027') );
unless ( open FILE,
'>' . $self->{dirName} . "/lmConf-" . $fields->{cfgNum} )
{
unless ( open FILE, ">" . $self->_file( $fields->{cfgNum} ) ) {
$Lemonldap::NG::Common::Conf::msg .= "Open file failed: $! \n";
$self->unlock;
return UNKNOWN_ERROR;
}
foreach my $k ( sort keys %$fields ) {
print FILE "$k\n\t$fields->{$k}\n\n";
}
print FILE JSON->new->canonical(1)->encode($fields);
close FILE;
umask($mask);
return $fields->{cfgNum};
......@@ -86,29 +101,59 @@ sub store {
sub load {
my ( $self, $cfgNum, $fields ) = @_;
my $f;
local $/ = "";
unless ( open FILE, $self->{dirName} . "/lmConf-$cfgNum" ) {
$Lemonldap::NG::Common::Conf::msg .= "Open file failed: $! \n";
return undef;
if ( -e $self->_file($cfgNum) ) {
local $/ = '';
open FILE, $self->_file($cfgNum) or die "$!$@";
$f = join( '', <FILE> );
close FILE;
my $ret = eval { decode_json($f); };
die "Unable to load conf: $@\n" if ($@);
return $ret;
}
while (<FILE>) {
my ( $k, $v ) = split /\n\s+/;
chomp $k;
$v =~ s/\n*$//;
if ($fields) {
$f->{$k} = $v if ( grep { $_ eq $k } @$fields );
# Old format
elsif ( -e "$self->{dirName}/lmConf-$cfgNum" ) {
open FILE, "$self->{dirName}/lmConf-$cfgNum" or die "$!$@";
local $/ = "";
unless ( open FILE, $self->{dirName} . "/lmConf-$cfgNum" ) {
$Lemonldap::NG::Common::Conf::msg .= "Open file failed: $! \n";
return undef;
}
else {
$f->{$k} = $v;
while (<FILE>) {
my ( $k, $v ) = split /\n\s+/;
chomp $k;
$v =~ s/\n*$//;
if ($fields) {
$f->{$k} = $v if ( grep { $_ eq $k } @$fields );
}
else {
$f->{$k} = $v;
}
}
close FILE;
require Lemonldap::NG::Common::Conf::Serializer;
return $self->unserialize($f);
}
else {
$Lemonldap::NG::Common::Conf::msg .=
"Unable to find configuration file";
return undef;
}
close FILE;
return $self->unserialize($f);
}
sub delete {
my ( $self, $cfgNum ) = @_;
unlink( $self->{dirName} . "/lmConf-$cfgNum" );
my $file = $self->_file($cfgNum);
if ( -e $file ) {
my $res = unlink($file);
$Lemonldap::NG::Common::Conf::msg .= $! unless ($res);
return $res;
}
else {
$Lemonldap::NG::Common::Conf::msg .=
"Unable to delete conf $cfgNum, no such file";
return 0;
}
}
1;
......
# Now, File.pm is a mix of the old File.pm and JSONFile.pm. So this file is
# just set for compatibility
package Lemonldap::NG::Common::Conf::JSONFile;
use strict;
use Lemonldap::NG::Common::Conf::Constants; #inherits
our $VERSION = '1.4.0';
our $initDone;
sub prereq {
my $self = shift;
unless ($initDone) {
eval "use JSON::Any";
if ($@) {
$Lemonldap::NG::Common::Conf::msg .=
"Unable to load JSON::Any: $@\n";
return 0;
}
$initDone++;
}
unless ( $self->{dirName} ) {
$Lemonldap::NG::Common::Conf::msg .=
'"dirName" is required in "JSONFile" configuration type ! \n';
return 0;
}
unless ( -d $self->{dirName} ) {
$Lemonldap::NG::Common::Conf::msg .=
"Directory \"$self->{dirName}\" does not exist ! \n";
return 0;
}
1;
}
sub available {
my $self = shift;
opendir D, $self->{dirName};
my @conf = readdir(D);
closedir D;
@conf = sort { $a <=> $b } map { /lmConf-(\d+)\.js/ ? $1 : () } @conf;
return @conf;
}
sub lastCfg {
my $self = shift;
my @avail = $self->available;
return $avail[$#avail];
}
sub lock {
my $self = shift;
if ( $self->isLocked ) {
sleep 2;
return 0 if ( $self->isLocked );
}
unless ( open F, ">" . $self->{dirName} . "/lmConf.lock" ) {
$Lemonldap::NG::Common::Conf::msg .=
"Unable to lock (" . $self->{dirName} . "/lmConf.lock) \n";
return 0;
}
print F $$;
close F;
return 1;
}
sub isLocked {
my $self = shift;
-e $self->{dirName} . "/lmConf.lock";
}
sub unlock {
my $self = shift;
unlink $self->{dirName} . "/lmConf.lock";
1;
}
sub store {
my ( $self, $fields ) = @_;
my $mask = umask;
umask( oct('0027') );
unless ( open FILE, ">$self->{dirName}/lmConf-$fields->{cfgNum}.js" ) {
$Lemonldap::NG::Common::Conf::msg .= "Open file failed: $! \n";
$self->unlock;
return UNKNOWN_ERROR;
}
print FILE JSON::Any->objToJson($fields);
close FILE;
umask($mask);
return $fields->{cfgNum};
}
sub load {
my ( $self, $cfgNum, $fields ) = @_;
my $f = '';
open FILE, "$self->{dirName}/lmConf-$cfgNum.js" or die "$!$@";
while (<FILE>) {
$f .= $_;
}
close FILE;
my $ret;
eval { $ret = JSON::Any->jsonToObj($f); };
die "Unable to load conf: $@\n" if ($@);
return $ret;
}
sub delete {
my ( $self, $cfgNum ) = @_;
unlink( $self->{dirName} . "/lmConf-$cfgNum.js" );
}
use Lemonldap::NG::Common::Conf::File;
our @ISA = qw(Lemonldap::NG::Common::Conf::File);
1;
__END__
package Lemonldap::NG::Common::PSGI;
use 5.10.0;
use Mouse;
use JSON;
use Lemonldap::NG::Common::PSGI::Constants;
use Lemonldap::NG::Common::PSGI::Request;
our $VERSION = '1.5.99';
our $_json = JSON->new->allow_nonref;
has error => ( is => 'rw', default => '' );
has languages => ( is => 'rw', isa => 'Str', default => 'en' );
has logLevel => ( is => 'rw', isa => 'Str' );
has staticPrefix => ( is => 'rw', isa => 'Str' );
has templateDir => ( is => 'rw', isa => 'Str' );
has links => ( is => 'rw', isa => 'ArrayRef' );
sub lmLog {
my ( $self, $msg, $level ) = splice @_;
my $levels = {
emerg => 7,
alert => 6,
crit => 5,
error => 4,
warn => 3,
notice => 2,
info => 1,
debug => 0
};
my $l = $levels->{$level} || 1;
return if ( ref($self) and $l < $levels->{ $self->{logLevel} } );
print STDERR "[$level] " . ( $l ? '' : (caller)[0] . ': ' ) . " $msg\n";
}
# Responses methods
sub sendJSONresponse {
my ( $self, $req, $j, %args ) = splice @_;
$args{code} ||= 200;
my $type = 'text/json';
if ( ref $j ) {
if ( $args{forceJSON} or $req->accept =~ m|application/json| ) {
$j = $_json->encode($j);
}
else {
# TODO: escape keys in hash values
eval {
require XML::Simple;
$j = XML::Simple::XMLout($j);
$type = 'text/xml';
};
}
}
return [ $args{code}, [ 'Content-Type', $type ], [$j] ];
}
sub sendError {
my ( $self, $req, $err, $code ) = splice @_;
$err ||= $req->error;
$code ||= 500;
return $self->sendJSONresponse( $req, { error => $err }, code => $code );
}
sub abort {
my ( $self, $err ) = splice @_;
$self->lmLog( $err, 'error' );
return sub {
$self->sendError( Lemonldap::NG::Common::PSGI::Request->new( $_[0] ),
$err, 500 );
};
}
sub _mustBeDefined {
my $name = ( caller(1) )[3];