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