]>
Commit | Line | Data |
---|---|---|
1 | package App::EdwardNG; | |
2 | ||
3 | use 5.014000; | |
4 | use strict; | |
5 | use warnings; | |
6 | use parent qw/Exporter/; | |
7 | our $VERSION = '0.001'; | |
8 | our @EXPORT_OK = qw/import_pubkeys process_message/; | |
9 | ||
10 | use Email::Sender::Simple qw/sendmail/; | |
11 | use File::Share qw/dist_file/; | |
12 | use File::Slurp qw/read_file/; | |
13 | use File::Spec::Functions qw/rel2abs/; | |
14 | use IO::Handle; | |
15 | use Getopt::Long; | |
16 | use MIME::Entity; | |
17 | use MIME::Parser; | |
18 | use Mail::GnuPG; | |
19 | use PerlX::Maybe; | |
20 | use Template; | |
21 | use Try::Tiny; | |
22 | ||
23 | sub debug { say STDERR @_ if $ENV{EDWARDNG_DEBUG} } | |
24 | sub stringify ($) { join '', map {; '>', $_ } @{$_[0]} } | |
25 | sub mg { | |
26 | Mail::GnuPG->new( | |
27 | key => $ENV{EDWARDNG_KEY}, | |
28 | maybe always_trust => $ENV{EDWARDNG_ALWAYS_TRUST}, | |
29 | maybe keydir => $ENV{EDWARDNG_KEYDIR}, | |
30 | maybe passphrase => $ENV{EDWARDNG_PASSPHRASE}, | |
31 | maybe use_agent => $ENV{EDWARDNG_USE_AGENT}, | |
32 | @_); | |
33 | } | |
34 | ||
35 | sub mp { | |
36 | my $parser = MIME::Parser->new; | |
37 | $parser->decode_bodies($_[0] // 0); | |
38 | $parser->output_to_core(1); | |
39 | $parser | |
40 | } | |
41 | ||
42 | sub first_part{ | |
43 | my ($ent) = @_; | |
44 | return first_part ($ent->parts(0)) if $ent->parts; | |
45 | stringify [$ent->bodyhandle->as_lines] | |
46 | } | |
47 | ||
48 | sub import_pubkeys { | |
49 | my ($ent, $mg) = @_; | |
50 | my @keys; | |
51 | if ($ent->mime_type eq 'application/pgp-keys') { | |
52 | $ent = mp(1)->parse_data($ent->stringify); | |
53 | my $gpg = GnuPG::Interface->new; | |
54 | $mg->_set_options($gpg); | |
55 | $gpg->options->quiet(1); | |
56 | my ($input, $status) = (IO::Handle->new, IO::Handle->new); | |
57 | my $pid = $gpg->import_keys(handles => GnuPG::Handles->new(stdin => $input, status => $status)); | |
58 | my $read = Mail::GnuPG::_communicate([$status], [$input], {$input => $ent->bodyhandle->as_string}); | |
59 | push @keys, map { /IMPORT_OK \d+ (\w+)/ } $read->{$status}; | |
60 | waitpid $pid, 0 | |
61 | } | |
62 | push @keys, import_pubkeys ($_, $mg) for $ent->parts; | |
63 | @keys | |
64 | } | |
65 | ||
66 | sub process_message { | |
67 | my ($in) = @_; | |
68 | my $msg; | |
69 | my $parser = mp; | |
70 | ||
71 | $msg = $in if ref $in eq 'MIME::Entity'; | |
72 | $msg = $parser->parse ($in) if ref $in eq 'IO'; | |
73 | $msg = $parser->parse_data ($in) if ref $in eq 'SCALAR'; | |
74 | $msg = $parser->parse_open ($in) unless ref $in; | |
75 | die "Don't know how to parse $in" unless $msg; | |
76 | ||
77 | if ($msg->mime_type ne 'multipart/signed' && $msg->mime_type ne 'multipart/encrypted') { | |
78 | # PGP/Inline requires decoding | |
79 | $parser->decode_bodies(1); | |
80 | $msg = $parser->parse_data($msg->stringify) | |
81 | } | |
82 | ||
83 | my $gpg = mg; | |
84 | if ($gpg->is_signed($msg)) { | |
85 | debug 'This mail looks signed'; | |
86 | my ($code, $keyid, $email) = $gpg->verify($msg); | |
87 | return sign_error => ( | |
88 | message => stringify $gpg->{last_message}) if $code; | |
89 | return sign => ( | |
90 | keyid => $keyid, | |
91 | email => $email, | |
92 | message => stringify $gpg->{last_message}); | |
93 | } | |
94 | ||
95 | if ($gpg->is_encrypted($msg)) { | |
96 | debug 'This mail looks encrypted'; | |
97 | my ($code, $keyid, $email) = $gpg->decrypt($msg); | |
98 | return encrypt_error => ( | |
99 | message => stringify $gpg->{last_message}) if $code; | |
100 | return encrypt => ( | |
101 | plaintext => stringify $gpg->{plaintext}, | |
102 | decrypted => $gpg->{decrypted}, | |
103 | message => stringify $gpg->{last_message}) unless defined $keyid; | |
104 | return signencrypt => ( | |
105 | keyid => $keyid, | |
106 | email => $email, | |
107 | plaintext => stringify $gpg->{plaintext}, | |
108 | decrypted => $gpg->{decrypted}, | |
109 | message => stringify $gpg->{last_message}); | |
110 | } | |
111 | ||
112 | debug 'This mail doesn\'t seem to be signed or encrypted'; | |
113 | return 'plain', message => '' | |
114 | } | |
115 | ||
116 | sub run { | |
117 | GetOptions( | |
118 | 'always-trust!' => \$ENV{EDWARDNG_ALWAYS_TRUST}, | |
119 | 'debug!' => \$ENV{EDWARDNG_DEBUG}, | |
120 | 'from=s' => \$ENV{EDWARDNG_FROM}, | |
121 | 'key=s' => \$ENV{EDWARDNG_KEY}, | |
122 | 'keydir=s' => \$ENV{EDWARDNG_KEYDIR}, | |
123 | 'logfile=s' => \$ENV{EDWARDNG_LOGFILE}, | |
124 | 'passphrase=s' => \$ENV{EDWARDNG_PASSPHRASE}, | |
125 | 'tmpl-path=s' => \$ENV{EDWARDNG_TMPL_PATH}, | |
126 | 'use-agent!' => \$ENV{EDWARDNG_USE_AGENT}, | |
127 | ); | |
128 | my $tmpl_path = $ENV{EDWARDNG_TMPL_PATH} // 'en'; | |
129 | open STDERR, '>>', $ENV{EDWARDNG_LOGFILE} if $ENV{EDWARDNG_LOGFILE}; | |
130 | ||
131 | my $in = mp->parse(\*STDIN); | |
132 | debug 'Received mail from ', $in->get('From'); | |
133 | my @keys = import_pubkeys $in, mg; | |
134 | say 'Found keys: ', join ' ', @keys if @keys; | |
135 | ||
136 | my ($tmpl, %params); | |
137 | try { | |
138 | ($tmpl, %params) = process_message $in | |
139 | } catch { | |
140 | ($tmpl, %params) = (error => message => $_) | |
141 | }; | |
142 | debug "Result is $tmpl, GnuPG said:\n", $params{message}; | |
143 | ||
144 | $params{plaintext} = first_part $params{decrypted} if $params{decrypted}; | |
145 | ||
146 | my $tt = Template->new(INCLUDE_PATH => rel2abs $tmpl_path, dist_file 'App-EdwardNG', 'tmpl'); | |
147 | my ($keys, $result) = ('', ''); | |
148 | $tt->process('keys', {keys => \@keys}, \$keys) if @keys; | |
149 | $tt->process($tmpl, \%params, \$result); | |
150 | my $email = MIME::Entity->build( | |
151 | From => $ENV{EDWARDNG_FROM}, | |
152 | To => $in->get('From'), | |
153 | Type => 'text/plain; charset=UTF-8', | |
154 | Encoding=> '-SUGGEST', | |
155 | Subject => 'Re: ' . $in->get('Subject'), | |
156 | Data => $keys.$result); | |
157 | ||
158 | my $email_unencrypted = $email->dup; | |
159 | my $mg = mg always_trust => 1; | |
160 | my $encrypt_failed = $mg->mime_signencrypt($email, $in->get('From') =~ /<(.*)>/); | |
161 | debug 'Could not encrypt message, sending unencrypted. GnuPG said:', "\n", stringify $mg->{last_message} if $encrypt_failed; | |
162 | sendmail $encrypt_failed ? $email_unencrypted : $email | |
163 | } | |
164 | ||
165 | 1; | |
166 | __END__ | |
167 | ||
168 | =encoding utf-8 | |
169 | ||
170 | =head1 NAME | |
171 | ||
172 | App::EdwardNG - GnuPG email sign/encrypt testing bot | |
173 | ||
174 | =head1 SYNOPSIS | |
175 | ||
176 | use App::EdwardNG; | |
177 | my ($status, %params) = process_message '/path/to/message'; | |
178 | if ($status eq 'signencrypt') { | |
179 | say 'This message is encrypted and signed with key ', $params{keyid}, ' from ', $params{email}; | |
180 | say 'Its contents are: ', $params{plaintext}; | |
181 | } elsif ($status eq 'encrypt') { | |
182 | say 'This message is encrypted but not signed'; | |
183 | say 'Its contents are: ', $params{plaintext}; | |
184 | } elsif ($status eq 'encrypt_error') { | |
185 | say 'This message is encrypted but I was unable to decrypt it. GnuPG output: ', $params{message}; | |
186 | } elsif ($status eq 'sign') { | |
187 | say 'This message is signed with key ', $params{keyid}, ' from ', $params{email}; | |
188 | } elsif ($status eq 'sign_error') { | |
189 | say 'This message is signed but I was unable to verify the signature. GnuPG output: ', $params{message}; | |
190 | } elsif ($status eq 'plain') { | |
191 | say 'This message is neither signed nor encrypted'; | |
192 | } elsif ($status eq 'error') { | |
193 | say 'There was an error processing the message: ', $params{message}; | |
194 | } | |
195 | ||
196 | =head1 DESCRIPTION | |
197 | ||
198 | EdwardNG is a reimplementation of the Edward reply bot referenced in L<https://emailselfdefense.fsf.org/>. | |
199 | ||
200 | =head1 EXPORTS | |
201 | ||
202 | None by default. | |
203 | ||
204 | =head2 B<import_keys>(I<$entity>, I<$gpg>) | |
205 | ||
206 | Scan a message for PGP public keys, and import them. I<$entity> is a L<MIME::Entity> to scan, I<$gpg> is a L<Mail::GnuPG> instance. | |
207 | ||
208 | Returns a list of fingerprints of keys found. | |
209 | ||
210 | =head2 B<process_message>(I<$message>) | |
211 | ||
212 | Analyze a message, looking for PGP signatures and encryption. I<$message> can be: | |
213 | ||
214 | =over | |
215 | ||
216 | =item A filehandle reference, e.g. C<\*STDIN>. | |
217 | ||
218 | =item A reference to a scalar which holds the message contents. | |
219 | ||
220 | =item A scalar which represents a path to a message. | |
221 | ||
222 | =item A L<MIME::Entity> object created with decode_bodies(0) | |
223 | ||
224 | =back | |
225 | ||
226 | The function returns a status followed by a hash. Possible results: | |
227 | ||
228 | =over | |
229 | ||
230 | =item plain | |
231 | ||
232 | The message is neither signed nor encrypted. | |
233 | ||
234 | =item sign_error, message => $message | |
235 | ||
236 | The message is signed but the signature could not be verified. GnuPG output is $message. | |
237 | ||
238 | =item sign, keyid => $keyid, email => $email, message => $message | |
239 | ||
240 | The message is signed with key $keyid from $email. GnuPG output is $message. | |
241 | ||
242 | =item encrypt_error, message => $message | |
243 | ||
244 | The message is encrypted and unable to be decrypted. GnuPG output is $message. | |
245 | ||
246 | =item encrypt, plaintext => $plaintext, decrypted => $decrypted, message => $message | |
247 | ||
248 | The message is encrypted and unsigned. $plaintext is the decrypted message as plain text, while $decrypted is a MIME::Entity representing the decrypted message. GnuPG output is $message. | |
249 | ||
250 | =item signencrypt, plaintext => $plaintext, decrypted => $decrypted, keyid => $keyid, email => $email, message => $message | |
251 | ||
252 | The message is encrypted and signed with key $keyid from $email. $plaintext is the decrypted message as plain text, while $decrypted is a MIME::Entity representing the decrypted message. GnuPG output is $message. | |
253 | ||
254 | =item error, message => $message | |
255 | ||
256 | There was an error while processing the message. The error can be found in $message. | |
257 | ||
258 | =back | |
259 | ||
260 | =head1 ENVIRONMENT | |
261 | ||
262 | This module is configured via the %ENV hash. See the L<edwardng(1)> manpage for more information. | |
263 | ||
264 | =head1 SEE ALSO | |
265 | ||
266 | L<edwardng(1)> | |
267 | ||
268 | =head1 AUTHOR | |
269 | ||
270 | Marius Gavrilescu, E<lt>marius@ieval.roE<gt> | |
271 | ||
272 | =head1 COPYRIGHT AND LICENSE | |
273 | ||
274 | Copyright (C) 2014 by Fundația Ceata | |
275 | ||
276 | This library is free software; you can redistribute it and/or modify | |
277 | it under the same terms as Perl itself, either Perl version 5.18.2 or, | |
278 | at your option, any later version of Perl 5 you may have available. | |
279 | ||
280 | ||
281 | =cut |