path: root/masterkey.pl

#!/usr/bin/perl
use strictures;
use v5.10;

use Data::Dumper;
use Email::Date;
use Email::MessageID;
use Function::Parameters;
use Getopt::Long;
use GnuPG::Interface;
use JSON;
use List::Util qw(first);
use List::MoreUtils;
use Mail::GPG;
use MIME::Entity;
use Pod::Usage;
use String::Random qw(random_string);
use Text::Template;
use Try::Tiny;

=head1 NAME

masterkey.pl

=head1 SYNOPSIS

masterkey.pl [options] <keyid ...>

Send verification mails to the owners of the listed GPG keys.

 Options:
   --help, -h             short help message
   --dry-run, -n          do not perform any permanent actions
   --from, -f <gpg id>    GPG ID used to send the email
   --from-address <email> Email of GPG ID to use
   --tokenfile <file>     Record tokens in this file
   --debug                Output debugging information

=cut

sub main {
	my $recipient_address_regex = qr/\@archlinux\.org/;
	my %templates = (
		'verification' => {
			'subject' => 'Master Key Verification for {$recipient_name} ({$recipient_key})',
			'body' => 'Hi,

This mail is about having your GPG key signed by an Arch Linux master key.
Please reply with an email that is signed with your key or a subkey of it ({$recipient_key})
and contains the token listed below. It is not necessary to encrypt the mail,
however, signing the mail with your key or a subkey of it is required.

If you do not have GPG configured in your mail client, it is sufficient to
send the signed token as an attachment.

Your token: {$token}

Best Regards,
SAMKIVS (Simple Automated Master Key Identity Verification System)
on behalf of {$sender_name} ({$sender_key})
',
		},
		'confirmation' => {
			'subject' => 'Master Key Signature Confirmation for {$recipient_name} ({$recipient_key})',
			'body' => 'Hi,

Your GPG key ({$recipient_key})
has been successfully signed by an Arch Linux master key.

A copy of your signed key is attached to this message.

Best Regards,
SAMKIVS (Simple Automated Master Key Identity Verification System)
on behalf of {$sender_name} ({$sender_key})
',
		},
	);

	my %opts = ();

	Getopt::Long::Configure ("bundling");
	GetOptions(\%opts, "help|h", "dry-run|n", "from|f=s", "from-address=s", "tokenfile=s", "debug") or pod2usage(2);
	pod2usage(0) if $opts{help};
	pod2usage(-verbose => 0) if (@ARGV== 0);

	my $command = shift @ARGV;

	# TODO: print all errors at once
	die "Error: --from option is required but not set\n" if not $opts{from};
	die "Error: --from-address option is required but not set\n" if not $opts{'from-address'};
	die "Error: --tokenfile option is required but not set\n" if not $opts{tokenfile};
	die "Error: no or invalid command\n" unless $templates{$command};

	for my $id (@ARGV) {
		say STDERR "Processing $id";
		try {
			die "key ID has length != 40\n" unless length($id) == 40;

			my $mail_subject = $templates{$command}{'subject'};
			my $mail_body = $templates{$command}{'body'};
			my $token = random_string('.' x 25);

			if ($command eq 'verification') {
				validate_key_parameters($id);
			}

			my $msg = build_email($command, $opts{from}, quotemeta($opts{'from-address'}), $id, $recipient_address_regex, $mail_subject, $mail_body, $token);

			if ($command eq 'verification') {
				save_token($id, $token, $opts{tokenfile}) unless $opts{'dry-run'};
			}

			send_email($msg) unless $opts{'dry-run'};
			say $msg->as_string if $opts{debug};
		} catch {
			warn "$_\nSkipping $id due to uncaught error\n";
		}
	}
}

fun save_token($id, $token, $file) {
	open my $fh,  '>>', $file or die "Failed to open '$file': $!";
	say $fh "$id $token";
	close $fh;
}

fun fill_template($template, $values) {
	my $result = Text::Template::fill_in_string($template, HASH => $values)
		or die "Failed to fill in template: $Text::Template::ERROR";

	return $result;
}

