package IdPAccountManager::Tools;
## Copyright (c) GEANT
## This software was developed by RENATER. The research leading to these results has received funding
## from the European Community¹s Seventh Framework Programme (FP7/2007-2013) under grant agreement nº 238875 (GÉANT).
use Conf;
use Template;
# load Template::Stash to make method tables visible
use Template::Stash;
use Digest::SHA;
use Encode;
INIT {
## a TT2 virtual method to get a variable type
$Template::Stash::LIST_OPS->{isa} = sub {
my ($list, $type) = @_;
return 1 if ($type eq 'ARRAY');
return 0;
};
$Template::Stash::SCALAR_OPS->{isa} = sub {
my ($list, $type) = @_;
return 1 if ($type eq 'SCALAR');
return 0;
};
}
# get SHA256 hash for a string
sub sha256_hash {
my ($s) = @_;
return Digest::SHA::sha256_base64($s);
}
# This function generates a random password
sub generate_password {
my $length_of_randomstring = 10; # the length of
# the random string to generate
# plusieurs tirages :
# 1-tirage des caractères obligatoires : les mettre dans un tableau
my @uppers = ('A' .. 'N', 'P' .. 'Z');
my @lowers = ('a' .. 'k', 'm' .. 'z');
my @punctuation = (':', '!', '?', '&', '$', '=', '-', '#');
my @numerics = ('0' .. '9');
my @rndtab;
push(@rndtab, $uppers[ rand @uppers ]);
push(@rndtab, $lowers[ rand @lowers ]);
push(@rndtab, $punctuation[ rand @punctuation ]);
## Pas de caractères 8bit pour l'antispam
push(@rndtab, $numerics[ rand @numerics ]);
# 2-tirage des caractères optionnels : les ajouter au tableau
my @chars = (
'a' .. 'k', 'm' .. 'z', 'A' .. 'N', 'P' .. 'Z',
'0' .. '9', '_', '%', ';',
':', '!', '?', '&',
'$', '*', '(', ')',
'{', '}', '[', ']',
'.', '=', '-', '#'
);
foreach (6 .. $length_of_randomstring) {
# rand @chars will generate a random
# number between 0 and scalar @chars
push(@rndtab, $chars[ rand @chars ]);
}
# 3-ordonnancement de ceux-ci : les retirer aléatoirement du tableau en les concaténant dans une chaîne
my $rndstring = '';
my $cpt = 1;
while ($cpt <= $length_of_randomstring) {
my $indice = rand @rndtab;
$rndstring .= $rndtab[$indice];
splice(@rndtab, $indice, 1);
$cpt += 1;
}
return $rndstring;
}
## Updates simpleSamlPhp authsources.php configuration file
sub update_ssp_authsources {
my $tt2 = Template->new(
{
'INCLUDE_PATH' => $Conf::global{'root_manager_dir'} . ':'
. $Conf::global{'root_manager_dir'}
. '/templates/accountProfiles'
}
);
my %args = (
'accounts' => IdPAccountManager::TestAccount::list_test_accounts(),
'conf' => \%Conf::global
);
#chdir $Conf::global{'root_manager_dir'};
my $template_file = 'templates/accountProfiles/valid-accounts.php.tt2';
my $output_file = 'conf/valid-accounts.php';
#printf "Trace : in=%s, out=%s\n", $template_file, $output_file;
unless ($tt2->process($template_file, \%args, $output_file)) {
return undef;
}
}
## Dump a variable's content
sub dump_var {
my ($var, $level, $fd) = @_;
if (ref($var)) {
if (ref($var) eq 'ARRAY') {
foreach my $index (0 .. $#{$var}) {
print $fd "\t" x $level . $index . "\n";
dump_var($var->[$index], $level + 1, $fd);
}
} elsif (ref($var) eq 'HASH') {
foreach my $key (sort keys %{$var}) {
print $fd "\t" x $level . '_' . $key . '_' . "\n";
dump_var($var->{$key}, $level + 1, $fd);
}
} else {
if (defined $var) {
print $fd "\t" x $level . "'$var'" . "\n";
} else {
print $fd "\t" x $level . "UNDEF\n";
}
}
} else {
if (defined $var) {
print $fd "\t" x $level . "'$var'" . "\n";
} else {
print $fd "\t" x $level . "UNDEF\n";
}
}
}
## Send a mail notice
## Default is to send email to the manager admins, unless other recipients are specified
## mail_notice(IN)
## IN is a HASH with expected entries :
## template : mail template file
## data : data used by the TT2 parser
sub mail_notice {
my (%args) = @_;
my $tt2_file = $args{'template'};
my $mail_data = $args{'data'};
my $logger = $args{'logger'};
$mail_data->{'conf'} ||= \%Conf::global;
my $notice_email = $in{'to'} || $Conf::global{'admin_email'};
$mail_data->{'to'} = $notice_email;
## Protection to prevent notifications during test dev phases
## Notify only admin_email or dev_sp_contact addresses
if ($Conf::global{'dev_no_mail_outside'}) {
my %rcpt = map { $_ => 1 } split(/,/, $notice_email);
my %authorized_rcpt = map { $_ => 1 } split(
/,/,
join(',',
$Conf::global{'admin_email'},
$Conf::global{'dev_sp_contact'})
);
my $change_rcpt = 0;
foreach my $email (keys %rcpt) {
unless ($authorized_rcpt{$email}) {
$change_rcpt = 1;
last;
}
}
if ($change_rcpt) {
$logger->log(
level => LOG_INFO,
message => sprintf(
"no_mail_outside option set; notification for %s rerouted to admins ; ",
$notice_email
)
);
$notice_email = $Conf::global{'admin_email'};
}
}
$logger->log(
level => LOG_TRACE,
message => sprintf('(template=%s, to=%s)', $in{'template'}, $mail_data->{'to'})
);
open SENDMAIL,
"|/usr/sbin/sendmail -f "
. $Conf::global{'notice_from'}
. " $notice_email";
my $tt2 = Template->new(FILTERS => { qencode => [ \qencode, 0 ] });
unless ($tt2->process($tt2_file, $mail_data, \*SENDMAIL)) {
$logger->log(
level => LOG_ERROR,
message => sprintf("Error TT2 : %s", $tt2->error())
);
}
close SENDMAIL;
}
sub qencode {
my ($string) = @_;
# We are not able to determine the name of header field, so assume
# longest (maybe) one.
return MIME::EncWords::encode_mimewords(
Encode::decode('utf8', $string),
Encoding => 'A',
Charset => 'utf8',
Field => "subject"
);
}
## usefull to pass parameters to TT2
sub encode_utf8 ($) {
my ($string) = @_;
$string = '' unless $string;
return Encode::encode('utf8', $string);
}
## Escape characters that may interfer in an XML document
sub escape_xml {
my ($s) = @_;
$s =~ s/\&/&\;/gm;
$s =~ s/\"/"\;/gm;
$s =~ s/\</<\;/gm;
$s =~ s/\>/>\;/gm;
$s =~ s/\'/'/gm;
return $s;
}
## usefull to pass parameters to TT2
sub escape_quotes {
my ($string) = @_;
$string =~ s/\'/\\\'/g;
return $string;
}
## returns an integer (0 or 1), given an input string ('true' or 'false')
sub boolean2integer {
my ($boolean) = @_;
if ($boolean eq 'true') {
return 1;
} elsif ($boolean eq 'false') {
return 0;
}
return undef;
}
1;
__END__
=head1 NAME
IdPAccountManager::Tools - Set of subroutines usefull for the Test Account manager
=head1 DESCRIPTION
The Test Account manager instanciates test accounts associated to a SAML Identity Provider.
This module gathers a set of usefull subroutines.
=head1 SUBROUTINES/METHODS
=over 8
=item C<dump_var ($var, $level, $fd)>
Dumps a complex perl data structure. $var is a reference to the variable to dump. $level should be set to 0 (subroutine called recursively). $fd is the file descriptor for the output (default is STDOUT).
=item C<encode_utf8 ($string)>
Return a UTF8 encoded version of $string.
=item C<escape_xml ($string)>
Escape XML chars in $string.
=item C<generate_password>
Returns a random password following some security guidelines.
=item C<mail_notice (ARGS)>
Send a mail notice.
Supported arguments include:
=over 12
=item C<template>
TT2 mail template to parse.
=item C<to>
Destination email address.
=item C<data>
A hashref with parameters used to parse the mail template.
=back
=item C<qencode ($string)>
Retunrs a Q-encoded version of $string.
=item C<sha256_hash ($string)>
Returns a SHA256 hash for $string.
=item C<update_ssp_authsources>
Update simpleSAMLphp authsources.php configuration file with the currently valid test accounts.
=back
=head1 AUTHOR
Olivier Salaün (olivier.salaun@renater.fr)
=head1 LICENSE
Copyright (c) GEANT
This software was developed by RENATER. The research leading to these results has received funding
from the European Community¹s Seventh Framework Programme (FP7/2007-2013) under grant agreement nº 238875 (GÉANT).