Filename | /usr/local/libexec/sympa/Sympa/Tools/SMIME.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN@139 | Sympa::Tools::SMIME::
0 | 0 | 0 | 0s | 0s | BEGIN@27 | Sympa::Tools::SMIME::
0 | 0 | 0 | 0s | 0s | BEGIN@28 | Sympa::Tools::SMIME::
0 | 0 | 0 | 0s | 0s | BEGIN@29 | Sympa::Tools::SMIME::
0 | 0 | 0 | 0s | 0s | BEGIN@31 | Sympa::Tools::SMIME::
0 | 0 | 0 | 0s | 0s | BEGIN@32 | Sympa::Tools::SMIME::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Sympa::Tools::SMIME::
0 | 0 | 0 | 0s | 0s | find_keys | Sympa::Tools::SMIME::
0 | 0 | 0 | 0s | 0s | parse_cert | Sympa::Tools::SMIME::
0 | 0 | 0 | 0s | 0s | smime_extract_certs | Sympa::Tools::SMIME::
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 | |||||
25 | package Sympa::Tools::SMIME; | ||||
26 | |||||
27 | use strict; | ||||
28 | use warnings; | ||||
29 | use English qw(-no_match_vars); | ||||
30 | |||||
31 | use Conf; | ||||
32 | use Sympa::Log; | ||||
33 | |||||
34 | my $log = Sympa::Log->instance; | ||||
35 | |||||
36 | =over | ||||
37 | |||||
38 | =item find_keys ( $that, $operation ) | ||||
39 | |||||
40 | Find the appropriate S/MIME keys/certs for $operation of $that. | ||||
41 | |||||
42 | $operation can be: | ||||
43 | |||||
44 | =over | ||||
45 | |||||
46 | =item 'sign' | ||||
47 | |||||
48 | return the preferred signing key/cert | ||||
49 | |||||
50 | =item 'decrypt' | ||||
51 | |||||
52 | return a list of possible decryption keys/certs | ||||
53 | |||||
54 | =item 'encrypt' | ||||
55 | |||||
56 | return the preferred encryption key/cert | ||||
57 | |||||
58 | =back | ||||
59 | |||||
60 | Returnss C<($certs, $keys)>. | ||||
61 | For 'sign' and 'encrypt', these are strings containing the absolute filename. | ||||
62 | For 'decrypt', these are arrayrefs containing absolute filenames. | ||||
63 | |||||
64 | =back | ||||
65 | |||||
66 | =cut | ||||
67 | |||||
68 | # Old name: tools::smime_find_keys() | ||||
69 | sub 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 | |||||
139 | BEGIN { 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() | ||||
152 | sub 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). | ||||
203 | sub 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 | |||||
230 | 1; |