92 lines
3.9 KiB
Perl
92 lines
3.9 KiB
Perl
#!/usr/bin/perl
|
|
# Spike helper: what the kernel tells a unix-socket server about each peer.
|
|
# peer.pl serve <path> <mode-octal> accept loop; per connection, reply with one JSON line
|
|
# peer.pl call <path> connect, print this process's own view and the reply
|
|
# peer.pl creds STDIN is an accepted socket: print its SO_PEERCRED as JSON
|
|
# Perl ships in the pinned node image (perl-base) and on the host, so no compiler or new
|
|
# dependency is needed. Node has no API for these options. No credentials are involved.
|
|
use strict; use warnings;
|
|
use Socket;
|
|
|
|
use constant { SO_PEERGROUPS => 59, SO_PEERPIDFD => 77 };
|
|
$| = 1;
|
|
|
|
sub readf { my ($f) = @_; open(my $h, '<', $f) or return undef; local $/; my $d = <$h>; close $h; return $d; }
|
|
sub jstr { my $s = shift; $s = '' unless defined $s; $s =~ s/([\\"])/\\$1/g; $s =~ s/\n/\\n/g; $s =~ s/[\0-\x1f]/ /g; return "\"$s\""; }
|
|
sub nsid { my $l = readlink("/proc/self/ns/$_[0]"); return defined $l ? $l : 'unreadable'; }
|
|
|
|
# SO_PEERCRED, SO_PEERGROUPS, SO_PEERPIDFD for an accepted socket, plus what the
|
|
# server can see of the peer's pid in its own /proc.
|
|
sub peer {
|
|
my ($c) = @_;
|
|
my %r;
|
|
my $cred = getsockopt($c, SOL_SOCKET, SO_PEERCRED);
|
|
if (defined $cred) { @r{qw(pid uid gid)} = unpack('iII', $cred); } else { $r{err} = "SO_PEERCRED: $!"; return \%r; }
|
|
my $g = getsockopt($c, SOL_SOCKET, SO_PEERGROUPS);
|
|
$r{groups} = defined $g ? [unpack('I*', $g)] : "err: $!";
|
|
my $pf = getsockopt($c, SOL_SOCKET, SO_PEERPIDFD);
|
|
if (defined $pf) {
|
|
my $fd = unpack('i', $pf);
|
|
my $info = readf("/proc/self/fdinfo/$fd") // '';
|
|
my ($p) = $info =~ /^Pid:\s*(-?\d+)/m; my ($ns) = $info =~ /^NSpid:\s*(.*)$/m;
|
|
$r{pidfd} = { fd => $fd, fdinfo_pid => $p, nspid => $ns };
|
|
if (open(my $h, '<&=', $fd)) { close $h; }
|
|
} else { $r{pidfd} = "err: $!"; }
|
|
my $pid = $r{pid};
|
|
$r{proc} = {
|
|
dir_exists => (-d "/proc/$pid" ? 1 : 0),
|
|
stat_readable => (defined readf("/proc/$pid/stat") ? 1 : 0),
|
|
cmdline_readable => (defined readf("/proc/$pid/cmdline") ? 1 : 0),
|
|
environ_readable => (defined readf("/proc/$pid/environ") ? 1 : 0),
|
|
};
|
|
my $cl = readf("/proc/$pid/cmdline"); $r{proc}{cmdline} = defined $cl ? $cl : undef;
|
|
return \%r;
|
|
}
|
|
|
|
sub jpeer {
|
|
my ($r) = @_;
|
|
return '{' . join(',', map { jstr($_) . ':' . jval($r->{$_}) } sort keys %$r) . '}';
|
|
}
|
|
sub jval {
|
|
my $v = shift;
|
|
return 'null' unless defined $v;
|
|
return '[' . join(',', map { jval($_) } @$v) . ']' if ref $v eq 'ARRAY';
|
|
return jpeer($v) if ref $v eq 'HASH';
|
|
return $v if $v =~ /^-?\d+$/;
|
|
return jstr($v);
|
|
}
|
|
|
|
sub me {
|
|
my @g = split ' ', $);
|
|
my $rg = $(; my ($gid) = split ' ', $rg;
|
|
my $um = readf('/proc/self/uid_map') // ''; $um =~ s/\s+/ /g;
|
|
return { pid => $$, uid => $<, euid => $>, gid => $gid, groups => [@g[1 .. $#g]],
|
|
pidns => nsid('pid'), userns => nsid('user'), uid_map => $um };
|
|
}
|
|
|
|
my $mode = shift // '';
|
|
if ($mode eq 'serve') {
|
|
my ($path, $perm) = @ARGV;
|
|
socket(my $s, PF_UNIX, SOCK_STREAM, 0) or die "socket: $!";
|
|
unlink $path;
|
|
bind($s, sockaddr_un($path)) or die "bind: $!";
|
|
chmod oct($perm), $path or die "chmod: $!";
|
|
listen($s, 16) or die "listen: $!";
|
|
print "listening $path $perm\n";
|
|
$SIG{TERM} = $SIG{INT} = sub { unlink $path; exit 0 };
|
|
while (accept(my $c, $s)) {
|
|
my $r = peer($c);
|
|
print $c '{"server":' . jpeer(me()) . ',"peer_as_server_sees_it":' . jpeer($r) . "}\n";
|
|
close $c;
|
|
}
|
|
} elsif ($mode eq 'call') {
|
|
my ($path) = @ARGV;
|
|
socket(my $s, PF_UNIX, SOCK_STREAM, 0) or die "socket: $!";
|
|
if (!connect($s, sockaddr_un($path))) { print '{"connect":"refused","errno":' . jstr("$!") . ',"client":' . jpeer(me()) . "}\n"; exit 0; }
|
|
my $line = <$s>; $line = '' unless defined $line; chomp $line;
|
|
print '{"connect":"ok","client":' . jpeer(me()) . ',"reply":' . ($line eq '' ? 'null' : $line) . "}\n";
|
|
} elsif ($mode eq 'creds') {
|
|
open(my $c, '<&=', 0) or die "fd 0: $!";
|
|
print jpeer(peer($c)) . "\n";
|
|
} else { die "usage: peer.pl serve|call|creds\n"; }
|