[app-edwardng.git] / lib / App / EdwardNG.pm

package App::EdwardNG;

use 5.014000;
use strict;
use warnings;
use parent qw/Exporter/;
our $VERSION = '0.001';
our @EXPORT_OK = qw/import_pubkeys process_message/;

use Email::Sender::Simple qw/sendmail/;
use File::Share qw/dist_file/;
use File::Slurp qw/read_file/;
use File::Spec::Functions qw/rel2abs/;
use IO::Handle;
use Getopt::Long;
use MIME::Entity;
use MIME::Parser;
use Mail::GnuPG;
use PerlX::Maybe;
use Template;
use Try::Tiny;

sub debug { say STDERR @_ if $ENV{EDWARDNG_DEBUG} }
sub stringify ($) { join '', map {; '>', $_ } @{$_[0]} }
sub mg {
	Mail::GnuPG->new(
		key                => $ENV{EDWARDNG_KEY},
		maybe always_trust => $ENV{EDWARDNG_ALWAYS_TRUST},
		maybe keydir       => $ENV{EDWARDNG_KEYDIR},
		maybe passphrase   => $ENV{EDWARDNG_PASSPHRASE},
		maybe use_agent    => $ENV{EDWARDNG_USE_AGENT},
		@_);
}

sub mp {
	my $parser = MIME::Parser->new;
	$parser->decode_bodies($_[0] // 0);
	$parser->output_to_core(1);
	$parser
}

sub first_part{
	my ($ent) = @_;
	return first_part ($ent->parts(0)) if $ent->parts;
	stringify [$ent->bodyhandle->as_lines]
}

sub import_pubkeys {
	my ($ent, $mg) = @_;
	my @keys;
	if ($ent->mime_type eq 'application/pgp-keys') {
		$ent = mp(1)->parse_data($ent->stringify);
		my $gpg = GnuPG::Interface->new;
		$mg->_set_options($gpg);
		$gpg->options->quiet(1);
		my ($input, $status) = (IO::Handle->new, IO::Handle->new);
		my $pid = $gpg->import_keys(handles => GnuPG::Handles->new(stdin => $input, status => $status));
		my $read = Mail::GnuPG::_communicate([$status], [$input], {$input => $ent->bodyhandle->as_string});
		push @keys, map { /IMPORT_OK \d+ (\w+)/ } $read->{$status};
		waitpid $pid, 0
	}
	push @keys, import_pubkeys ($_, $mg) for $ent->parts;
	@keys
}

sub process_message {
	my ($in) = @_;
	my $msg;
	my $parser = mp;

	$msg =                      $in   if     ref $in eq 'MIME::Entity';
	$msg = $parser->parse      ($in)  if     ref $in eq 'IO';
	$msg = $parser->parse_data ($in)  if     ref $in eq 'SCALAR';
	$msg = $parser->parse_open ($in)  unless ref $in;
	die "Don't know how to parse $in" unless $msg;

	if ($msg->mime_type ne 'multipart/signed' && $msg->mime_type ne 'multipart/encrypted') {
		# PGP/Inline requires decoding
		$parser->decode_bodies(1);
		$msg = $parser->parse_data($msg->stringify)
	}

	my $gpg = mg;
	if ($gpg->is_signed($msg)) {
		debug 'This mail looks signed';
		my ($code, $keyid, $email) = $gpg->verify($msg);
		return sign_error => (
			message => stringify $gpg->{last_message}) if $code;
		return sign => (
			keyid   => $keyid,
			email   => $email,
			message => stringify $gpg->{last_message});
	}

	if ($gpg->is_encrypted($msg)) {
		debug 'This mail looks encrypted';
		my ($code, $keyid, $email) = $gpg->decrypt($msg);
		return encrypt_error => (
			message   => stringify $gpg->{last_message}) if $code;
		return encrypt => (
			plaintext => stringify $gpg->{plaintext},
			decrypted => $gpg->{decrypted},
			message   => stringify $gpg->{last_message}) unless defined $keyid;
		return signencrypt => (
			keyid     => $keyid,
			email     => $email,
			plaintext => stringify $gpg->{plaintext},
			decrypted => $gpg->{decrypted},
			message   => stringify $gpg->{last_message});
	}

	debug 'This mail doesn\'t seem to be signed or encrypted';
	return 'plain'
}

sub run {
	GetOptions(
		'always-trust!' => \$ENV{EDWARDNG_ALWAYS_TRUST},
		'debug!'        => \$ENV{EDWARDNG_DEBUG},
		'from=s'        => \$ENV{EDWARDNG_FROM},
		'key=s'         => \$ENV{EDWARDNG_KEY},
		'keydir=s'      => \$ENV{EDWARDNG_KEYDIR},
		'logfile=s'     => \$ENV{EDWARDNG_LOGFILE},
		'passphrase=s'  => \$ENV{EDWARDNG_PASSPHRASE},
		'tmpl-path=s'   => \$ENV{EDWARDNG_TMPL_PATH},
		'use-agent!'    => \$ENV{EDWARDNG_USE_AGENT},
	);
	my $tmpl_path = $ENV{EDWARDNG_TMPL_PATH} // 'en';
	open STDERR, '>>', $ENV{EDWARDNG_LOGFILE} if $ENV{EDWARDNG_LOGFILE};

	my $in = mp->parse(\*STDIN);
	debug 'Received mail from ', $in->get('From');
	my @keys = import_pubkeys $in, mg;
	say 'Found keys: ', join ' ', @keys if @keys;

	my ($tmpl, %params);
	try {
		($tmpl, %params) = process_message $in
	} catch {
		($tmpl, %params) = (error => message => $_)
	};
	debug "Result is $tmpl, GnuPG said:\n", $params{message};

	$params{plaintext} = first_part $params{decrypted} if $params{decrypted};

	my $tt = Template->new(INCLUDE_PATH => rel2abs $tmpl_path, dist_file 'App-EdwardNG', 'tmpl');
	my ($keys, $result) = ('', '');
	$tt->process('keys', {keys => \@keys}, \$keys) if @keys;
	$tt->process($tmpl, \%params, \$result);
	my $email = MIME::Entity->build(
		From    => $ENV{EDWARDNG_FROM},
		To      => $in->get('From'),
		Subject => 'Re: ' . $in->get('Subject'),
		Data    => $keys.$result);

	my $email_unencrypted = $email->dup;
	my $mg = mg always_trust => 1;
	my $encrypt_failed = $mg->mime_signencrypt($email, $in->get('From') =~ /<(.*)>/);
	debug 'Could not encrypt message, sending unencrypted. GnuPG said:', "\n", stringify $mg->{last_message} if $encrypt_failed;
	sendmail $encrypt_failed ? $email_unencrypted : $email
}

1;
__END__

=encoding utf-8

=head1 NAME

App::EdwardNG - GnuPG email sign/encrypt testing bot

=head1 SYNOPSIS

  use App::EdwardNG;
  my ($status, %params) = process_message '/path/to/message';
  if ($status eq 'signencrypt') {
    say 'This message is encrypted and signed with key ', $params{keyid}, ' from ', $params{email};
    say 'Its contents are: ', $params{plaintext};
  } elsif ($status eq 'encrypt') {
    say 'This message is encrypted but not signed';
    say 'Its contents are: ', $params{plaintext};
  } elsif ($status eq 'encrypt_error') {
    say 'This message is encrypted but I was unable to decrypt it. GnuPG output: ', $params{message};
  } elsif ($status eq 'sign') {
    say 'This message is signed with key ', $params{keyid}, ' from ', $params{email};
  } elsif ($status eq 'sign_error') {
    say 'This message is signed but I was unable to verify the signature. GnuPG output: ', $params{message};
  } elsif ($status eq 'plain') {
    say 'This message is neither signed nor encrypted';
  } elsif ($status eq 'error') {
    say 'There was an error processing the message: ', $params{message};
  }

=head1 DESCRIPTION

EdwardNG is a reimplementation of the Edward reply bot referenced in L<https://emailselfdefense.fsf.org/>.

=head1 EXPORTS

None by default.

=head2 B<import_keys>(I<$entity>, I<$gpg>)

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.

Returns a list of fingerprints of keys found.

=head2 B<process_message>(I<$message>)

Analyze a message, looking for PGP signatures and encryption. I<$message> can be:

=over

=item A filehandle reference, e.g. C<\*STDIN>.

=item A reference to a scalar which holds the message contents.

=item A scalar which represents a path to a message.

=item A L<MIME::Entity> object created with decode_bodies(0)

=back

The function returns a status followed by a hash. Possible results:

=over

=item plain

The message is neither signed nor encrypted.

=item sign_error, message => $message

The message is signed but the signature could not be verified. GnuPG output is $message.

=item sign, keyid => $keyid, email => $email, message => $message

The message is signed with key $keyid from $email. GnuPG output is $message.

=item encrypt_error, message => $message

The message is encrypted and unable to be decrypted. GnuPG output is $message.

=item encrypt, plaintext => $plaintext, decrypted => $decrypted, message => $message

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.

=item signencrypt, plaintext => $plaintext, decrypted => $decrypted, keyid => $keyid, email => $email, message => $message

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.

=item error, message => $message

There was an error while processing the message. The error can be found in $message.

=back

=head1 ENVIRONMENT

This module is configured via the %ENV hash. See the L<edwardng(1)> manpage for more information.

=head1 SEE ALSO

L<edwardng(1)>

=head1 AUTHOR

Marius Gavrilescu, E<lt>marius@ieval.roE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014 by Fundația Ceata

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.18.2 or,
at your option, any later version of Perl 5 you may have available.


=cut
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';
2f363992	8	our @EXPORT_OK = qw/import_pubkeys process_message/;
2f9e679a MG	9
2f9e679a MG	10	use Email::Sender::Simple qw/sendmail/;
8dd68edb	11	use File::Share qw/dist_file/;
2f9e679a	12	use File::Slurp qw/read_file/;
b2664811	13	use File::Spec::Functions qw/rel2abs/;
2f363992	14	use IO::Handle;
2f9e679a MG	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
2f363992 MG	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
2f9e679a MG	42	sub first_part{
2f9e679a MG	43	my ($ent) = @_;
d03d611f	44	return first_part ($ent->parts(0)) if $ent->parts;
3da0c458	45	stringify [$ent->bodyhandle->as_lines]
2f9e679a MG	46	}
2f9e679a MG	47
2f363992 MG	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
2f9e679a	66	sub process_message {
4224c4ce MG	67	my ($in) = @_;
4224c4ce MG	68	my $msg;
2f363992	69	my $parser = mp;
2f9e679a	70
4224c4ce MG	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;
2f9e679a MG	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},
8cf8d328	123	'logfile=s' => \$ENV{EDWARDNG_LOGFILE},
2f9e679a	124	'passphrase=s' => \$ENV{EDWARDNG_PASSPHRASE},
b2664811	125	'tmpl-path=s' => \$ENV{EDWARDNG_TMPL_PATH},
2f9e679a MG	126	'use-agent!' => \$ENV{EDWARDNG_USE_AGENT},
2f9e679a MG	127	);
b2664811	128	my $tmpl_path = $ENV{EDWARDNG_TMPL_PATH} // 'en';
8cf8d328	129	open STDERR, '>>', $ENV{EDWARDNG_LOGFILE} if $ENV{EDWARDNG_LOGFILE};
2f9e679a	130
2f363992	131	my $in = mp->parse(\*STDIN);
2044b38a	132	debug 'Received mail from ', $in->get('From');
2f363992 MG	133	my @keys = import_pubkeys $in, mg;
2f363992 MG	134	say 'Found keys: ', join ' ', @keys if @keys;
2f9e679a MG	135
	136	my ($tmpl, %params);
	137	try {
	138	($tmpl, %params) = process_message $in
	139	} catch {
	140	($tmpl, %params) = (error => message => $_)
	141	};
