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