]> iEval git - app-edwardng.git/blame_incremental - lib/App/EdwardNG.pm
Set Content-Type and Content-Transfer-Encoding
[app-edwardng.git] / lib / App / EdwardNG.pm
... / ...
CommitLineData
1package App::EdwardNG;
2
3use 5.014000;
4use strict;
5use warnings;
6use parent qw/Exporter/;
7our $VERSION = '0.001';
8our @EXPORT_OK = qw/import_pubkeys process_message/;
9
10use Email::Sender::Simple qw/sendmail/;
11use File::Share qw/dist_file/;
12use File::Slurp qw/read_file/;
13use File::Spec::Functions qw/rel2abs/;
14use IO::Handle;
15use Getopt::Long;
16use MIME::Entity;
17use MIME::Parser;
18use Mail::GnuPG;
19use PerlX::Maybe;
20use Template;
21use Try::Tiny;
22
23sub debug { say STDERR @_ if $ENV{EDWARDNG_DEBUG} }
24sub stringify ($) { join '', map {; '>', $_ } @{$_[0]} }
25sub 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
35sub mp {
36 my $parser = MIME::Parser->new;
37 $parser->decode_bodies($_[0] // 0);
38 $parser->output_to_core(1);
39 $parser
40}
41
42sub first_part{
43 my ($ent) = @_;
44 return first_part ($ent->parts(0)) if $ent->parts;
45 stringify [$ent->bodyhandle->as_lines]
46}
47
48sub 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
66sub 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
116sub 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
1651;
166__END__
167
168=encoding utf-8
169
170=head1 NAME
171
172App::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
198EdwardNG is a reimplementation of the Edward reply bot referenced in L<https://emailselfdefense.fsf.org/>.
199
200=head1 EXPORTS
201
202None by default.
203
204=head2 B<import_keys>(I<$entity>, I<$gpg>)
205
206Scan 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
208Returns a list of fingerprints of keys found.
209
210=head2 B<process_message>(I<$message>)
211
212Analyze 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
226The function returns a status followed by a hash. Possible results:
227
228=over
229
230=item plain
231
232The message is neither signed nor encrypted.
233
234=item sign_error, message => $message
235
236The 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
240The message is signed with key $keyid from $email. GnuPG output is $message.
241
242=item encrypt_error, message => $message
243
244The message is encrypted and unable to be decrypted. GnuPG output is $message.
245
246=item encrypt, plaintext => $plaintext, decrypted => $decrypted, message => $message
247
248The 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
252The 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
256There was an error while processing the message. The error can be found in $message.
257
258=back
259
260=head1 ENVIRONMENT
261
262This module is configured via the %ENV hash. See the L<edwardng(1)> manpage for more information.
263
264=head1 SEE ALSO
265
266L<edwardng(1)>
267
268=head1 AUTHOR
269
270Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
271
272=head1 COPYRIGHT AND LICENSE
273
274Copyright (C) 2014 by Fundația Ceata
275
276This library is free software; you can redistribute it and/or modify
277it under the same terms as Perl itself, either Perl version 5.18.2 or,
278at your option, any later version of Perl 5 you may have available.
279
280
281=cut
This page took 0.026191 seconds and 5 git commands to generate.