lsofc

#! /usr/bin/perl
# wrapper around lsof to add peer information for sockets.
#
# Where the "ss" command can give peer information for Unix domain
# sockets, it uses that and also retrieves information on which
# direction of the socket is shut down (indicated with arrows like <--,
# -->, <->, ---).
#
# Where not (older systems), we get the information from kernel memory
# (/proc/kcore). In that case, superuser privileges are required.
#
# Copyright Stephane Chazelas 2015, public domain.
#
# example without "ss":
# # lsofc -ad14,21,22 -c mysqld
# COMMAND  PID  USER   FD   TYPE             DEVICE SIZE/OFF     NODE NAME
# mysqld  1260 mysql   14u  unix 0xffff880f48b48680      0t0 47793475 /var/run/mysqld/mysqld.sock -> 0xffff880f48b4aa40[authdaemond,2692]
# mysqld  1260 mysql   21u  IPv4           47946785      0t0      TCP localhost:mysql->localhost:44477 (ESTABLISHED) -> [proxymap,40597]
# mysqld  1260 mysql   22u  unix 0xffff880fbd6ab0c0      0t0 47953869 /var/run/mysqld/mysqld.sock -> 0xffff880fbd6afb80[postfix-policyd,3455]
#
# Example with "ss":
# # lsofc -aUc packagekit
# COMMAND     PID USER   FD   TYPE             DEVICE SIZE/OFF   NODE NAME
# packageki 26565 root    1u  unix 0xffff8800a95081c0      0t0 591416 type=STREAM --> 591417[systemd-journal,233,/run/systemd/journal/stdout]
# packageki 26565 root    2u  unix 0xffff8800a95081c0      0t0 591416 type=STREAM --> 591417[systemd-journal,233,/run/systemd/journal/stdout]
# packageki 26565 root    3u  unix 0xffff8802168f04c0      0t0 592167 type=DGRAM
# packageki 26565 root    5u  unix 0xffff8801bd2f0780      0t0 591426 type=STREAM <-> 592168[dbus-daemon,2268,/var/run/dbus/system_bus_socket]

use Socket;

my $usable_ss;
my (%peer, %dir);

# Try and get unix socket peer information from the ss command.
# While we're at it, we also use -e to get direction (-->, <-->...)
if (open SS, '-|', 'ss', '-nexa') {
  while (<SS>) {
    # parse unix domain list.
    if (/\s(\d+)\s+\*\s+(\d+) ([<-]-[->])$/) {
      # if we find a non-null peer, that means we can probably trust ss
      $usable_ss = 1 if $2;
      $peer{$1} = $2;
      $dir{$1} = $3;
    }
  }
  close SS;
}

my (%fields, %proc, %net);

# get an idea of what [command,pid] has any given (unix or tcp) socket
# open. We store the information in the keys of a hash for each socket.
open LSOF, '-|', qw{lsof -nMPFpctidn -U -i@[::1] -i@127.0.0.1};
while (<LSOF>) {
  if (/(.)(.*)/) {
    $fields{$1} = $2;
    if ($1 eq 'n') {
      if ($fields{t} eq 'unix') {
	$proc{$usable_ss ? $fields{i} : hex $fields{d}}->{"$fields{c},$fields{p}" .
	($fields{n} =~ m{^([@/].*?)( type=\w+)?$} ? ",$1" : "")} = "";
      } else {
	# for TCP sockets, We try to identify peers of loopback connections.
	# Here we store a: "x:p->y:q" -> ["cmd,pid"...] relationship using
	# numerical values for x,y,p,q.
	$net{$fields{n}}->{"$fields{c},$fields{p}"} = "";
      }
    }
  }
}
close LSOF;

