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/; | |
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, $subject); | |
125 | $tt->process($tmpl, \%params, \$data); | |
126 | $tt->process('subject', undef, \$subject); | |
127 | my $email = MIME::Entity->build( | |
128 | From => $ENV{EDWARDNG_FROM}, | |
129 | To => $in->get('From'), | |
130 | Subject => $subject, | |
131 | Data => $data); | |
132 | ||
133 | my $mg = mg always_trust => 1; | |
134 | $mg->mime_signencrypt($email, $in->get('From') =~ /<(.*)>/) and debug 'Could not encrypt message. GnuPG said ', stringify $mg->{last_message}; | |
135 | sendmail $email | |
136 | } | |
137 | ||
138 | 1; | |
139 | __END__ | |
140 | ||
141 | =encoding utf-8 | |
142 | ||
143 | =head1 NAME | |
144 | ||
145 | App::EdwardNG - GnuPG email sign/encrypt testing bot | |
146 | ||
147 | =head1 SYNOPSIS | |
148 | ||
149 | use App::EdwardNG; | |
150 | my ($status, %params) = process_message '/path/to/message'; | |
151 | if ($status eq 'signencrypt') { | |
152 | say 'This message is encrypted and signed with key ', $params{keyid}, ' from ', $params{email}; | |
153 | say 'Its contents are: ', $params{plaintext}; | |
154 | } elsif ($status eq 'encrypt') { | |
155 | say 'This message is encrypted but not signed'; | |
156 | say 'Its contents are: ', $params{plaintext}; | |
157 | } elsif ($status eq 'encrypt_error') { | |
158 | say 'This message is encrypted but I was unable to decrypt it. GnuPG output: ', $params{message}; | |
159 | } elsif ($status eq 'sign') { | |
160 | say 'This message is signed with key ', $params{keyid}, ' from ', $params{email}; | |
161 | } elsif ($status eq 'sign_error') { | |
162 | say 'This message is signed but I was unable to verify the signature. GnuPG output: ', $params{message}; | |
163 | } elsif ($status eq 'plain') { | |
164 | say 'This message is neither signed nor encrypted'; | |
165 | } elsif ($status eq 'error') { | |
166 | say 'There was an error processing the message: ', $params{message}; | |
167 | } | |
168 | ||
169 | =head1 DESCRIPTION | |
170 | ||
171 | EdwardNG is a reimplementation of the Edward reply bot referenced in L<https://emailselfdefense.fsf.org/>. | |
172 | ||
173 | It takes mail messages, checks them for PGP signatures and encryption, then replies appropriately. | |
174 | ||
175 | This module exports a single function, B<process_message>, which takes a single parameter representing the message. This parameter can be: | |
176 | ||
177 | =over | |
178 | ||
179 | =item A filehandle reference, e.g. C<\*STDIN>. | |
180 | ||
181 | =item A reference to a scalar which holds the message contents. | |
182 | ||
183 | =item A scalar which represents a path to a message. | |
184 | ||
185 | =item A L<MIME::Entity> object | |
186 | ||
187 | =back | |
188 | ||
189 | The function returns a status followed by a hash. Possible results: | |
190 | ||
191 | =over | |
192 | ||
193 | =item plain | |
194 | ||
195 | The message is neither signed nor encrypted. | |
196 | ||
197 | =item sign_error, message => $message | |
198 | ||
199 | The message is signed but the signature could not be verified. GnuPG output is $message. | |
200 | ||
201 | =item sign, keyid => $keyid, email => $email, message => $message | |
202 | ||
203 | The message is signed with key $keyid from $email. GnuPG output is $message. | |
204 | ||
205 | =item encrypt_error, message => $message | |
206 | ||
207 | The message is encrypted and unable to be decrypted. GnuPG output is $message. | |
208 | ||
209 | =item encrypt, plaintext => $plaintext, decrypted => $decrypted, message => $message | |
210 | ||
211 | 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. | |
212 | ||
213 | =item signencrypt, plaintext => $plaintext, decrypted => $decrypted, keyid => $keyid, email => $email, message => $message | |
214 | ||
215 | 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. | |
216 | ||
217 | =item error, message => $message | |
218 | ||
219 | There was an error while processing the message. The error can be found in $message. | |
220 | ||
221 | =back | |
222 | ||
223 | =head1 ENVIRONMENT | |
224 | ||
225 | This module is configured via the %ENV hash. See the L<edwardng(1)> manpage for more information. | |
226 | ||
227 | =head1 SEE ALSO | |
228 | ||
229 | L<edwardng(1)> | |
230 | ||
231 | =head1 AUTHOR | |
232 | ||
233 | Marius Gavrilescu, E<lt>marius@ieval.roE<gt> | |
234 | ||
235 | =head1 COPYRIGHT AND LICENSE | |
236 | ||
1f08c352 | 237 | Copyright (C) 2014 by Fundația Ceata |
2f9e679a MG |
238 | |
239 | This library is free software; you can redistribute it and/or modify | |
240 | it under the same terms as Perl itself, either Perl version 5.18.2 or, | |
241 | at your option, any later version of Perl 5 you may have available. | |
242 | ||
243 | ||
244 | =cut |