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