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