fun gpg_get_users($key) {
	my $gpg = GnuPG::Interface->new();
	my @keys = $gpg->get_public_keys_with_sigs($key);

	die "No key found" if 0+@keys == 0;

	my @users;

	for my $uid ($keys[0]->user_ids->@*) {
		next if $uid->revocations->@* > 0;

		my $user = Encode::decode('utf8', $uid->as_string);
		unless ($user =~ m/^(?<name>.*?) (?:\((?<comment>.*?)\) )?\<(?<email>.*?@.*?)\>$/) {
			warn "Warning: Failed to parse GPG user information for key $key; got '$user'. Ignoring...\n";
		}

		push @users, {%+};
	}

	die "Failed to parse even one UID from key. Giving up" unless (0+@users > 0);

	return \@users;
}

fun gpg_get_user($key, $email_regex) {
	my $users = gpg_get_users($key);

	# Disable this since we only want to use the userid matching the regex
	#return $users->[0] if $users->@* == 1;

	my $user = first {$_->{email} =~ m/$email_regex/} $users->@*;

	while (not defined $user) {
		for my $item ($users->@*) {
			printf "%s - %s\n", $item->@{qw(name email)};
		}

		print "Enter email address to use: ";
		my $email = <STDIN>;
		chomp($email);
		$user = first {$_->{email} eq $email} $users->@*;
	}

	return $user;
}

fun validate_key_parameters($key) {
	system("sq-keyring-linter <(gpg --export '$key')");
	system("gpg --export '$key' | hokey lint");

	print "Are there validation errors in the output above or is anything else wrong with the key? (Y/n) ";
	my $answer = <STDIN>;
	chomp($answer);

	die "Key has validation errors" unless $answer eq 'n' or $answer eq 'N';
}

fun build_email($command, $sender_key, $sender_address_regex, $recipient_key, $recipient_address_regex, $subject, $body, $token) {
	# get from gpg keys
	my ($sender_name, $sender_addr) = gpg_get_user($sender_key, $sender_address_regex)->@{qw(name email)};
	my ($recipient_name, $recipient_addr) = gpg_get_user($recipient_key, $recipient_address_regex)->@{qw(name email)};

	my %values;
	$values{token} = $token;
	$values{sender_key} = $sender_key;
	$values{sender_name} = $sender_name;
	$values{sender_addr} = $sender_addr;
	$values{recipient_key} = $recipient_key;
	$values{recipient_name} = $recipient_name;
	$values{recipient_addr} = $recipient_addr;

	$subject = fill_template($subject, \%values);
	$body = fill_template($body, \%values);

	my $mgpg = Mail::GPG->new(
		default_key_id => $sender_key,
		default_passphrase => '',
	);

	my $msg = MIME::Entity->build(
		From => Encode::encode('MIME-Header', $sender_name). " <$sender_addr>",
		To   => $recipient_addr,
		BCC   => $sender_addr,
		Subject => Encode::encode('MIME-Header', $subject),
		# TODO: necessary?
		#TimeZone => 'Europe/Vienna',
		Encoding => 'quoted-printable',
		Charset => 'utf8',
		Date => Email::Date::format_date(),
		Data => [$body],
	);

	if ($command eq 'confirmation') {
		my $recipient_key_data = `gpg --armor --export $recipient_key`;
		$msg->attach(
			Data => $recipient_key_data,
			Filename => "$recipient_key-signed.asc",
			Encoding => 'quoted-printable',
		);
	}


	$msg->add("Message-ID", Email::MessageID->new->in_brackets);
	$msg->replace("Return-Path", "<$sender_addr>");

	if ($command eq 'verification') {
		return $mgpg->mime_sign_encrypt(
			entity => $msg,
			recipients => [$sender_key, $recipient_key],
		);
	}
	return $mgpg->mime_sign(
		entity => $msg,
		recipients => [$sender_key, $recipient_key],
	);
}

fun send_email($msg) {
	open my $mail, "|msmtp -t";
	print $mail $msg->as_string;
	close $mail;
}

main();