← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:11 2021

Filename/usr/local/libexec/sympa/Sympa/Tools/SMIME.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSympa::Tools::SMIME::::BEGIN@139Sympa::Tools::SMIME::BEGIN@139
0000s0sSympa::Tools::SMIME::::BEGIN@27Sympa::Tools::SMIME::BEGIN@27
0000s0sSympa::Tools::SMIME::::BEGIN@28Sympa::Tools::SMIME::BEGIN@28
0000s0sSympa::Tools::SMIME::::BEGIN@29Sympa::Tools::SMIME::BEGIN@29
0000s0sSympa::Tools::SMIME::::BEGIN@31Sympa::Tools::SMIME::BEGIN@31
0000s0sSympa::Tools::SMIME::::BEGIN@32Sympa::Tools::SMIME::BEGIN@32
0000s0sSympa::Tools::SMIME::::__ANON__Sympa::Tools::SMIME::__ANON__ (xsub)
0000s0sSympa::Tools::SMIME::::find_keysSympa::Tools::SMIME::find_keys
0000s0sSympa::Tools::SMIME::::parse_certSympa::Tools::SMIME::parse_cert
0000s0sSympa::Tools::SMIME::::smime_extract_certsSympa::Tools::SMIME::smime_extract_certs
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# -*- indent-tabs-mode: nil; -*-
2# vim:ft=perl:et:sw=4
3# $Id$
4
5# Sympa - SYsteme de Multi-Postage Automatique
6#
7# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
8# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
9# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
10# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
11#
12# This program is free software; you can redistribute it and/or modify
13# it under the terms of the GNU General Public License as published by
14# the Free Software Foundation; either version 2 of the License, or
15# (at your option) any later version.
16#
17# This program is distributed in the hope that it will be useful,
18# but WITHOUT ANY WARRANTY; without even the implied warranty of
19# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20# GNU General Public License for more details.
21#
22# You should have received a copy of the GNU General Public License
23# along with this program. If not, see <http://www.gnu.org/licenses/>.
24
25package Sympa::Tools::SMIME;
26
27use strict;
28use warnings;
29use English qw(-no_match_vars);
30
31use Conf;
32use Sympa::Log;
33
34my $log = Sympa::Log->instance;
35
36=over
37
38=item find_keys ( $that, $operation )
39
40Find the appropriate S/MIME keys/certs for $operation of $that.
41
42$operation can be:
43
44=over
45
46=item 'sign'
47
48return the preferred signing key/cert
49
50=item 'decrypt'
51
52return a list of possible decryption keys/certs
53
54=item 'encrypt'
55
56return the preferred encryption key/cert
57
58=back
59
60Returnss C<($certs, $keys)>.
61For 'sign' and 'encrypt', these are strings containing the absolute filename.
62For 'decrypt', these are arrayrefs containing absolute filenames.
63
64=back
65
66=cut
67
68# Old name: tools::smime_find_keys()
69sub find_keys {
70 $log->syslog('debug2', '(%s, %s)', @_);
71 my $that = shift || '*';
72 my $operation = shift;
73
74 my $dir;
75 if (ref $that eq 'Sympa::List') {
76 $dir = $that->{'dir'};
77 } else {
78 $dir = $Conf::Conf{'home'} . '/sympa'; #FIXME
79 }
80
81 my (%certs, %keys);
82 my $ext = ($operation eq 'sign' ? 'sign' : 'enc');
83
84 unless (opendir(D, $dir)) {
85 return undef;
86 }
87
88 while (my $fn = readdir(D)) {
89 if ($fn =~ /^cert\.pem/) {
90 $certs{"$dir/$fn"} = 1;
91 } elsif ($fn =~ /^private_key/) {
92 $keys{"$dir/$fn"} = 1;
93 }
94 }
95 closedir(D);
96
97 foreach my $c (keys %certs) {
98 my $k = $c;
99 $k =~ s/\/cert\.pem/\/private_key/;
100 unless ($keys{$k}) {
101 $log->syslog('debug3', '%s exists, but matching %s doesn\'t',
102 $c, $k);
103 delete $certs{$c};
104 }
105 }
106
107 foreach my $k (keys %keys) {
108 my $c = $k;
109 $c =~ s/\/private_key/\/cert\.pem/;
110 unless ($certs{$c}) {
111 $log->syslog('debug3', '%s exists, but matching %s doesn\'t',
112 $k, $c);
113 delete $keys{$k};
114 }
115 }
116
117 my ($certs, $keys);
118 if ($operation eq 'decrypt') {
119 $certs = [sort keys %certs];
120 $keys = [sort keys %keys];
121 } else {
122 if ($certs{"$dir/cert.pem.$ext"}) {
123 $certs = "$dir/cert.pem.$ext";
124 $keys = "$dir/private_key.$ext";
125 } elsif ($certs{"$dir/cert.pem"}) {
126 $certs = "$dir/cert.pem";
127 $keys = "$dir/private_key";
128 } else {
129 $log->syslog('debug3', '%s: no certs/keys found for %s',
130 $that, $operation);
131 return undef;
132 }
133 }
134
135 $log->syslog('debug3', '%s: certs/keys for %s found', $that, $operation);
136 return ($certs, $keys);
137}
138
139BEGIN { eval 'use Crypt::OpenSSL::X509'; }
# spent 0s executing statements in string eval
140
141# IN: hashref:
142# file => filename
143# text => PEM-encoded cert
144# OUT: hashref
145# email => email address from cert
146# subject => distinguished name
147# purpose => hashref
148# enc => true if v3 purpose is encryption
149# sign => true if v3 purpose is signing
150#
151# Old name: tools::smime_parse_cert()
152sub parse_cert {
153 $log->syslog('debug3', '(%s => %s)', @_);
154 my %arg = @_;
155
156 ## Load certificate
157 my $x509;
158 if ($arg{'text'}) {
159 $x509 = eval { Crypt::OpenSSL::X509->new_from_string($arg{'text'}) };
160 } elsif ($arg{'file'}) {
161 $x509 = eval { Crypt::OpenSSL::X509->new_from_file($arg{'file'}) };
162 } else {
163 $log->syslog('err', 'Neither "text" nor "file" given');
164 return undef;
165 }
166 unless ($x509) {
167 $log->syslog('err', 'Cannot parse certificate');
168 return undef;
169 }
170
171 my %res;
172 $res{subject} = join '',
173 map { '/' . $_->as_string } @{$x509->subject_name->entries};
174 my $extensions = $x509->extensions_by_name();
175 my %emails;
176 foreach my $extension_name (keys %$extensions) {
177 if ($extension_name eq 'subjectAltName') {
178 my $extension_value = $extensions->{$extension_name}->value();
179 my @addresses = split '\.{2,}', $extension_value;
180 shift @addresses;
181 foreach my $address (@addresses) {
182 $emails{$address} = 1;
183 }
184 }
185 }
186 if (%emails) {
187 foreach my $email (keys %emails) {
188 $res{email}{lc($email)} = 1;
189 }
190 } elsif ($x509->email) {
191 $res{email}{lc($x509->email)} = 1;
192 }
193 # Check key usage roughy.
194 my %purposes = $x509->extensions_by_name->{keyUsage}->hash_bit_string;
195 $res{purpose}->{sign} = $purposes{'Digital Signature'} ? 1 : '';
196 $res{purpose}->{enc} = $purposes{'Key Encipherment'} ? 1 : '';
197 return \%res;
198}
199
200# NO LONGER USED
201# However, this function may be useful because it can extract messages openssl
202# can not (e.g. signature part not encoded by BASE64).
203sub smime_extract_certs {
204 my ($mime, $outfile) = @_;
205 $log->syslog('debug2', '(%s)', $mime->mime_type);
206
207 if ($mime->mime_type =~ /application\/(x-)?pkcs7-/) {
208 my $pipeout;
209 unless (
210 open $pipeout,
211 '|-', $Conf::Conf{openssl}, 'pkcs7', '-print_certs',
212 '-inform' => 'der',
213 '-out' => $outfile
214 ) {
215 $log->syslog('err', 'Unable to run openssl pkcs7: %m');
216 return 0;
217 }
218 print $pipeout $mime->bodyhandle->as_string;
219 close $pipeout;
220 my $status = $CHILD_ERROR >> 8;
221 if ($status) {
222 $log->syslog('err', 'Openssl pkcs7 returned an error: %s',
223 $status);
224 return 0;
225 }
226 return 1;
227 }
228}
229
2301;