Path: utzoo!utgpu!news-server.csri.toronto.edu!mailrus!ames!fxgrp!grady
From: grady@fx.com (Steven Grady)
Newsgroups: comp.lang.perl
Subject: inetd in perl
Message-ID: <1990Jul7.030248.11160@fxgrp.fx.com>
Date: 7 Jul 90 03:02:48 GMT
Sender: news@fxgrp.fx.com (News)
Reply-To: grady@postgres.berkeley.edu
Organization: FXD/Telerate, Mountain View, CA
Lines: 222

Because I don't think I'll be spending much time hacking on this in the
near future, I figured I'd post this now.  This is a version of inetd
written in perl.  It parses BSD/SunOS-style inetd.conf files. It is
intended to allow individual (non-root type) users to run their own
servers -- a feature sorely lacking in standard versions.  Other
than allowing you to specify your own configuration file, it supports
numbered services as well as names.  It handles tcp (stream) and udp
(dgram), wait and nowait sockets.  No RPC or internal services.  The
two main problems are that it doesn't set the uid (trivial to add, but
I don't have the time or the need), and it can't set argv[0] (since
perl doesn't seem to let you do that). The closest I've come is to
replace argv[0] in the command with the specified server.  This may or
may not be adequate.

I haven't spent time cleaning this up, so it could probably use quite
a bit of polishing.  I encourage people to hack on it and improve it.

Here's a sample inetd.conf that I used when testing it
(Mind you, I had to remove comsat from the real inetd.conf
to test this completely.)

# Test for perl inetd
# Service   socket-type protocol wait-st uid	server-prog   arguments
4444		stream	tcp	nowait	grady	/bin/cat
4455		stream	tcp	nowait	grady	/bin/csh -if
comsat		dgram	udp	wait	grady	/tmp/comsat.pl

(BTW, comsat.pl would cat an audio file of a cow mooing to the
speaker of my sparcstation every time I got mail.  My officemates
got annoyed pretty quick.. Also, I had to run it as root to bind
to the comsat port.)

You'll need to use makelib (in the perl distribution) to create
sys/socket.h and sys/errno.h.

Enjoy.

	Steven

#!/usr/share/new/bin/perl

# Usage:
#	inetd.pl [-d] [conf file]
#	-d: debug
#	conf file: configuration file (defaults to /etd/inetd.conf)

# Todo:
#	Use uid
#	Close all file descriptors before exec'ing
#	statuses from exited children
# Problems:
#	Can't have argv[0] different from server path

do 'sys/socket.h' || die "can't do sys/socket.h: $@";
do 'sys/errno.h' || die "can't do sys/errno.h: $@";
do 'getopts.pl' || die "couldn't find getopts.pl";

$SIG{'CHLD'} = 'reapchild';

$sockaddr = 'S n a4 x8';
$fileDescs = '';
do Getopts('d');
$debug = $opt_d;

($conf) = @ARGV;
$conf = "/etc/inetd.conf" unless $conf;

# Read the entries from the configuration file.
open(conf, "<$conf") || die "open: $conf: $!";
while (<conf>) {
    next if (/^#/ || /^$/);
    ($service, $sockettype, $proto, 
	    $waitstatus, $uid, $server, @commandlist) = split;
    push (@services, $service);
    $sockettype{$service} = $sockettype;
    $proto{$service} = $proto;
    $waitstatus{$service} = $waitstatus;
    $uid{$service} = $uid;
    if ($commandlist[0] ne $server) {
	$commandlist[0] = $server;
    }
    $command{$service} = join(' ', @commandlist);
}
close(conf);

# Begin each service in the conf file.
foreach $service (@services) {
    &addBits(&startService($service));
}

# Main loop
$| = 1;
while (1) {
    print "fileDescs:  ", &printVec($fileDescs), "\n" if $debug;
    $nfound = select($rout = $fileDescs, undef, undef, undef);
    if ($nfound == -1) {
	if ($! == &EINTR) {
	    next;
	} else {
	    die "select: $!";
	}
    }
    print "rout:  ", &printVec($rout), ", " if $debug;
    foreach $service (@services) {
	if (vec($rout, $fileno{$service}, 1)) {
	    print "$service ready\n" if $debug;
	    &spawn($service);
	}
    }
}

# Start an individual service.
sub startService {
    local($serviceName) = @_;

    print "starting service $serviceName...\n" if ($debug);

    $protoName = $proto{$serviceName};
    ($pname, $paliases, $proto) = getprotobyname($protoName);
    die "Couldn't get proto by name $protoName: $!" if ($pname eq "");

    if ($serviceName =~ /\d+/) {
	$port = $serviceName;
    } else {
	print "Getting service from ($serviceName, $proto)\n" if $debug;
	($name, $aliases, $port) = getservbyname($serviceName, $protoName);
	die "Couldn't get by name $serviceName: $!" if ($name eq "");
    }

    if ($sockettype{$serviceName} eq "stream") {
	$socktype = &SOCK_STREAM;
    } elsif ($sockettype{$serviceName} eq "dgram") {
	$socktype = &SOCK_DGRAM;
    } else {
	$socktype = -1;
    }

    $name = pack($sockaddr, &AF_INET, $port, "\0\0\0\0");
    socket($service, &PF_INET, $socktype, $proto) || 
	    die "socket ($serviceName): $!";
    print "binding to port $port.\n" if $debug;
    bind($service, $name) || die "bind($serviceName): $!";
    if ($socktype == &SOCK_STREAM) {
	listen($service, 10) || die "listen($serviceName): $!";
    }
    $fileno{$service} = fileno($service);
}

# Utility functions to deal with select() bit arguments.
sub addBits {
    local($fd) = @_;
    vec($fileDescs, $fd, 1) = 1;
}

sub delBits {
    local($fd) = @_;
    vec($fileDescs, $fd, 1) = 0;
}

# Start a new server.
sub spawn {
    local($service) = @_;
    local($stream) = ($sockettype{$service} eq "stream");
    # Only datagram sockets can be 'wait'.
    local($wait) = ($waitstatus{$service} eq "wait" && (! $stream));
    local($fd);

    if ($wait) {
	$fd = $service;
    } else {
        accept($fd, $service) || die "accept: $!";
    }

    print "Running: " . $command{$service} . "\n";
    $pid = fork;
    if (! $pid) {
	select($fd);
	$| = 1;

	# I'd like to do `open(STDIN, "<&$fd")..', but that's not allowed.
	$inputStr = "<&" . fileno($fd);
	$outputStr = ">&" . fileno($fd);

	close(STDIN); open(STDIN, $inputStr) || die "open STDIN: $!";
	close(STDOUT); open(STDOUT, $outputStr) || die "open STDOUT: $!";
	# Die can't print an error, since STDERR is closed..
	close(STDERR); open(STDERR, $outputStr) || die;
	exec split(' ', $command{$service});
    } else {
	if ($wait) {
	    $serviceof{$pid} = $service;
	    &delBits($fileno{$service});
	} else {
	    close($fd);
	}
    }
}

# When a child dies, if it's a "wait" server, put the file descriptor
#   for the child back in the select mask.
sub reapchild {
    while (1) {
	print "Reaping child\n";
	$pid = wait;
	last if ($pid == -1);
	$service = $serviceof{$pid};
	last unless $service;
	print "$service restored\n" if $debug;
	&addBits($fileno{$service});
    }
}

# Debugging subroutine.
sub printVec {
    local($v) = @_;
    local($i, $result);

    for ($i = (8*length($v)) - 1; $i >= 0; $i--) {
	$result .= (vec($v, $i, 1)) ? "1" : "0";
    }
    $result;
}