1 # Monkeysphere Validation Agent, Perl version
2 # Copyright © 2010 Daniel Kahn Gillmor <dkg@fifthhorseman.net>,
3 # Jameson Rollins <jrollins@finestructure.net>
5 # This program is free software: you can redistribute it and/or modify
6 # it under the terms of the GNU General Public License as published by
7 # the Free Software Foundation, either version 3 of the License, or
8 # (at your option) any later version.
10 # This program is distributed in the hope that it will be useful,
11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 # GNU General Public License for more details.
15 # You should have received a copy of the GNU General Public License
16 # along with this program. If not, see <http://www.gnu.org/licenses/>.
18 { package Crypt::Monkeysphere::MSVA;
22 use vars qw($VERSION);
24 use parent qw(HTTP::Server::Simple::CGI);
26 use Crypt::Monkeysphere::Validator;
29 use Regexp::Common qw /net/;
37 use Crypt::Monkeysphere::MSVA::MarginalUI;
38 use Crypt::Monkeysphere::Logger;
39 use Crypt::Monkeysphere::Util qw(untaint);
40 use Crypt::Monkeysphere::MSVA::Monitor;
41 use Crypt::Monkeysphere::OpenPGP;
44 use POSIX qw(strftime);
45 # we need the version of GnuPG::Interface that knows about pubkey_data, etc:
46 use GnuPG::Interface 0.43;
48 $VERSION = '0.09_001';
50 my $gnupg = GnuPG::Interface::->new();
51 $gnupg->options->quiet(1);
52 $gnupg->options->batch(1);
55 '/' => { handler => \&noop,
56 methods => { 'GET' => 1 },
58 '/reviewcert' => { handler => \&reviewcert,
59 methods => { 'POST' => 1 },
61 '/extracerts' => { handler => \&extracerts,
62 methods => { 'POST' => 1 },
66 my $default_keyserver_policy = 'unlessvalid';
68 my $logger = Crypt::Monkeysphere::Logger->new($ENV{MSVA_LOG_LEVEL});
74 return 'Net::Server::MSVA';
78 return $logger->log(@_);
81 no warnings 'redefine';
86 if (exists $ENV{MSVA_PORT} and $ENV{MSVA_PORT} ne '') {
87 msvalog('debug', "MSVA_PORT set to %s\n", $ENV{MSVA_PORT});
88 $port = $ENV{MSVA_PORT} + 0;
89 die sprintf("not a reasonable port %d", $port) if (($port >= 65536) || $port <= 0);
91 # start the server on requested port
92 my $self = $class->SUPER::new($port);
93 if (! exists $ENV{MSVA_PORT}) {
94 # we can't pass port 0 to the constructor because it evaluates
95 # to false, so HTTP::Server::Simple just uses its internal
96 # default of 8080. But if we want to select an arbitrary open
97 # port, we *can* set it here.
101 $self->{allowed_uids} = {};
102 if (exists $ENV{MSVA_ALLOWED_USERS} and $ENV{MSVA_ALLOWED_USERS} ne '') {
103 msvalog('verbose', "MSVA_ALLOWED_USERS environment variable is set.\nLimiting access to specified users.\n");
104 foreach my $user (split(/ +/, $ENV{MSVA_ALLOWED_USERS})) {
105 my ($name, $passwd, $uid);
106 if ($user =~ /^[0-9]+$/) {
107 $uid = $user + 0; # force to integer
109 ($name,$passwd,$uid) = getpwnam($user);
112 msvalog('verbose', "Allowing access from user ID %d\n", $uid);
113 $self->{allowed_uids}->{$uid} = $user;
115 msvalog('error', "Could not find user '%d'; not allowing\n", $user);
119 # default is to allow access only to the current user
120 $self->{allowed_uids}->{POSIX::getuid()} = 'self';
123 bless ($self, $class);
130 return '200 OK', { available => JSON::true,
135 # return an arrayref of processes which we can detect that have the
136 # given socket open (the socket is specified with its inode)
137 sub getpidswithsocketinode {
140 if (! defined ($sockid)) {
141 msvalog('verbose', "No client socket ID to check. The MSVA is probably not running as a service.\n");
144 # this appears to be how Linux symlinks open sockets in /proc/*/fd,
145 # as of at least 2.6.26:
146 my $socktarget = sprintf('socket:[%d]', $sockid);
150 if (opendir($procfs, '/proc')) {
151 foreach my $pid (grep { /^\d+$/ } readdir($procfs)) {
152 my $procdir = sprintf('/proc/%d', $pid);
155 if (opendir($procfds, sprintf('/proc/%d/fd', $pid))) {
156 foreach my $procfd (grep { /^\d+$/ } readdir($procfds)) {
157 my $fd = sprintf('/proc/%d/fd/%d', $pid, $procfd);
159 #my ($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($fd);
160 my $targ = readlink($fd);
162 if ($targ eq $socktarget);
172 # FIXME: this whole business is very linux-specific, i think. i
173 # wonder how to get this info in other OSes?
178 # return {uid => X, inode => Y}, meaning the numeric ID of the peer
179 # on the other end of $socket, "socket inode" identifying the peer's
180 # open network socket. each value could be undef if unknown.
181 sub get_client_info {
184 my $sock = IO::Socket::->new_from_fd($socket, 'r');
185 # check SO_PEERCRED -- if this was a TCP socket, Linux
186 # might not be able to support SO_PEERCRED (even on the loopback),
187 # though apparently some kernels (Solaris?) are able to.
190 my $remotesocketinode;
191 my $socktype = $sock->sockopt(SO_TYPE) or die "could not get SO_TYPE info";
192 if (defined $socktype) {
193 msvalog('debug', "sockopt(SO_TYPE) = %d\n", $socktype);
195 msvalog('verbose', "sockopt(SO_TYPE) returned undefined.\n");
198 my $peercred = $sock->sockopt(SO_PEERCRED) or die "could not get SO_PEERCRED info";
199 my $client = $sock->peername();
200 my $family = sockaddr_family($client); # should be AF_UNIX (a.k.a. AF_LOCAL) or AF_INET
202 msvalog('verbose', "socket family: %d\nsocket type: %d\n", $family, $socktype);
205 # FIXME: on i386 linux, this appears to be three ints, according to
206 # /usr/include/linux/socket.h. What about other platforms?
207 my ($pid, $uid, $gid) = unpack('iii', $peercred);
209 msvalog('verbose', "SO_PEERCRED: pid: %u, uid: %u, gid: %u\n",
212 if ($pid != 0 && $uid != 0) { # then we can accept it:
215 # FIXME: can we get the socket inode as well this way?
218 # another option in Linux would be to parse the contents of
219 # /proc/net/tcp to find the uid of the peer process based on that
221 if (! defined $clientid) {
222 msvalog('verbose', "SO_PEERCRED failed, digging around in /proc/net/tcp\n");
224 if ($family == AF_INET) {
226 } elsif ($family == AF_INET6) {
229 if (defined $proto) {
230 if ($socktype == &SOCK_STREAM) {
231 $proto = 'tcp'.$proto;
232 } elsif ($socktype == &SOCK_DGRAM) {
233 $proto = 'udp'.$proto;
237 if (defined $proto) {
238 my ($port, $iaddr) = unpack_sockaddr_in($client);
239 my $iaddrstring = unpack("H*", reverse($iaddr));
240 msvalog('verbose', "Port: %04x\nAddr: %s\n", $port, $iaddrstring);
241 my $remmatch = lc(sprintf("%s:%04x", $iaddrstring, $port));
242 my $infofile = '/proc/net/'.$proto;
243 my $f = IO::File::->new();
244 if ( $f->open('< '.$infofile)) {
245 my @header = split(/ +/, <$f>);
246 my ($localaddrix, $uidix, $inodeix);
249 while ($ix <= $#header) {
250 $localaddrix = $ix - $skipcount if (lc($header[$ix]) eq 'local_address');
251 $uidix = $ix - $skipcount if (lc($header[$ix]) eq 'uid');
252 $inodeix = $ix - $skipcount if (lc($header[$ix]) eq 'inode');
253 $skipcount++ if (lc($header[$ix]) eq 'tx_queue') or (lc($header[$ix]) eq 'tr'); # these headers don't actually result in a new column during the data rows
256 if (!defined $localaddrix) {
257 msvalog('info', "Could not find local_address field in %s; unable to determine peer UID\n",
259 } elsif (!defined $uidix) {
260 msvalog('info', "Could not find uid field in %s; unable to determine peer UID\n",
262 } elsif (!defined $inodeix) {
263 msvalog('info', "Could not find inode field in %s; unable to determine peer network socket inode\n",
266 msvalog('debug', "local_address: %d; uid: %d\n", $localaddrix,$uidix);
267 while (my @line = split(/ +/,<$f>)) {
268 if (lc($line[$localaddrix]) eq $remmatch) {
269 if (defined $clientid) {
270 msvalog('error', "Warning! found more than one remote uid! (%s and %s\n", $clientid, $line[$uidix]);
272 $clientid = $line[$uidix];
273 $remotesocketinode = $line[$inodeix];
274 msvalog('info', "remote peer is uid %d (inode %d)\n",
275 $clientid, $remotesocketinode);
279 msvalog('error', "Warning! could not find peer information in %s. Not verifying.\n", $infofile) unless defined $clientid;
281 } else { # FIXME: we couldn't read the file. what should we
282 # do besides warning?
283 msvalog('info', "Could not read %s; unable to determine peer UID\n",
289 return { 'uid' => $clientid,
290 'inode' => $remotesocketinode };
297 # This is part of a spawned child process. We don't want the
298 # child process to destroy the update monitor when it terminates.
299 $self->{updatemonitor}->forget();
300 my $clientinfo = get_client_info(select);
301 my $clientuid = $clientinfo->{uid};
303 if (defined $clientuid) {
304 # test that this is an allowed user:
305 if (exists $self->{allowed_uids}->{$clientuid}) {
306 msvalog('verbose', "Allowing access from uid %d (%s)\n", $clientuid, $self->{allowed_uids}->{$clientuid});
308 msvalog('error', "MSVA client connection from uid %d, forbidden.\n", $clientuid);
309 printf("HTTP/1.0 403 Forbidden -- peer does not match local user ID\r\nContent-Type: text/plain\r\nDate: %s\r\n\r\nHTTP/1.1 403 Not Found -- peer does not match the local user ID. Are you sure the agent is running as the same user?\r\n",
310 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),);
315 my $path = $cgi->path_info();
316 my $handler = $dispatch{$path};
318 if (ref($handler) eq "HASH") {
319 if (! exists $handler->{methods}->{$cgi->request_method()}) {
320 printf("HTTP/1.0 405 Method not allowed\r\nAllow: %s\r\nDate: %s\r\n",
321 join(', ', keys(%{$handler->{methods}})),
322 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
323 } elsif (ref($handler->{handler}) ne "CODE") {
324 printf("HTTP/1.0 500 Server Error\r\nDate: %s\r\n",
325 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())));
328 my $ctype = $cgi->content_type();
329 msvalog('verbose', "Got %s %s (Content-Type: %s)\n", $cgi->request_method(), $path, defined $ctype ? $ctype : '**none supplied**');
330 if (defined $ctype) {
331 my @ctypes = split(/; */, $ctype);
332 $ctype = shift @ctypes;
333 if ($ctype eq 'application/json') {
334 $data = from_json($cgi->param('POSTDATA'));
338 my ($status, $object) = $handler->{handler}($data, $clientinfo);
339 if (ref($object) eq 'HASH' &&
340 ! defined $object->{server}) {
341 $object->{server} = sprintf("MSVA-Perl %s", $VERSION);
344 my $ret = to_json($object);
345 msvalog('info', "returning: %s\n", $ret);
346 printf("HTTP/1.0 %s\r\nDate: %s\r\nContent-Type: application/json\r\n\r\n%s",
348 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
352 printf("HTTP/1.0 404 Not Found -- not handled by Monkeysphere validation agent\r\nContent-Type: text/plain\r\nDate: %s\r\n\r\nHTTP/1.0 404 Not Found -- the path:\r\n %s\r\nis not handled by the MonkeySphere validation agent.\r\nPlease try one of the following paths instead:\r\n\r\n%s\r\n",
353 strftime("%a, %d %b %Y %H:%M:%S %z", localtime(time())),
354 $path, ' * '.join("\r\n * ", keys %dispatch) );
358 sub get_keyserver_policy {
359 if (exists $ENV{MSVA_KEYSERVER_POLICY} and $ENV{MSVA_KEYSERVER_POLICY} ne '') {
360 if ($ENV{MSVA_KEYSERVER_POLICY} =~ /^(always|never|unlessvalid)$/) {
363 msvalog('error', "Not a valid MSVA_KEYSERVER_POLICY):\n %s\n", $ENV{MSVA_KEYSERVER_POLICY});
365 return $default_keyserver_policy;
369 # We should read from (first hit wins):
371 if (exists $ENV{MSVA_KEYSERVER} and $ENV{MSVA_KEYSERVER} ne '') {
372 if ($ENV{MSVA_KEYSERVER} =~ /^(((hkps?|hkpms|finger|ldap):\/\/)?$RE{net}{domain})$/) {
375 msvalog('error', "Not a valid keyserver (from MSVA_KEYSERVER):\n %s\n", $ENV{MSVA_KEYSERVER});
378 # FIXME: some msva.conf or monkeysphere.conf file (system and user?)
380 # let the keyserver routines choose.
385 ##################################################
386 ## PKC KEY EXTRACTION ############################
392 if (lc($data->{pkc}->{type}) eq 'x509der') {
393 $key = der2key(join('', map(chr, @{$data->{pkc}->{data}})));
394 } elsif (lc($data->{pkc}->{type}) eq 'x509pem') {
395 $key = der2key(pem2der($data->{pkc}->{data}));
396 } elsif (lc($data->{pkc}->{type}) eq 'opensshpubkey') {
397 $key = opensshpubkey2key($data->{pkc}->{data});
398 } elsif (lc($data->{pkc}->{type}) eq 'rfc4716') {
399 $key = rfc47162key($data->{pkc}->{data});
401 $key->{error} = sprintf("Don't know this public key carrier type: %s", $data->{pkc}->{type});
404 if (exists $key->{error}) {
408 # make sure that the returned integers are Math::BigInts:
409 $key->{exponent} = Math::BigInt::->new($key->{exponent}) unless (ref($key->{exponent}));
410 $key->{modulus} = Math::BigInt::->new($key->{modulus}) unless (ref($key->{modulus}));
411 msvalog('debug', "pubkey info:\nmodulus: %s\nexponent: %s\n",
412 $key->{modulus}->as_hex(),
413 $key->{exponent}->as_hex(),
416 if ($key->{modulus}->copy()->blog(2) < 1000) {
417 $key->{error} = sprintf('Public key size is less than 1000 bits (was: %d bits)', $key->{modulus}->copy()->blog(2));
426 my $cert = Crypt::X509::->new(cert => $rawdata);
428 my $key = {error => 'I do not know what happened here'};
431 $key->{error} = sprintf("Error decoding X.509 certificate: %s", $cert->error);
433 msvalog('verbose', "cert subject: %s\n", $cert->subject_cn());
434 msvalog('verbose', "cert issuer: %s\n", (defined $cert->issuer_cn() ? $cert->issuer_cn() : '<none>'));
435 msvalog('verbose', "cert pubkey algo: %s\n", $cert->PubKeyAlg());
436 msvalog('verbose', "cert pubkey: %s\n", unpack('H*', $cert->pubkey()));
438 if ($cert->PubKeyAlg() ne 'RSA') {
439 $key->{error} = sprintf('public key was algo "%s" (OID %s). MSVA.pl only supports RSA',
440 $cert->PubKeyAlg(), $cert->pubkey_algorithm);
442 msvalog('debug', "decoding ASN.1 pubkey\n");
443 $key = $cert->pubkey_components();
444 if (! defined $key) {
445 msvalog('verbose', "failed to decode %s\n", unpack('H*', $cert->pubkey()));
446 $key = {error => 'failed to decode the public key'};
448 # ensure these are Math::BigInts!
449 $key->{exponent} = Math::BigInt::->new($key->{exponent}) unless (ref($key->{exponent}));
450 $key->{modulus} = Math::BigInt::->new($key->{modulus}) unless (ref($key->{modulus}));
452 my $pgpext = $cert->PGPExtension();
453 if (defined $pgpext) {
454 $key->{openpgp4fpr} = Crypt::Monkeysphere::OpenPGP::fingerprint($key, $pgpext);
455 msvalog('verbose', "OpenPGP Fingerprint (derived from X.509 cert): 0x%s\n", uc(unpack("H*", $key->{openpgp4fpr})));
465 my @lines = split(/\n/, $pem);
468 foreach my $line (@lines) {
469 if ($line eq '-----END CERTIFICATE-----') {
472 push @goodlines, $line;
473 } elsif ($line eq '-----BEGIN CERTIFICATE-----') {
477 msvalog('debug', "%d lines of base64:\n%s\n", $#goodlines + 1, join("\n", @goodlines));
478 return decode_base64(join('', @goodlines));
481 sub opensshpubkey2key {
483 # FIXME: do we care that the label matches the type of key?
484 my ($label, $prop) = split(/ +/, $data);
486 my $out = parse_rfc4716body($prop);
495 my $continuation = '';
496 my $state = 'outside';
497 foreach my $line (split(/\n/, $data)) {
498 last if ($state eq 'body' && $line eq '---- END SSH2 PUBLIC KEY ----');
499 if ($state eq 'outside' && $line eq '---- BEGIN SSH2 PUBLIC KEY ----') {
503 if ($state eq 'header') {
504 $line = $continuation.$line;
506 if ($line =~ /^(.*)\\$/) {
510 if (! ($line =~ /:/)) {
514 push(@goodlines, $line) if ($state eq 'body');
517 msvalog('debug', "Found %d lines of RFC4716 body:\n%s\n",
519 join("\n", @goodlines));
520 my $out = parse_rfc4716body(join('', @goodlines));
525 sub parse_rfc4716body {
529 unless defined($data);
530 $data = decode_base64($data) or return undef;
532 msvalog('debug', "key properties: %s\n", unpack('H*', $data));
534 while (length($data) > 4) {
535 my $size = unpack('N', substr($data, 0, 4));
536 msvalog('debug', "size: 0x%08x\n", $size);
537 return undef if (length($data) < $size + 4);
538 push(@{$out}, substr($data, 4, $size));
539 $data = substr($data, 4 + $size);
542 if ($out->[0] ne "ssh-rsa") {
543 return {error => 'Not an RSA key'};
546 if (scalar(@{$out}) != 3) {
547 return {error => 'Does not contain the right number of bigints for RSA'};
550 return { exponent => Math::BigInt->from_hex('0x'.unpack('H*', $out->[1])),
551 modulus => Math::BigInt->from_hex('0x'.unpack('H*', $out->[2])),
555 ## PKC KEY EXTRACTION ############################
556 ##################################################
560 my $clientinfo = shift;
561 return if !ref $data;
563 msvalog('verbose', "reviewing data...\n");
565 my $status = '200 OK';
566 my $ret = { valid => JSON::false,
567 message => 'Unknown failure',
570 # check that there actually is key data
571 if ($data->{pkc}->{data} eq '') {
572 $ret->{message} = sprintf("Key data empty.");
576 # check context string
577 if ($data->{context} =~ /^(https|ssh|smtp|ike|postgresql|imaps|imap|submission|e-mail)$/) {
578 $data->{context} = $1;
580 msvalog('error', "invalid context: %s\n", $data->{context});
581 $ret->{message} = sprintf("Invalid/unknown context: %s", $data->{context});
584 msvalog('verbose', "context: %s\n", $data->{context});
586 # checkout peer string
587 # old-style just passed a string as a peer, rather than
588 # peer: { name: 'whatever', 'type': 'client' }
589 $data->{peer} = { name => $data->{peer} }
590 if (ref($data->{peer}) ne 'HASH');
592 if (defined($data->{peer}->{type})) {
593 if ($data->{peer}->{type} =~ /^(client|server|peer)$/) {
594 $data->{peer}->{type} = $1;
596 msvalog('error', "invalid peer type string: %s\n", $data->{peer}->{type});
597 $ret->{message} = sprintf("Invalid peer type string: %s", $data->{peer}->{type});
602 my $prefix = $data->{context}.'://';
603 if ($data->{context} eq 'e-mail' ||
604 (defined $data->{peer}->{type} &&
605 $data->{peer}->{type} eq 'client' &&
606 # ike and smtp clients are effectively other servers, so we'll
608 $data->{context} !~ /^(ike|smtp)$/)) {
610 # clients can have any one-line User ID without NULL characters
611 # and leading or trailing whitespace
612 if ($data->{peer}->{name} =~ /^([^[:space:]][^\n\0]*[^[:space:]]|[^\0[:space:]])$/) {
613 $data->{peer}->{name} = $1;
615 msvalog('error', "invalid client peer name string: %s\n", $data->{peer}->{name});
616 $ret->{message} = sprintf("Invalid client peer name string: %s", $data->{peer}->{name});
619 } elsif ($data->{peer}->{name} =~ /^($RE{net}{domain}(:[[:digit:]]+)?)$/) {
620 $data->{peer}->{name} = $1;
622 msvalog('error', "invalid peer name string: %s\n", $data->{peer}->{name});
623 $ret->{message} = sprintf("Invalid peer name string: %s", $data->{peer}->{name});
627 msvalog('verbose', "peer: %s\n", $data->{peer}->{name});
629 # generate uid string
630 my $uid = $prefix.$data->{peer}->{name};
631 msvalog('verbose', "user ID: %s\n", $uid);
633 # extract key or openpgp fingerprint from PKC
636 if (lc($data->{pkc}->{type}) eq 'openpgp4fpr') {
637 if ($data->{pkc}->{data} =~ /^(0x)?([[:xdigit:]]{40})$/) {
638 $data->{pkc}->{data} = uc($2);
639 $fpr = $data->{pkc}->{data};
641 msvalog('error', "invalid OpenPGP v4 fingerprint: %s\n",$data->{pkc}->{data});
642 $ret->{message} = sprintf("Invalid OpenPGP v4 fingerprint.");
646 # extract key from PKC
647 $key = pkcextractkey($data);
648 if (exists $key->{error}) {
649 $ret->{message} = $key->{error};
652 $fpr = uc(unpack('H*', $key->{openpgp4fpr}))
653 if (exists $key->{openpgp4fpr});
655 msvalog('verbose', "OpenPGP v4 fingerprint: %s\n",$fpr)
658 # determine keyserver policy
660 if (defined $data->{keyserverpolicy} &&
661 $data->{keyserverpolicy} =~ /^(always|never|unlessvalid)$/) {
663 msvalog("verbose", "using requested keyserver policy: %s\n", $1);
665 $kspolicy = get_keyserver_policy();
667 msvalog('debug', "keyserver policy: %s\n", $kspolicy);
668 # needed because $gnupg spawns child processes
669 $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
671 $ret->{message} = sprintf('Failed to validate "%s" through the OpenPGP Web of Trust.', $uid);
673 my $validator=new Crypt::Monkeysphere::Validator(kspolicy=>$kspolicy,
674 context=>$data->{context},
675 keyserver=>get_keyserver(),
679 my $uid_query=$validator->query(uid=>$uid,fpr=>$fpr, key=>$key );
681 # only show the marginal UI if the UID of the corresponding
682 # key is not fully valid.
683 if (scalar(@{$uid_query->{valid_keys}}) > 0) {
684 $ret->{valid} = JSON::true;
685 $ret->{message} = sprintf('Successfully validated "%s" through the OpenPGP Web of Trust.', $uid);
687 my $resp = Crypt::Monkeysphere::MSVA::MarginalUI->ask_the_user($gnupg,
689 $uid_query->{subvalid_keys},
690 getpidswithsocketinode($clientinfo->{inode}),
692 msvalog('info', "response: %s\n", $resp);
694 $ret->{valid} = JSON::true;
695 $ret->{message} = sprintf('Manually validated "%s" through the OpenPGP Web of Trust.', $uid);
706 $self->spawn_master_subproc($server);
709 sub master_subprocess_died {
712 my $subproc_return = shift;
714 my $exitstatus = POSIX::WEXITSTATUS($subproc_return);
715 msvalog('verbose', "Subprocess %d terminated; exiting %d.\n", $self->{child_pid}, $exitstatus);
716 $server->set_exit_status($exitstatus);
717 $server->server_close();
725 msvalog('debug', "Subprocess %d terminated.\n", $pid);
727 if (exists $self->{updatemonitor} &&
728 defined $self->{updatemonitor}->getchildpid() &&
729 $self->{updatemonitor}->getchildpid() == $pid) {
730 my $exitstatus = POSIX::WEXITSTATUS($?);
731 msvalog('verbose', "Update monitoring process (%d) terminated with code %d.\n", $pid, $exitstatus);
732 if (0 == $exitstatus) {
733 msvalog('info', "Reloading MSVA due to update request.\n");
734 # sending self a SIGHUP:
737 msvalog('error', "Update monitoring process (%d) died unexpectedly with code %d.\nNo longer monitoring for updates; please send HUP manually.\n", $pid, $exitstatus);
738 # it died for some other weird reason; should we respawn it?
740 # FIXME: i'm worried that re-spawning would create a
741 # potentially abusive loop, if there are legit, repeatable
742 # reasons for the failure.
744 # $self->{updatemonitor}->spawn();
746 # instead, we'll just avoid trying to kill the next process with this PID:
747 $self->{updatemonitor}->forget();
749 } elsif (exists $self->{child_pid} &&
750 ($self->{child_pid} == 0 ||
751 $self->{child_pid} == $pid)) {
752 $self->master_subprocess_died($server, $?);
760 $server->{server}->{leave_children_open_on_hup} = 1;
762 my $socketcount = @{ $server->{server}->{sock} };
763 if ( $socketcount != 1 ) {
764 msvalog('error', "%d sockets open; should have been 1.\n", $socketcount);
765 $server->set_exit_status(10);
766 $server->server_close();
768 my $port = @{ $server->{server}->{sock} }[0]->sockport();
769 if ((! defined $port) || ($port < 1) || ($port >= 65536)) {
770 msvalog('error', "got nonsense port: %d.\n", $port);
771 $server->set_exit_status(11);
772 $server->server_close();
774 if ((exists $ENV{MSVA_PORT}) && (($ENV{MSVA_PORT} + 0) != $port)) {
775 msvalog('error', "Explicitly requested port %d, but got port: %d.", ($ENV{MSVA_PORT}+0), $port);
776 $server->set_exit_status(13);
777 $server->server_close();
780 $self->{updatemonitor} = Crypt::Monkeysphere::MSVA::Monitor::->new($logger);
783 sub spawn_master_subproc {
787 if ((exists $ENV{MSVA_CHILD_PID}) && ($ENV{MSVA_CHILD_PID} ne '')) {
788 # this is most likely a re-exec.
789 msvalog('info', "This appears to be a re-exec, continuing with child pid %d\n", $ENV{MSVA_CHILD_PID});
790 $self->{child_pid} = $ENV{MSVA_CHILD_PID} + 0;
791 } elsif ($#ARGV >= 0) {
792 $self->{child_pid} = 0; # indicate that we are planning to fork.
793 # avoid ignoring SIGCHLD right before we fork.
796 while (defined($val = POSIX::waitpid(-1, POSIX::WNOHANG)) && $val > 0) {
797 $self->child_dies($val, $server);
801 if (! defined $fork) {
802 msvalog('error', "could not fork\n");
805 msvalog('debug', "Child process has PID %d\n", $fork);
806 $self->{child_pid} = $fork;
807 $ENV{MSVA_CHILD_PID} = $fork;
809 msvalog('verbose', "PID %d executing: \n", $$);
810 for my $arg (@ARGV) {
811 msvalog('verbose', " %s\n", $arg);
813 # untaint the environment for the subprocess
814 # see: https://labs.riseup.net/code/issues/2461
815 foreach my $e (keys %ENV) {
816 $ENV{$e} = untaint($ENV{$e});
820 push @args, untaint($_);
822 # restore default SIGCHLD handling:
823 $SIG{CHLD} = 'DEFAULT';
824 $ENV{MONKEYSPHERE_VALIDATION_AGENT_SOCKET} = sprintf('http://localhost:%d', $self->port);
825 exec(@args) or exit 111;
829 printf("MONKEYSPHERE_VALIDATION_AGENT_SOCKET=http://localhost:%d;\nexport MONKEYSPHERE_VALIDATION_AGENT_SOCKET;\n", $self->port);
830 # FIXME: consider daemonizing here to behave more like
831 # ssh-agent. maybe avoid backgrounding by setting
832 # MSVA_NO_BACKGROUND.
839 return '500 not yet implemented', { };