Skip to content
GitLab
Unverified Commit 57fc3e3f authored by IKEDA Soji's avatar IKEDA Soji Committed by GitHub
Browse files

Merge branch 'sympa-6.2' into cleanup_report

parents 9f990130 63a5251b
Hide whitespace changes
Inline Side-by-side
cpanfile
View file @ 57fc3e3f
......@@ -5,8 +5,12 @@
# Notation suggested on https://metacpan.org/pod/Carton#PERL-VERSIONS
requires 'perl', '5.16.0';
# This module provides zip/unzip for archive and shared document download/upload
requires 'Archive::Zip', '>= 1.05';
# Used to zip/unzip for archive and shared document download/upload.
# Note: Some environments not providing 'Archive::Zip::Simple*' modules may
# use a memory-consuming module 'Archive::Zip' for the alternative.
requires 'Archive::Zip::SimpleUnzip', '>= 0.024';
requires 'Archive::Zip::SimpleZip', '>= 0.021';
#requires 'Archive::Zip', '>= 1.05';
# Required to run Sympa web interface
requires 'CGI', '>= 3.51';
......@@ -204,15 +208,16 @@ feature 'Crypt::Eksblowfish', 'Used to encrypt passwords with the Bcrypt hash al
};
feature 'x509-auth', 'Required to extract user certificates for SSL clients and S/MIME messages.' => sub {
requires 'Crypt::OpenSSL::X509', '>= 1.800.1';
# Note: email() for certificate on versions < 1.909 was broken.
requires 'Crypt::OpenSSL::X509', '>= 1.909';
};
feature 'smime', 'Required to sign, verify, encrypt and decrypt S/MIME messages.' => sub {
requires 'Convert::ASN1', '>= 0.14';
requires 'Crypt::SMIME', '>= 0.15';
# Required to extract user certificates for SSL clients and S/MIME messages.
# Note: On versions < 1.808, the value() method for extension was broken.
requires 'Crypt::OpenSSL::X509', '>= 1.808';
# Note: value() for extension on versions < 1.808 was broken.
# Note: email() for certificate on versions < 1.909 was broken.
requires 'Crypt::OpenSSL::X509', '>= 1.909';
};
feature 'csv', 'CSV database driver, required if you include list members, owners or moderators from CSV file.' => sub {
......
src/cgi/wwsympa.fcgi.in
View file @ 57fc3e3f
......@@ -37,7 +37,6 @@ use strict;
##use warnings;
use lib split(/:/, $ENV{SYMPALIB} || ''), '--modulesdir--';
 
use Archive::Zip qw();
use DateTime;
use DateTime::Format::Mail;
use Digest::MD5;
......@@ -50,7 +49,16 @@ use POSIX qw();
use Time::Local qw();
use URI;
use Data::Dumper; # tentative
BEGIN { eval 'use Crypt::OpenSSL::X509'; }
BEGIN {
# For some environments not providing Archive::Zip::Simple*, Archive::Zip
# may be used. The latter is discouraged because it is memory-consuming.
eval 'use Archive::Zip::SimpleUnzip qw()';
eval 'use Archive::Zip::SimpleZip qw()';
require Archive::Zip
unless $Archive::Zip::SimpleUnzip::VERSION
and $Archive::Zip::SimpleZip::VERSION;
}
 
use Sympa;
use Sympa::Archive;
......@@ -87,6 +95,7 @@ use Sympa::Ticket;
use Sympa::Tools::Data;
use Sympa::Tools::File;
use Sympa::Tools::Password;
use Sympa::Tools::SMIME;
use Sympa::Tools::Text;
use Sympa::Tracking;
use Sympa::User;
......@@ -1280,28 +1289,25 @@ while ($query = Sympa::WWW::FastCGI->new) {
 
## RSS does not require user authentication
unless ($rss) {
if ( $Crypt::OpenSSL::X509::VERSION
and $ENV{SSL_CLIENT_VERIFY}
and $ENV{SSL_CLIENT_VERIFY} eq 'SUCCESS'
if ('SUCCESS' eq ($ENV{SSL_CLIENT_VERIFY} // '')
and $in{'action'} ne 'sso_login') {
# Get rfc822Name in X.509v3 subjectAltName, otherwise
# emailAddress attribute in subject DN (the first one of either).
# Note: Earlier efforts getting attribute such as MAIL, Email in
# subject DN are no longer supported.
my $x509 = eval {
Crypt::OpenSSL::X509->new_from_string($ENV{SSL_CLIENT_CERT});
};
my $email = Sympa::Tools::Text::canonic_email($x509->email)
if $x509 and Sympa::Tools::Text::valid_email($x509->email);
my $cert =
Sympa::Tools::SMIME::parse_cert(text => $ENV{SSL_CLIENT_CERT})
// {};
my $email = ($cert->{emails} // [])->[0];
 
if ($email) {
$param->{'user'}{'email'} = $email;
$session->{'email'} = $email;
$param->{'auth_method'} = 'smime';
$session->{'auth'} = 'x509';
$param->{'ssl_client_s_dn'} = $x509->subject;
$param->{'ssl_client_v_end'} = $x509->notAfter;
$param->{'ssl_client_i_dn'} = $x509->issuer;
$param->{'ssl_client_s_dn'} = $cert->{subject};
$param->{'ssl_client_v_end'} = $cert->{notAfter};
$param->{'ssl_client_i_dn'} = $cert->{issuer};
# Only with Apache+mod_ssl or lighttpd+mod_openssl.
$param->{'ssl_cipher_usekeysize'} =
$ENV{SSL_CIPHER_USEKEYSIZE};
......@@ -12136,7 +12142,7 @@ sub do_d_unzip {
}
 
# Uploaded of the file.zip
my ($zip, $az);
my ($zip, $rv, $az);
my $fh = $query->upload('uploaded_file');
if (defined $fh) {
my $ioh = $fh->handle;
......@@ -12144,10 +12150,18 @@ sub do_d_unzip {
# CGI derives handles from IO::Handle and/or File::Temp which lack
# some of methods. That's why destructive bless-ing is here.
bless $ioh => 'IO::File';
$zip = Archive::Zip->new();
$az = $zip->readFromFileHandle($ioh);
if ($Archive::Zip::SimpleUnzip::VERSION) {
$zip = Archive::Zip::SimpleUnzip->new($ioh);
$rv = defined $zip;
$az = $Archive::Zip::SimpleUnzip::SimpleUnzipError;
} else {
$zip = Archive::Zip->new();
$az = $zip->readFromFileHandle($ioh);
$rv = (defined $az and $az == Archive::Zip::AZ_OK());
}
}
unless (defined $az and $az == Archive::Zip::AZ_OK()) {
unless ($rv) {
add_stash('user', 'cannot_unzip', {name => $zip_name});
wwslog('err', 'Unable to read the zip file: %s', $az);
web_db_log(
......@@ -12168,11 +12182,21 @@ sub do_d_unzip {
my $status = 1;
my %subpaths;
my @langs = Sympa::Language::implicated_langs($language->get_lang);
foreach my $member ($zip->members) {
next if $member->isEncrypted;
my @members;
if ($Archive::Zip::SimpleUnzip::VERSION) {
@members = map { $zip->member($_) } $zip->names;
} else {
@members = grep { !$_->isEncrypted } $zip->members;
}
foreach my $member (@members) {
my $path;
if ($Archive::Zip::SimpleUnzip::VERSION) {
$path = $member->name;
} else {
$path = $member->fileName;
}
my @subpaths = split m{/+},
Sympa::Tools::Text::guessed_to_utf8($member->fileName, @langs);
Sympa::Tools::Text::guessed_to_utf8($path, @langs);
next unless @subpaths;
my $name;
unless ($member->isDirectory) {
......@@ -12215,26 +12239,37 @@ sub do_d_unzip {
return undef;
}
 
$subpaths{$member->fileName} = [@subpaths];
$subpaths{$path} = [@subpaths];
}
foreach my $member ($zip->members) {
next if $member->isEncrypted;
my $subpaths = $subpaths{$member->fileName};
foreach my $member (@members) {
my $path;
if ($Archive::Zip::SimpleUnzip::VERSION) {
$path = $member->name;
} else {
$path = $member->fileName;
}
my $subpaths = $subpaths{$path};
next unless $subpaths and @$subpaths;
 
my ($content, $az);
my ($content, $rv, $az);
unless ($member->isDirectory) {
($content, $az) = $member->contents;
unless (defined $az and $az == Archive::Zip::AZ_OK()) {
if ($Archive::Zip::SimpleUnzip::VERSION) {
$content = $member->content;
$rv = defined $content;
$az = $Archive::Zip::SimpleUnzip::SimpleUnzipError;
} else {
($content, $az) = $member->contents;
$rv = (defined $az and $az == Archive::Zip::AZ_OK());
}
unless ($rv) {
wwslog('err',
'Unable to extract member %s of the zip file: %s',
$member->fileName, $az);
$path, $az);
web_db_log(
{ 'robot' => $robot,
'list' => $list->{'name'},
'action' => $param->{'action'},
'parameters' => $member->fileName,
'parameters' => $path,
'target_email' => "",
'msg_id' => '',
'status' => 'error',
......@@ -12256,13 +12291,13 @@ sub do_d_unzip {
)
) {
wwslog('err',
'Unable to create member %s of the zip file as %s: %s',
$member->fileName, join('/', @$subpaths));
'Unable to create member %s of the zip file as %s: %m',
$path, join('/', @$subpaths));
web_db_log(
{ 'robot' => $robot,
'list' => $list->{'name'},
'action' => $param->{'action'},
'parameters' => $member->fileName,
'parameters' => $path,
'target_email' => "",
'msg_id' => '',
'status' => 'error',
......@@ -15603,9 +15638,15 @@ sub do_arc_download {
return undef unless defined check_authz('do_arc', 'archive_web_access');
 
##zip file name:listname_archives.zip
my $zip_file_name = $in{'list'} . '_archives.zip';
my $zip_abs_file = $Conf::Conf{'tmpdir'} . '/' . $zip_file_name;
my $zip = Archive::Zip->new();
my $zip_file_name = sprintf '%s_archives.zip', $list->{'name'};
my $zip_abs_file = $Conf::Conf{'tmpdir'} . '/' . $zip_file_name;
my $zip;
if ($Archive::Zip::SimpleZip::VERSION) {
$zip = Archive::Zip::SimpleZip->new($zip_abs_file);
} else {
$zip = Archive::Zip->new;
}
my $number_of_members = 0;
 
#Search for months to put in zip
unless (defined($in{'directories'})) {
......@@ -15630,6 +15671,8 @@ sub do_arc_download {
 
# For each selected month
foreach my $arc (split /\0/, $in{'directories'}) {
my $arc_dirname = sprintf '%s_%s', $list->{'name'}, $arc;
# Check arc directory
unless ($archive->select_archive($arc)) {
add_stash('user', 'month_not_found', {month => $arc});
......@@ -15649,23 +15692,33 @@ sub do_arc_download {
next;
}
 
$zip->addDirectory($archive->{directory}, $in{'list'} . '_' . $arc);
if ($Archive::Zip::SimpleZip::VERSION) {
$zip->add($archive->{directory}, Name => $arc_dirname);
} else {
$zip->addDirectory($archive->{directory}, $arc_dirname);
}
 
while (1) {
my ($message, $handle) = $archive->next;
last unless $handle;
next unless $message;
 
unless (
$zip->addString(
$message->as_string,
$in{'list'} . '_' . $arc . '/' . $handle->basename
)
) {
my ($rv, $az);
if ($Archive::Zip::SimpleZip::VERSION) {
$rv = $zip->addString($message->as_string,
Name => sprintf('%s/%s', $arc_dirname, $handle->basename)
);
$az = $Archive::Zip::SimpleZip::SimpleZipError;
} else {
$rv = $zip->addString($message->as_string,
sprintf('%s/%s', $arc_dirname, $handle->basename));
$az = 'unknown error';
}
unless ($rv) {
wwslog('info', 'Failed to add %s file in %s to archive: %s',
$handle->basename, $archive, $az);
add_stash('intern', 'add_file_zip',
{file => $arc . '/' . $handle->basename});
wwslog('info', 'Failed to add %s file in %s to archive',
$handle->basename, $archive);
web_db_log(
{ 'robot' => $robot,
'list' => $list->{'name'},
......@@ -15680,16 +15733,15 @@ sub do_arc_download {
);
return undef;
}
}
 
## create and fill a new folder in zip
#$zip->addTree ($abs_dir, $in{'list'}.'_'.$dir);
$number_of_members++;
}
}
 
## check if zip isn't empty
if ($zip->numberOfMembers() == 0) {
# Check if zip isn't empty.
unless ($number_of_members) {
wwslog('info', 'Empty archives');
add_stash('user', 'empty_archives');
wwslog('info', 'Empty directories');
web_db_log(
{ 'robot' => $robot,
'list' => $list->{'name'},
......@@ -15704,10 +15756,20 @@ sub do_arc_download {
);
return undef;
}
##writing zip file
unless ($zip->writeToFileNamed($zip_abs_file) == Archive::Zip::AZ_OK()) {
# Writing zip file.
my ($rv, $az);
if ($Archive::Zip::SimpleZip::VERSION) {
$rv = $zip->close;
$az = $Archive::Zip::SimpleZip::SimpleZipError;
} else {
$az = $zip->writeToFileNamed($zip_abs_file);
$rv = (defined $az and $az == Archive::Zip::AZ_OK());
}
unless ($rv) {
wwslog('info', 'Error while writing ZIP File %s: %s',
$zip_abs_file, $az);
add_stash('intern', 'write_file_zip', {zipfile => $zip_abs_file});
wwslog('info', 'Error while writing ZIP File %s', $zip_file_name);
web_db_log(
{ 'robot' => $robot,
'list' => $list->{'name'},
......@@ -15723,15 +15785,16 @@ sub do_arc_download {
return undef;
}
 
##Sending Zip to browser
# Sending zip file to browser.
$param->{'bypass'} = 'extreme';
printf(
"Content-Type: application/zip;\nContent-disposition: attachment; filename=\"%s\";\n\n",
$zip_file_name);
##MIME Header
unless (open(ZIP, $zip_abs_file)) {
print "Content-Type: application/zip\n";
printf "Content-Disposition: attachment; filename=\"%s\"\n\n",
$zip_file_name;
my $ifh;
unless (open $ifh, '<', $zip_abs_file) {
wwslog('info', 'Error while reading ZIP File %s: %m', $zip_abs_file);
add_stash('intern', 'cannot_open_file', {path => $zip_abs_file});
wwslog('info', 'Error while reading ZIP File %s', $zip_abs_file);
web_db_log(
{ 'robot' => $robot,
'list' => $list->{'name'},
......@@ -15746,13 +15809,13 @@ sub do_arc_download {
);
return undef;
}
print <ZIP>;
close ZIP;
while (<$ifh>) {print}
close $ifh;
 
## remove zip file from server disk
# Remove zip file from server disk.
unless (unlink $zip_abs_file) {
wwslog('info', 'Error while unlinking File %s: %m', $zip_abs_file);
add_stash('intern', 'cannot_erase_file', {path => $zip_abs_file});
wwslog('info', 'Error while unlinking File %s', $zip_abs_file);
web_db_log(
{ 'robot' => $robot,
'list' => $list->{'name'},
......
src/lib/Sympa/Tools/SMIME.pm
View file @ 57fc3e3f
......@@ -31,47 +31,13 @@ use strict;
use warnings;
use English qw(-no_match_vars);
BEGIN { eval 'use Crypt::OpenSSL::X509'; }
use Conf;
use Sympa::Log;
use Sympa::Tools::Text;
my $log = Sympa::Log->instance;
=over
=item find_keys ( $that, $operation )
Find the appropriate S/MIME keys/certs for $operation of $that.
$operation can be:
=over
=item 'sign'
return the preferred signing key/cert
=item 'decrypt'
return a list of possible decryption keys/certs
=item 'encrypt'
return the preferred encryption key/cert
=back
Returnss C<($certs, $keys)>.
For 'sign' and 'encrypt', these are strings containing the absolute filename.
For 'decrypt', these are arrayrefs containing absolute filenames.
=back
=cut
# Old name: tools::smime_find_keys()
sub find_keys {
$log->syslog('debug2', '(%s, %s)', @_);
my $that = shift || '*';
my $operation = shift;
......@@ -102,8 +68,6 @@ sub find_keys {
my $k = $c;
$k =~ s/\/cert\.pem/\/private_key/;
unless ($keys{$k}) {
$log->syslog('debug3', '%s exists, but matching %s doesn\'t',
$c, $k);
delete $certs{$c};
}
}
......@@ -112,8 +76,6 @@ sub find_keys {
my $c = $k;
$c =~ s/\/private_key/\/cert\.pem/;
unless ($certs{$c}) {
$log->syslog('debug3', '%s exists, but matching %s doesn\'t',
$k, $c);
delete $keys{$k};
}
}
......@@ -130,34 +92,15 @@ sub find_keys {
$certs = "$dir/cert.pem";
$keys = "$dir/private_key";
} else {
$log->syslog('debug3', '%s: no certs/keys found for %s',
$that, $operation);
return undef;
}
}
$log->syslog('debug3', '%s: certs/keys for %s found', $that, $operation);
return ($certs, $keys);
}
BEGIN {
eval 'use Crypt::OpenSSL::X509';
eval 'use Convert::ASN1 qw()';
}
# IN: hashref:
# file => filename
# text => PEM-encoded cert
# OUT: hashref
# email => email address from cert
# subject => distinguished name
# purpose => hashref
# enc => true if v3 purpose is encryption
# sign => true if v3 purpose is signing
#
# Old name: tools::smime_parse_cert()
sub parse_cert {
$log->syslog('debug3', '(%s => %s)', @_);
my %arg = @_;
return undef unless $Crypt::OpenSSL::X509::VERSION;
......@@ -169,27 +112,23 @@ sub parse_cert {
} elsif ($arg{'file'}) {
$x509 = eval { Crypt::OpenSSL::X509->new_from_file($arg{'file'}) };
} else {
$log->syslog('err', 'Neither "text" nor "file" given');
return undef;
die 'bug in logic. Ask developer';
}
unless ($x509) {
$log->syslog('err', 'Cannot parse certificate');
return undef;
}
my %res;
$res{subject} = join '',
map { '/' . $_->as_string } @{$x509->subject_name->entries};
# Get email(s).
# The subjectAltName extension is used. The email() method that gives
# single address may be used for workaround on malformed certificates.
my @emails = _get_subjectAltName($x509, 1); # rfc822Name [1]
unless (@emails) {
@emails = ($x509->email) if $x509->email;
}
$res{email} =
{map { (Sympa::Tools::Text::canonic_email($_) => 1) } @emails};
$res{subject} = $x509->subject;
$res{notAfter} = $x509->notAfter;
$res{issuer} = $x509->issuer;
my @emails =
map { Sympa::Tools::Text::canonic_email($_) }
grep { Sympa::Tools::Text::valid_email($_) }
split / +/, ($x509->email // '');
$res{emails} = [@emails];
$res{email} = {map { ($_ => 1) } @emails};
# Check key usage roughy.
my %purposes = $x509->extensions_by_name->{keyUsage}->hash_bit_string;
......@@ -198,81 +137,106 @@ sub parse_cert {
return \%res;
}
sub _get_subjectAltName {
my $x509 = shift;
my $context_num = shift;
my $extensions = $x509->extensions_by_name;
return
unless $extensions
and $extensions->{subjectAltName}
and $extensions->{subjectAltName}->value =~ /\A#([0-9A-F]+)\z/;
my $bin = pack 'H*', $1;
my ($tag, $tnum, $len);
($tag, $tnum, $bin, $len) = _parse_asn1_single_value($bin);
return
unless defined $tag
and ($tag & ~Convert::ASN1::ASN_CONSTRUCTOR()) ==
Convert::ASN1::ASN_SEQUENCE();
my @ret;
while (length $bin) {
my $val;
($tag, $tnum, $val, $len) = _parse_asn1_single_value($bin);
last unless defined $tag;
$bin = substr $bin, $len;
next if $tag == 0 and length $val == 0;
push @ret, $val
if ($tag & 0xC0) == Convert::ASN1::ASN_CONTEXT()
and $tnum == $context_num;
}
return @ret;
}
1;
__END__
sub _parse_asn1_single_value {
my $bin = shift;
=encoding utf-8
my ($tb, $tag, $tnum) =
Convert::ASN1::asn_decode_tag2(substr $bin, 0, 10);
return unless defined $tb;
my ($lb, $len) = Convert::ASN1::asn_decode_length(substr $bin, $tb, 10);
return unless $tb + $lb + $len <= length $bin;
=head1 NAME
return ($tag, $tnum, substr($bin, $tb + $lb, $len), $tb + $lb + $len);
}
Sympa::Tools::SMIME - Tools for S/MIME messages and X.509 certificates
# NO LONGER USED
# However, this function may be useful because it can extract messages openssl
# can not (e.g. signature part not encoded by BASE64).
sub smime_extract_certs {
my ($mime, $outfile) = @_;
$log->syslog('debug2', '(%s)', $mime->mime_type);
if ($mime->mime_type =~ /application\/(x-)?pkcs7-/) {
my $pipeout;
unless (
open $pipeout,
'|-', $Conf::Conf{openssl}, 'pkcs7', '-print_certs',
'-inform' => 'der',
'-out' => $outfile
) {
$log->syslog('err', 'Unable to run openssl pkcs7: %m');
return 0;
}
print $pipeout $mime->bodyhandle->as_string;
close $pipeout;
my $status = $CHILD_ERROR >> 8;
if ($status) {
$log->syslog('err', 'Openssl pkcs7 returned an error: %s',
$status);
return 0;
}
return 1;
}
}
=head1 DESCRIPTION
1;
=head2 Functions
=over
=item find_keys ( $that, $operation )
Find the appropriate S/MIME keys/certs for $operation of $that.
$operation can be:
=over
=item 'sign'
return the preferred signing key/cert
=item 'decrypt'
return a list of possible decryption keys/certs
=item 'encrypt'
return the preferred encryption key/cert
=back
Returnss C<($certs, $keys)>.
For 'sign' and 'encrypt', these are strings containing the absolute filename.
For 'decrypt', these are arrayrefs containing absolute filenames.
=item parse_cert ( C<text>|C<file> =E<gt> $content )
Parses X.509 certificate.
</