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