Tools.pm

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 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 ($root_manager_dir, $conf) = @_;

    my $tt2 = Template->new({
        'INCLUDE_PATH' => $root_manager_dir . ':' .
                          $root_manager_dir . '/templates/accountProfiles'
    });
    my %args = (
        'accounts' => IdPAccountManager::TestAccount::list_test_accounts(),
        'conf'     => $conf,
    );

    #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'} ||= $args{'conf'};

    my $notice_email = $args{'to'} || $args{'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 ($args{'dev_no_mail_outside'}) {
        my %rcpt = map { $_ => 1 } split(/,/, $notice_email);
        my %authorized_rcpt = map { $_ => 1 } split(
            /,/,
            join(',',
                $args{'admin_email'},
                $args{'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 = $args{'admin_email'};
        }
    }

    $logger->log(
        level   => LOG_TRACE,
        message => sprintf('(template=%s, to=%s)', $in{'template'}, $mail_data->{'to'})
    );

    open SENDMAIL,
        "|/usr/sbin/sendmail -f "
      . $args{'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/\&/&amp\;/gm;
    $s =~ s/\"/&quot\;/gm;
    $s =~ s/\</&lt\;/gm;
    $s =~ s/\>/&gt\;/gm;
    $s =~ s/\'/&#039;/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).