summaryrefslogtreecommitdiffstats
path: root/masterkey.pl
blob: d24a5a56f4985f371f0ba38fdb9cf7671906917d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
#!/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();