Tools.pm

package IdPAccountManager::Tools;

use Template;

# load Template::Stash to make method tables visible
use Template::Stash;

use Digest::SHA;
use Encode;

my %log_levels = ('debug' => 0, 'info' => 1, 'trace' => 1, 'notice' => 2, 'error' => 3);

INIT {
    ## a TT2 virtual method to get a variable type
    $Template::Stash::LIST_OPS->{isa} = sub {
        my $list = shift;
        my $type = shift;
        
        return 1 if ($type eq 'ARRAY');
        return 0;
    };
    $Template::Stash::SCALAR_OPS->{isa} = sub {
        my $list = shift;
        my $type = shift;

        return 1 if ($type eq 'SCALAR');
        return 0;
    };
}

# get SHA256 hash for a string
sub sha256_hash {
    my $s = shift;
    
    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)) {
        IdPAccountManager::Tools::do_log('error', "Failed to update valid-accounts.php: %s", $tt2->error());
        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";
        }
    }
}

sub do_log {
    my $level = shift;
    my $message = shift;

    unless ($log_levels{$level} < $log_levels{$Conf::global{'log_level'}}) {

        ## Determine calling function and parameters
        ## If in 'err' level, build a stack trace
        my $caller_string;
        if ($level eq 'error'){
            my $go_back = 1;
            my @calls;
            while (my @call = caller($go_back)) {
                unshift @calls, $call[3].'#'.$call[2];
                $go_back++;
            }
        
            $caller_string = join(' > ',@calls);
        }else {
            my @call = caller(1);
                
            $caller_string = $call[3].'()';
        }

        $level = uc($level);
        my $ip = $ENV{'REMOTE_HOST'}.'/'.$ENV{'REMOTE_ADDR'} || 'NOIP';
        my $date = POSIX::strftime ("%Y:%m:%d %H:%M:%S", localtime(time));
        my $user = lc($ENV{'mail'}) || 'NOEMAIL';
        open LOG, ">>".$Conf::global{'log_file'}; printf LOG "$date - ($level) - $ip - $user - $caller_string $message\n", @_; close LOG;       
    }
    return 1;
}

## 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 %in = @_;
  my $tt2_file = $in{'template'};
  my $mail_data = $in{'data'};

  $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) {
        &do_log('info',"no_mail_outside option set; notification for %s rerouted to admins ; ", $notice_email);
        $notice_email = $Conf::global{'admin_email'};
    }
  }

  &do_log('trace', '(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)) {
      &do_log('error', "Error TT2 : %s", $tt2->error());
  }
  close SENDMAIL;
}

sub qencode {
    my $string = shift;
    # 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 = shift||'';
	
	return Encode::encode('utf8', $string);
}

## Escape characters that may interfer in an XML document
sub escape_xml {
    my $s = shift;

    $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 = shift;
	
	$string =~ s/\'/\\\'/g;
	
	return $string;
}

## returns an integer (0 or 1), given an input string ('true' or 'false')
sub boolean2integer {
	my $boolean = shift;
	
	if ($boolean eq 'true') {
		return 1;
	}elsif ($boolean eq 'false') {
		return 0;
	}
		
	return undef;	
}



1; # Magic true value required at end of module
__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<do_log ($level, $message)>

Write $message to the log file. $level sets the log level (debug, info, trace, notice, error).

=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) 2015 RENATER on behalf of the GÉANT project