| 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 |