hackman has asked for the wisdom of the Perl Monks concerning the following question:

Hello guys, I'm writing a simple UNIX socket daemon and I want the daemon to be able to read the UID/GID/PID of the connecting process. Since this is defined in unix(7) I was expecting to find some easy way of doing it in perl. However I don't seam to find any examples on how I can implement it in Perl. Here is the most significant bit of my perl socket server: 
use constant SOCK_PATH => '/tmp/catsock';

socket(Server, AF_UNIX, SOCK_STREAM,0) or die "socket: $!";
setsockopt(Server, SOL_SOCKET, SO_PASSCRED, 1) or die "SO_PASSCRED: $!
+\n";
unlink(SOCK_PATH);
bind  (Server, sockaddr_un(SOCK_PATH)) or die "bind: $!";
listen(Server, SOMAXCONN) or die "listen: $!";

for ( $waitedpid = 0; accept(Client,Server) || $waitedpid; $waitedpid 
+= 0, close Client) {
    next if $waitedpid;
    my $n = unpack_sockaddr_un(getsockname(Client));
    logmsg 'peer: ' . $n . "\n" . <Client>;
}

[download]
I wish to have something similar to this C function: 
int svc_recv(int fd, char *buffer, size_t size, struct ucred *cred) {
        char            control[1024];
        struct msghdr   msg;
        struct cmsghdr  *cmsg;
        struct iovec    iov;
        int             result;

        memset(&msg, 0, sizeof(msg));
        iov.iov_base = buffer;
        iov.iov_len = size;
        msg.msg_iov = &iov;
        msg.msg_iovlen = 1;
        msg.msg_control = control;
        msg.msg_controllen = sizeof(control);

        if (recvmsg(fd, &msg, 0) < 0)
                return -1;

        result = -1;
        cmsg = CMSG_FIRSTHDR(&msg);
        while (cmsg != NULL) {
                if (cmsg->cmsg_level == SOL_SOCKET
                 && cmsg->cmsg_type  == SCM_CREDENTIALS) {
                        memcpy(cred, CMSG_DATA(cmsg), sizeof(*cred));
                        result = iov.iov_len;
                } else
                if (cmsg->cmsg_level == SOL_SOCKET
                 && cmsg->cmsg_type  == SCM_RIGHTS) {
                        dispose_fds((int *) CMSG_DATA(cmsg),
                                (cmsg->cmsg_len - CMSG_LEN(0))/sizeof(
+int));
                }
                cmsg = CMSG_NXTHDR(&msg, cmsg);
        }

        return result;
}

[download]
One Planet, One Internet... We Are All Connected...

Replies are listed 'Best First'.
Re: How to read UNIX socket credentials?
by hackman (Acolyte) on Jan 07, 2011 at 05:19 UTC
    Monks, this is how I implemented a solution for the above problem: 
    use strict;
use warnings;
use IO::Socket;
use IO::Handle::Record;
$| = 1;
unlink('/tmp/catsock');
my $server = new IO::Socket::UNIX(
    Type => SOCK_STREAM,
    Local => '/tmp/catsock',
    Listen => SOMAXCONN
);
die "Coudn't open socket" unless $server;
my $client;
my $count = 0;
while(1) {
    $client = $server->accept();
    my ($pid, $uid, $gid) = $client->peercred;
    # name, pass, uid, gid, quota, comment, gcos, dir, shell, expire
    my @uinfo = getpwuid($uid);
    print "$count. Credentials User: $uinfo[0] PID: $pid UID: $uid GID
+: $gid\n" . <$client> . "\n";
    $count++;
}

    [download]
    However, I would really like to see how this can be implemented without using IO::Socket::UNIX.
    Or is it at all possible.
    One Planet, One Internet... We Are All Connected...
[reply]
[d/l]

      Pretty sure it'll work with an unblessed UNIX socket handle too. 

      my ($pid, $uid, $gid) = IO::Handle::Record::peercred($client);

      [download]

      If not, it should be easy to code in pure Perl since the above function is simply 

      void
smh_peercred(s)
    PerlIO* s;
PROTOTYPE: $
PPCODE:
{
# ifdef SO_PEERCRED
  struct ucred uc;
  socklen_t uc_len=sizeof(uc);

  if( !getsockopt(PerlIO_fileno(s), SOL_SOCKET, SO_PEERCRED, &uc, &uc_
+len) ) {
    EXTEND(SP, 3);
    PUSHs(sv_2mortal(newSViv(uc.pid)));
    PUSHs(sv_2mortal(newSViv(uc.uid)));
    PUSHs(sv_2mortal(newSViv(uc.gid)));
  }
# else
  SETERRNO(EOPNOTSUPP, RMS_IFI);
# endif
}

      [download]

      and fileno (builtin), getsockopt (builtin), SOL_SOCKET (Socket) and SO_PEERCRED (Socket) are all in core Perl.

      Mind you, IO::Socket::UNIX is just a thin layer that greatly simplifies socket calls with no loss of flexibility, so I wonder why you want to try to avoid it.

[reply]
[d/l]
[select]
        my ($pid, $uid, $gid) = IO::Handle::Record::peercred($client);

        [download]
        Thank you for the solution! It works like a charm on Linux and FreeBSD.
        One Planet, One Internet... We Are All Connected...
[reply]
[d/l]
      A problem might be that SCM_CREDENTIALS is not in the POSIX standard as an option. The option is specific to Linux, although BSD appears to have a similar option called SCM_CREDS (untested).
[reply]

Back to Seekers of Perl Wisdom