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