if (!$usable_ss) {
  # if we can't use ss, revert to getting peer information from kernel memory.
  # That works pretty well even for very old systems but requires superuser
  # privileges.
  open K, "<", "/proc/kcore" or die "open kcore: $!";
  read K, $h, 8192 # should be more than enough
   or die "read kcore: $!";

  # parse ELF header
  my ($t,$o,$n) = unpack("x4Cx[C19L!]L!x[L!C8]S", $h);
  $t = $t == 1 ? "L3x4Lx12" : "Lx4QQx8Qx16"; # program header ELF32 or ELF64
  my @headers = unpack("x$o($t)$n",$h);

  # helper to read data from kcore at given address (obtaining file offset from
  # ELF @headers)
  sub readaddr {
    my @h = @headers;
    my ($addr, $length) = @_;
    my $offset;
    while (my ($t, $o, $v, $s) = splice @h, 0, 4) {
      if ($addr >= $v && $addr < $v + $s) {
	$offset = $o + $addr - $v;
	if ($addr + $length - $v > $s) {
	  $length = $s - ($addr - $v);
	}
	last;
      }
    }
    return undef unless defined($offset);
    seek K, $offset, 0 or die "seek kcore: $!";
    my $ret;
    read K, $ret, $length or die "read($length) kcore \@$offset: $!";
    return $ret;
  }

  # create a dummy socketpair to try and find the offset of the
  # peer member in the kernel structure
  socketpair(Rdr, Wtr, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
   or die "socketpair: $!";
  my $r = readlink("/proc/self/fd/" . fileno(Rdr)) or die "readlink Rdr: $!";
  $r =~ /\[(\d+)/; $r = $1;
  my $w = readlink("/proc/self/fd/" . fileno(Wtr)) or die "readlink Wtr: $!";
  $w =~ /\[(\d+)/; $w = $1;
  # now $r and $w contain the socket inodes of both ends of the socketpair
  die "Can't determine peer offset" unless $r && $w;

  # get the inode->address mapping
  my %addr;
  open U, "<", "/proc/net/unix" or die "open unix: $!";
  while (<U>) {
    if (/^([0-9a-f]+):(?:\s+\S+){5}\s+(\d+)/) {
      $addr{$2} = hex $1;
    }
  }
  close U;

  die "Can't determine peer offset" unless $addr{$r} && $addr{$w};

  # read 2048 bytes starting at the address of Rdr and hope to find
  # the address of Wtr referenced somewhere in there.
  my $around = readaddr $addr{$r}, 2048;
  my $offset = 0;
  my $ptr_size = length(pack("L!",0));
  my $found;
  for (unpack("L!*", $around)) {
    if ($_ == $addr{$w}) {
      $found = 1;
      last;
    }
    $offset += $ptr_size;
  }
  die "Can't determine peer offset" unless $found;

  # now retrieve peer for each socket
  for my $inode (keys %addr) {
    $peer{$addr{$inode}} = unpack("L!", readaddr($addr{$inode}+$offset,$ptr_size));
  }
  close K;
}

# Now to be able to process host and service names, we need to know what
# host name the system uses for the loop back interface addresses
# (things like "localhost", "ip6-localhost"). These should work even for
# very old perls:
my ($l4) = gethostbyaddr(pack("C4",127,0,0,1), AF_INET);
my ($l6) = gethostbyaddr(pack("x15C",1), AF_INET6);
my %name_to_num = (
  $l4 => "127.0.0.1",
  $l6 => "[::1]"
);
# regexp to match localhost as IPv4 or IPv6 (numerical or name):
my $localhost = join "|", map {qr{\Q$_\E}} keys %name_to_num, values %name_to_num;
$localhost = qr{$localhost};

# and finally process the lsof output
open LSOF, '-|', 'lsof', @ARGV;
LINE: while (<LSOF>) {
  chomp;
  if ($usable_ss) {
    # we use the inode number (decimal, so we rely on it being the 3rd
    # field after "unix"
    if (/\sunix\s+\S+\s+\S+\s+(\d+)\s/) {
      my $peer = $peer{$1};
      if (defined($peer)) {
	$_ .= $peer ?
	      " ${dir{$1}} $peer\[" . (join("|", keys%{$proc{$peer}})||"?") . "]" :
	      "[LISTENING]";
	next LINE;
      }
    }
  } else {
    # we use the unix_sock address as hex number
    for my $addr (/0x[0-9a-f]+/g) {
      $addr = hex $addr;
      my $peer = $peer{$addr};
      if (defined($peer)) {
	$_ .= $peer ?
	      sprintf(" -> 0x%x[", $peer) . join("|", keys%{$proc{$peer}}) . "]" :
	      "[LISTENING]";
	next LINE;
      }
    }
  }
  # Handle TCP connections:
  if (/\s($localhost):([\w-]+)->($localhost):([\w-]+)\s/) {
    my ($a, $ap, $b, $bp) = ($1, $2, $3, $4);
    # convert to numerical form, assume 127.1 and [::1] for
    # loopback addresses
    $a = $name_to_num{$a} || $a;
    $b = $name_to_num{$b} || $b;
    (undef, undef, $ap) = getservbyname($ap, "tcp") if $ap =~ /\D/;
    (undef, undef, $bp) = getservbyname($bp, "tcp") if $bp =~ /\D/;
    my $peer = $net{"$b:$bp->$a:$ap"};
    if (defined($peer)) {
      $_ .= " -> [" . join("|", keys(%{$peer})) . "]";
    }
  }
} continue {
  print "$_\n";
}
close LSOF or exit(1);