Commit 19e59af4 authored by Yadd's avatar Yadd
Browse files

log & debug method lmLog() for CGIs

parent ed55803c
......@@ -17,6 +17,42 @@ our $VERSION = '0.4';
use base qw(CGI);
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;';
}
}
## @method void lmLog(string mess, string level)
# Log subroutine. Use Apache::Log in ModPerl::Registry context else simply
# print on STDERR non debug messages.
# @param $mess Text to log
# @param $level Level (debug|info|notice|error)
sub lmLog {
my($self,$mess,$level) = @_;
$mess = (ref($self)?ref($self):$self).": $mess" if($level eq 'debug');
if( $self->r and MP() ) {
if(MP()==2) {
require Apache2::Log;
Apache2::ServerRec->log->$level($mess);
}
else {
Apache->server->log->$level($mess);
}
}
else {
print STDERR "$mess\n" unless($level =~ /^(?:debug|info)$/);
}
}
## @method void soapTest(string soapFunctions object obj)
# Check if request is a SOAP request. If it is, launch
# Lemonldap::NG::Common::CGI::SOAPServer and exit. Else simply return.
......
......@@ -24,7 +24,8 @@ sub authInit {
sub extractFormInfo {
my $self = shift;
unless ( $self->{user} = $ENV{REMOTE_USER} ) {
print STDERR "Apache is not configured to authenticate users !";
$self->lmLog( 'Apache is not configured to authenticate users !',
'error' );
return PE_ERROR;
}
......
......@@ -40,9 +40,9 @@ sub authenticate {
}
# Set the dn unless done before
unless($self->{dn}) {
unless ( $self->{dn} ) {
my $tmp = $self->_subProcess(qw(_formateFilter _search));
return $tmp if($tmp);
return $tmp if ($tmp);
}
# Check if we use Ppolicy control
......
......@@ -9,9 +9,11 @@ use strict;
use warnings;
require Lemonldap::NG::Common::CGI;
use Lemonldap::NG::Portal::SharedConf;
use Lemonldap::NG::Portal::_LDAP; #link protected ldap Object used to change passwords only
use Lemonldap::NG::Portal::_LDAP
; #link protected ldap Object used to change passwords only
use XML::LibXML;
use Safe;
#inherits Net::LDAP::Control::PasswordPolicy
our $VERSION = '0.02';
......@@ -44,7 +46,7 @@ sub _safe {
eval "sub $_ {
return $sub(\$path,\@_);
}";
print STDERR "$@\n" if ($@);
$self->{portalObject}->lmLog( $@, 'error' ) if ($@);
}
$self->{_safe}->share( '&encode_base64', @t );
return $self->{_safe};
......@@ -64,11 +66,12 @@ sub new {
# Get configuration
$self->Lemonldap::NG::Portal::Simple::getConf(@_)
or Lemonldap::NG::Common::CGI->abort("Unable to read $class->new() parameters");
or Lemonldap::NG::Common::CGI->abort(
"Unable to read $class->new() parameters");
# Portal is required
Lemonldap::NG::Common::CGI->abort("Portal object required") unless ( $self->{portalObject} );
Lemonldap::NG::Common::CGI->abort("Portal object required")
unless ( $self->{portalObject} );
# Fill sessionInfo
&Lemonldap::NG::Portal::Simple::getSessionInfo( $self->{portalObject} );
......@@ -220,10 +223,8 @@ sub _getXML {
my $parser = XML::LibXML->new();
$parser->validation('1');
my $xml;
eval {
$xml = $parser->parse_file( $self->{apps}->{xmlfile} );
};
$self->{portalObject}->abort("Bad XML file", $@) if($@);
eval { $xml = $parser->parse_file( $self->{apps}->{xmlfile} ); };
$self->{portalObject}->abort( "Bad XML file", $@ ) if ($@);
my $root = $xml->documentElement;
# Filter XML file with user's authorizations
......@@ -405,6 +406,7 @@ sub _hideEmptyCategory {
# @param $oldpassword Current password
# @return Lemonldap::NG::Portal constant
sub _changePassword {
# TODO: Check used Auth module and change password for LDAP or DBI
my $self = shift;
my ( $newpassword, $confirmpassword, $oldpassword ) = @_;
......@@ -438,8 +440,9 @@ sub _changePassword {
# require Perl module
eval 'require Net::LDAP::Control::PasswordPolicy';
if ($@) {
print STDERR
"Module Net::LDAP::Control::PasswordPolicy not found in @INC\n";
$self->{portalObject}->lmLog(
"Module Net::LDAP::Control::PasswordPolicy not found in @INC",
'error' );
return PE_LDAPERROR;
}
no strict 'subs';
......@@ -550,8 +553,9 @@ sub _grant {
}
}
unless ( $defaultCondition->{$vhost} ) {
print STDERR
"Application $uri did not match any configured virtual host\n";
$self->{portalObject}
->lmLog( "Application $uri did not match any configured virtual host",
'warn' );
return 0;
}
return &{ $defaultCondition->{$vhost} }($self);
......
......@@ -64,6 +64,10 @@ sub new {
my ( $class, $storage ) = @_;
my $self = bless {}, $class;
(%$self) = (%$storage);
unless ( $self->{p} ) {
$msg = "p=>portal is required";
return 0;
}
my $type = $self->{type};
$self->{type} = "Lemonldap::NG::Portal::Notification::$self->{type}"
unless ( $self->{type} =~ /::/ );
......@@ -78,20 +82,13 @@ sub new {
return $self;
}
## @method protected void warn(string text)
# Notification will never die, but just insert warnings in the log file.
# @param $text Text to log
sub warn {
my ( $self, $text ) = @_;
print STDERR "Notification warning : $text\n";
}
## @method protected void notice(string text)
# Logs notification events
# @param $text Text to log
sub notice {
my ( $self, $text ) = @_;
print STDERR "Notification event : $text\n";
## @method protected void lmLog(string mess, string level)
# Log subroutine. Call Lemonldap::NG::Portal::lmLog().
# @param $mess Text to log
# @param $level Level (debug|info|notice|error)
sub lmLog {
my ( $self, $mess, $level ) = @_;
$self->{p}->lmLog( "[Notification] $mess", $level );
}
## @method string getNotification(Lemonldap::NG::Portal portal)
......@@ -118,8 +115,9 @@ sub getNotification {
$form .= $stylesheet->output_string($results);
};
if ($@) {
$self->warn(
"Bad XML file: a notification for $uid was not done ($@)");
$self->lmLog(
"Bad XML file: a notification for $uid was not done ($@)",
'warn' );
return 0;
}
}
......@@ -130,8 +128,9 @@ sub getNotification {
$i++;
my $t = $portal->{cipher}->encrypt( $tmp->value );
unless ( defined($t) ) {
$self->warn(
"Notification for $uid was not done : $Lemonldap::NG::Common::Crypto::msg"
$self->lmLog(
"Notification for $uid was not done : $Lemonldap::NG::Common::Crypto::msg",
'warn'
);
return 0;
}
......@@ -161,7 +160,7 @@ sub checkNotification {
my %tmp = @tmp;
my $value = $portal->{cipher}->decrypt( $tmp[1] );
unless ( defined($value) ) {
$self->warn("$Lemonldap::NG::Common::Crypto::msg");
$self->lmLog( "Unable to decrypt cookie", 'warn' );
return 0;
}
push @{ $portal->{cookie} },
......@@ -189,7 +188,7 @@ sub checkNotification {
}
$portal->controlExistingSession() unless ( $portal->{sessionInfo} );
unless ( $portal->{sessionInfo} ) {
$self->warn("Invalid session");
$self->lmLog( "Invalid session", 'warn' );
return 0;
}
my $result = 1;
......@@ -203,14 +202,15 @@ sub checkNotification {
my $files = $self->_get( $uid, $refs->{$ref} );
unless ($files) {
$self->warn("Can find notification $refs->{$ref} for $uid");
$self->lmLog( "Can find notification $refs->{$ref} for $uid",
'error' );
next;
}
foreach my $file ( keys %$files ) {
my $xml;
eval { $xml = $parser->parse_string( $files->{$file} ) };
if ($@) {
$self->warn("Bad XML notification for $uid");
$self->lmLog( "Bad XML notification for $uid", 'error' );
next;
}
foreach my $notif (
......@@ -225,18 +225,21 @@ sub checkNotification {
)
{
if ( $self->_delete($file) ) {
$self->notice(
"$uid has accepted notification $refs->{$ref}");
$self->lmLog(
"$uid has accepted notification $refs->{$ref}",
'notice' );
}
else {
$self->warn(
"Unable to delete notification $refs->{$ref} for $uid"
$self->lmLog(
"Unable to delete notification $refs->{$ref} for $uid",
'error'
);
}
}
else {
$self->notice(
"$uid has not accepted notification $refs->{$ref}");
$self->lmLog(
"$uid has not accepted notification $refs->{$ref}",
'notice' );
$result = 0;
}
}
......@@ -253,7 +256,7 @@ sub newNotification {
my ( $self, $xml ) = @_;
eval { $xml = $parser->parse_string($xml); };
if ($@) {
$self->warn("Unable to read XML file : $@");
$self->lmLog( "Unable to read XML file : $@", 'error' );
return 0;
}
my @notifs;
......@@ -265,7 +268,7 @@ sub newNotification {
foreach (qw(date uid reference)) {
my $tmp;
unless ( $tmp = $notif->getAttribute($_) ) {
$self->warn("Attribute $_ is missing");
$self->lmLog( "Attribute $_ is missing", 'error' );
return 0;
}
push @datas, $tmp;
......
......@@ -18,7 +18,7 @@ sub prereq {
'"dbiChain" is required in DBI notification type';
return 0;
}
print STDERR __PACKAGE__ . 'Warning: "dbiUser" parameter is not set'
$self->lmLog( 'Warning: "dbiUser" parameter is not set', 'warn' )
unless ( $self->{dbiUser} );
1;
}
......@@ -43,7 +43,7 @@ sub get {
while ( my $h = $self->{sth}->fetchrow_hashref() ) {
$result->{ "$h->{date}#$h->{uid}#$h->{ref}", $h->{xml} };
}
$self->warn( $self->{sth}->err() ) if ( $self->{sth}->err() );
$self->lmLog( $self->{sth}->err(), 'warn' ) if ( $self->{sth}->err() );
return $result;
}
......@@ -54,7 +54,7 @@ sub delete {
my ( $self, $myref ) = @_;
my ( $d, $u, $r );
unless ( ( $d, $u, $r ) = ( $myref =~ /^(\d+)#(.+?)#(.+)$/ ) ) {
$self->warn("Bad reference $myref");
$self->lmLog( "Bad reference $myref", 'warn' );
return 0;
}
$u =~ s/'/''/g;
......@@ -94,12 +94,12 @@ sub _execute {
my ( $self, $query ) = @_;
my $dbh = $self->dbh() or return 0;
unless ( $self->{sth} = $dbh->prepare($query) ) {
$self->warn( $dbh->errstr() );
$self->lmLog( $dbh->errstr(), 'warn' );
return 0;
}
my $tmp;
unless ( $tmp = $self->{sth}->execute() ) {
$self->warn( $self->{sth}->errstr() );
$self->lmLog( $self->{sth}->errstr(), 'warn' );
return 0;
}
return $tmp;
......@@ -116,7 +116,7 @@ sub dbh {
$self->{dbiChain}, $self->{dbiUser},
$self->{dbiPassword}, { RaiseError => 0 }
);
print STDERR "$DBI::errstr\n" unless ($r);
$self->lmLog( $DBI::errstr, 'error' ) unless ($r);
return $r;
}
......
......@@ -53,7 +53,8 @@ sub get {
my $files;
foreach my $file (@notif) {
unless ( open F, $self->{dirName} . "/$file" ) {
print STDERR "Unable to read notification $self->{dirName}/$_\n";
$self->lmLog( "Unable to read notification $self->{dirName}/$_",
'error' );
next;
}
$files->{$file} = join( '', <F> );
......
......@@ -152,6 +152,7 @@ sub new {
$tmp->{type} =~ s/.*:://;
$tmp->{table} = 'notifications';
}
$tmp->{p} = $self;
$self->{notifObject} = Lemonldap::NG::Portal::Notification->new($tmp);
$self->abort($Lemonldap::NG::Portal::Notification::msg)
unless ( $self->{notifObject} );
......@@ -161,7 +162,6 @@ sub new {
and $ENV{PATH_INFO} =~ "/notification" )
{
require SOAP::Lite;
$Lemonldap::NG::Portal::Notification::self = $self->{notifObject};
$self->soapTest( 'newNotification', $self->{notifObject} );
$self->abort( 'Bad request',
'Only SOAP requests are accepted with "/notification"' );
......@@ -208,7 +208,10 @@ sub error {
my $self = shift;
my $lang = shift || $ENV{HTTP_ACCEPT_LANGUAGE};
my $code = shift || $self->{error};
return &Lemonldap::NG::Portal::_i18n::error( $code, $lang );
my $tmp = &Lemonldap::NG::Portal::_i18n::error( $code, $lang );
return ( $ENV{HTTP_SOAPACTION}
? SOAP::Data->name( result => $tmp )->type('string')
: $tmp );
}
##@method string error_type(int code)
......@@ -324,8 +327,8 @@ sub getSessionInfo {
if ( $@ or not tied(%h) ) {
# Session not available (expired ?)
print STDERR
"Session $id isn't yet available ($ENV{REMOTE_ADDR})\n";
$self->lmLog( "Session $id isn't yet available ($ENV{REMOTE_ADDR})",
'info' );
return undef;
}
......@@ -364,8 +367,8 @@ sub updateSession {
if ( $@ or not tied(%h) ) {
# Session not available (expired ?)
print STDERR
"Session $id isn't yet available ($ENV{REMOTE_ADDR})\n";
$self->lmLog( "Session $id isn't yet available ($ENV{REMOTE_ADDR})",
'info' );
return undef;
}
......@@ -391,11 +394,12 @@ sub _subProcess {
foreach my $sub (@subs) {
#print STDERR "DEBUG : $sub\n";
if ( $self->{$sub} ) {
$self->lmLog( "processing to custom sub $sub", 'debug' );
last if ( $err = &{ $self->{$sub} }($self) );
}
else {
$self->lmLog( "processing to sub $sub", 'debug' );
last if ( $err = $self->$sub );
}
}
......@@ -453,7 +457,7 @@ sub safe {
eval "sub $_ {
return $sub( '$self->{portal}', \@_ );
}";
print STDERR $@ if ($@);
$self->lmLog( $@, 'error' ) if ($@);
}
$safe->share( '&encode_base64', @t );
return $safe;
......@@ -622,8 +626,8 @@ sub controlExistingSession {
if ( $@ or not tied(%h) ) {
# Session not available (expired ?)
print STDERR
"Session $id isn't yet available ($ENV{REMOTE_ADDR})\n";
$self->lmLog( "Session $id isn't yet available ($ENV{REMOTE_ADDR})",
'info' );
return PE_OK;
}
......@@ -759,7 +763,7 @@ sub store {
tie %h, $self->{globalStorage}, undef, $self->{globalStorageOptions};
};
if ($@) {
print STDERR "$@\n";
$self->lmLog( $@, 'error' );
return PE_APACHESESSIONERROR;
}
$self->{id} = $h{_session_id};
......
......@@ -45,7 +45,10 @@ sub getUser {
# @return Lemonldap::NG::Portal constant
sub formateFilter {
my $self = shift;
$self->{filter} = $self->{authFilter} || $self->{filter} || "(&(uid=" . $self->{user} . ")(objectClass=inetOrgPerson))";
$self->{filter} =
$self->{authFilter}
|| $self->{filter}
|| "(&(uid=" . $self->{user} . ")(objectClass=inetOrgPerson))";
PE_OK;
}
......@@ -63,7 +66,7 @@ sub search {
filter => $self->{filter},
);
if ( $mesg->code() != 0 ) {
print STDERR $mesg->error . "\n";
$self->lmLog( $mesg->error, 'error' );
return PE_LDAPERROR;
}
return PE_BADCREDENTIALS unless ( $self->{entry} = $mesg->entry(0) );
......
......@@ -39,7 +39,7 @@ sub new {
);
}
unless ($self) {
print STDERR "$@\n";
$portal->lmLog( $@, 'error' );
return 0;
}
bless $self, $class;
......@@ -49,7 +49,7 @@ sub new {
$h{capath} = $portal->{caPath} if ( $portal->{caPath} );
my $mesg = $self->start_tls(%h);
if ( $mesg->code ) {
print STDERR __PACKAGE__ . " StartTLS failed\n";
$portal->lmLog( 'StartTLS failed', 'error' );
return 0;
}
}
......@@ -69,7 +69,7 @@ sub bind {
my $self = shift;
my $mesg;
my ( $dn, %args ) = @_;
unless($dn) {
unless ($dn) {
$dn = $self->{portal}->{managerDn};
$args{password} = $self->{portal}->{managerPassword};
}
......
......@@ -99,7 +99,7 @@ sub error_fr {
"Échec de l'initialisation de Lasso:Login ou Lasso:Logout",
"Échec de la résolution de l'artefact Liberty Alliance",
"Échec de la défédération Liberty Alliance",
"La requête renvoyée par le fournisseur d'identité Liberty Alliance est vide",
"La requête renvoyée par le fournisseur d'identité Liberty Alliance est vide",
"Un des appels SOAP Liberty Alliance a échoué",
"Un des appels de déconnexion Liberty Alliance a échoué",
"Aucun artefact SAML trouvé, ou échec de l'auto-acceptation SSO",
......@@ -118,7 +118,7 @@ sub error_fr {
"Mot de passe trop récent",
"Mot de passe utilisé trop récemment",
" authentifications restantes, changez votre mot de passe !",
" secondes avant expiration de votre mot de passe, pensez &agrave; le changer !",
" secondes avant expiration de votre mot de passe, pensez &agrave; le changer !",
"Les mots de passe ne correspondent pas",
"Le mot de passe a &eacute;t&eacute; chang&eacute;",
"Vous avez un nouveau message",
......@@ -192,12 +192,12 @@ sub error_ro {
"Eşec al iniţializării Lasso:Login sau Lasso:Logout",
"Eşec al rezoluţiei artefact-ului Liberty Alliance",
"Eşec al defederaţiei Liberty Alliance",
"Cererea retrimisă de către furnizorul de identitate Liberty Alliance este goală",
"Cererea retrimisă de către furnizorul de identitate Liberty Alliance este goală",
"Unul dintre apelurile SOAP Liberty Alliance a eşuat",
"Unul dintre apelurile de deconectare Liberty Alliance a eşuat",
"Nici un artefact SAML găsit, sau eşec al auto-acceptării SSO",
"Iniţiere, construcţie sau cerere SSO în eşec",
"Imposibil de a înregistra identificatorul de conectare Liberty Alliance",
"Imposibil de a înregistra identificatorul de conectare Liberty Alliance",
"Un proces terminal Liberty Alliance a eşuat",
"Contul dvs. este blocat",
"Parola dvs. a expirat",
......@@ -205,13 +205,13 @@ sub error_ro {
'Eroare',
'Parola a fost de resetare şi acum trebuie să fie schimbat',
'Parola nu poate fi modificat',
'Vechea parolă trebuie să fi, de asemenea, furnizate atunci când stabilesc o nouă parolă',
'Vechea parolă trebuie să fi, de asemenea, furnizate atunci când stabilesc o nouă parolă',
'Calitate parola insuficiente',
'Parola prea scurt',
'Prea parolă nouă',
'Parola folosit prea recent',
' authentications rămase, schimbaţi-vă parola!',
' secunde înainte de expirarea parola dvs., asiguraţi-vă pentru a schimba!',
' secunde înainte de expirarea parola dvs., asiguraţi-vă pentru a schimba!',
'Parolele nu se potrivesc',
'Parola a fost schimbată',
'Ai un mesaj nou',
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment