added test to determine the uid of the remote peer

diff --git a/msva b/msva
index bfefaddfc0f5cab7cb55c534515694c8d1baf175..19d46309e5393c6e792837ac5bb71f729d40465d 100755 (executable)
--- a/msva
+++ b/msva
@@ -27,6 +27,9 @@ use strict;
   require Crypt::X509;
   use Convert::ASN1;
   use MIME::Base64;
+  use IO::Socket;
+  use IO::File;
+  use Socket;
 
   use JSON;
   use POSIX qw(strftime);
@@ -118,17 +121,120 @@ $rsa_decoder->prepare(q<
     return @out;
   }
 
-  sub handle_request {
-    my $self = shift;
-    my $cgi  = shift;
+  # return the numeric ID of the peer on the other end of $socket,
+  # returning undef if unknown.
+  sub get_remote_peer_id {
+    my $socket = shift;
 
-    # FIXME: check SO_PEERCRED -- if this was a TCP socket, Linux
+    my $sock = IO::Socket->new_from_fd($socket, 'r');
+    # check SO_PEERCRED -- if this was a TCP socket, Linux
     # might not be able to support SO_PEERCRED (even on the loopback),
     # though apparently some kernels (Solaris?) are able to.
 
+    my $remotepeerid;
+    my $socktype = $sock->sockopt(SO_TYPE) or die "could not get SO_TYPE info";
+    if (defined $socktype) {
+      msvalog('debug', "sockopt(SO_TYPE) = %d\n", $socktype);
+    } else {
+      msvalog('verbose', "sockopt(SO_TYPE) returned undefined.\n");
+    }
+
+    my $peercred = $sock->sockopt(SO_PEERCRED) or die "could not get SO_PEERCRED info";
+    my $remotepeer = $sock->peername();
+    my $family = sockaddr_family($remotepeer); # should be AF_UNIX (a.k.a. AF_LOCAL) or AF_INET
+
+    msvalog('verbose', "socket family: %d\nsocket type: %d\n", $family, $socktype);
+
+    if ($peercred) {
+      # FIXME: on i386 linux, this appears to be three ints, according to
+      # /usr/include/linux/socket.h.  What about other platforms?
+      my ($pid, $uid, $gid) = unpack('iii', $peercred);
+
+      msvalog('verbose', "SO_PEERCRED: pid: %u, uid: %u, gid: %u\n",
+              $pid, $uid, $gid,
+             );
+      if ($pid != 0 && $uid != 0) { # then we can accept it:
+        $remotepeerid = $uid;
+      }
+    }
+
     # another option in Linux would be to parse the contents of
     # /proc/net/tcp to find the uid of the peer process based on that
     # information.
+    if (! defined $remotepeerid) {
+      my $proto;
+      if ($family == AF_INET) {
+        $proto = '';
+      } elsif ($family == AF_INET6) {
+        $proto = '6';
+      }
+      if (defined $proto) {
+        if ($socktype == &SOCK_STREAM) {
+          $proto = 'tcp'.$proto;
+        } elsif ($socktype == &SOCK_DGRAM) {
+          $proto = 'udp'.$proto;
+        } else {
+          undef $proto;
+        }
+        if (defined $proto) {
+          my ($port, $iaddr) = unpack_sockaddr_in($remotepeer);
+          my $iaddrstring = unpack("H*", reverse($iaddr));
+          msvalog('verbose', "Port: %04x\nAddr: %s\n", $port, $iaddrstring);
+          my $remmatch = lc(sprintf("%s:%04x", $iaddrstring, $port));
+          my $infofile = '/proc/net/'.$proto;
+          my $f = new IO::File;
+          if ( $f->open('< '.$infofile)) {
+            my @header = split(/ +/, <$f>);
+            my ($localaddrix, $uidix);
+            my $ix = 0;
+            my $skipcount = 0;
+            while ($ix <= $#header) {
+              $localaddrix = $ix - $skipcount if (lc($header[$ix]) eq 'local_address');
+              $uidix = $ix - $skipcount if (lc($header[$ix]) eq 'uid');
+              $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
+              $ix++;
+            }
+            if (!defined $localaddrix) {
+              msvalog('info', "Could not find local_address field in %s; unable to determine peer UID\n",
+                      $infofile);
+            } elsif (!defined $uidix) {
+              msvalog('info', "Could not find uid field in %s; unable to determine peer UID\n",
+                      $infofile);
+            } else {
+              msvalog('debug', "local_address: %d; uid: %d\n", $localaddrix,$uidix);
+              while (my @line = split(/ +/,<$f>)) {
+                if (lc($line[$localaddrix]) eq $remmatch) {
+                  if (defined $remotepeerid) {
+                    msvalog('error', "Warning! found more than one remote uid! (%s and %s\n", $remotepeerid, $line[$uidix]);
+                  } else {
+                    $remotepeerid = $line[$uidix];
+                    msvalog('info', "remote peer is uid %d\n",
+                            $remotepeerid);
+                  }
+                }
+              }
+            }
+          } else { # FIXME: we couldn't read the file.  what should we
+                   # do besides warning?
+            msvalog('info', "Could not read %s; unable to determine peer UID\n",
+                    $infofile);
+          }
+        }
+      }
+    }
+    return $remotepeerid;
+  }
+
+  sub handle_request {
+    my $self = shift;
+    my $cgi  = shift;
+
+    my $remotepeerid =  get_remote_peer_id(select);
+
+    if (defined $remotepeerid) {
+      # FIXME: test that this is the same user id number, abort otherwise
+      # FIXME: maybe allow a space-separated list of allowed users from an environment variable?
+    }
 
     my $path = $cgi->path_info();
     my $handler = $dispatch{$path};