2044b38a	142	debug "Result is $tmpl, GnuPG said:\n", $params{message};
2f9e679a MG	143
	144	$params{plaintext} = first_part $params{decrypted} if $params{decrypted};
	145
8dd68edb	146	my $tt = Template->new(INCLUDE_PATH => rel2abs $tmpl_path, dist_file 'App-EdwardNG', 'tmpl');
2f363992 MG	147	my ($keys, $result) = ('', '');
	148	$tt->process('keys', {keys => \@keys}, \$keys) if @keys;
	149	$tt->process($tmpl, \%params, \$result);
2f9e679a MG	150	my $email = MIME::Entity->build(
	151	From => $ENV{EDWARDNG_FROM},
	152	To => $in->get('From'),
c3455a5b	153	Subject => 'Re: ' . $in->get('Subject'),
2f363992	154	Data => $keys.$result);
2f9e679a	155
70f9c37d	156	my $email_unencrypted = $email->dup;
2f9e679a	157	my $mg = mg always_trust => 1;
70f9c37d	158	my $encrypt_failed = $mg->mime_signencrypt($email, $in->get('From') =~ /<(.*)>/);
2044b38a	159	debug 'Could not encrypt message, sending unencrypted. GnuPG said:', "\n", stringify $mg->{last_message} if $encrypt_failed;
70f9c37d	160	sendmail $encrypt_failed ? $email_unencrypted : $email
2f9e679a MG	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
2f363992 MG	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:
2f9e679a MG	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
2f363992	220	=item A L<MIME::Entity> object created with decode_bodies(0)
2f9e679a MG	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
1f08c352	272	Copyright (C) 2014 by Fundația Ceata
2f9e679a MG	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