[logs] Trial SELP server implementation

betat_private

2003-01-09T18:25:24 Bennett Todd:
> I hope to crank out the server tomorrow, time permitting.

"Hacking --- it's not just a job, it's an obsession".

Here's that server. Likewise probably has more room for improvement;
I expect I'll add code to perform validation on the hostname part
(although that'll force me to figure out all the permissible
representations of IPv6 addrs, which I've yet to actually learn:-);
and I'll probably make this debugging tool explicitly quote any
characters it finds in the MSG that aren't printable US-ASCII, just
because I am what I am:-).

But this might just be enough now to be comfortable as a protocol
testbed.

-Bennett

#!/usr/bin/perl -w
use strict;

=head1 NAME

  selpd --- test daemon for SELP protocol

=head1 SYNOPSIS

  selpd [--port=127.0.0.1:1514]

=head1 DESCRIPTION

selpd binds to the indicated port, and accepts TCP connections.
It's a straightforward iterating daemon --- only one connection
is serviced at a time. If a connection is attempted while one is
already active, the OS queues it. selpd prints each complete record
it receives to stdout. The <PRI> is decoded. The timestamp is
validated; if it is in RFC 3164 format it's recoded into RFC 3999
format with the local timezone appended.

=cut

use Getopt::Long;
my $port = "127.0.0.1:1514";
my $syntax = "selpd [--port=$port]\n";
GetOptions("port=s" => \$port) || die $syntax;

use IO::Socket::INET;
my $sock = IO::Socket::INET->new(
    LocalAddr => $port,
    Proto => 'tcp',
    Listen => 65536,
) or die "$0: socket bind failed: $!\n";

$| = 1;

use Date::Parse;
use POSIX qw(strftime);

session: while (my $s = $sock->accept()) {
    line: while (defined($_ = $s->getline)) {
	chomp; s/\r$//;
	if (/^<(\d{1,3})>(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}(?:\.\d+)?(?:Z|[+-]\d{4})) (\S+) (.*)/) {
	    my ($prio, $ts, $host, $msg) = ($1, $2, $3, $4);
	    $prio = prio_decode($prio);
	    print "<$prio>$ts $host $msg\n";
	    next line;
	}
	if (/^<(\d{1,3})>([A-Z][a-z][a-z] [0-9 ]\d \d{2}:\d{2}:\d{2}) (\S+) (.*)/) {
	    my ($prio, $ts, $host, $msg) = ($1, $2, $3, $4);
	    $prio = prio_decode($prio);
	    $ts = strftime("%Y-%m-%dT%H:%M:%S%z", localtime(str2time($ts)));
	    print "<$prio>$ts $host $msg\n";
	    next line;
	}
	print "misformatted message: $_\n"
    }
}

sub prio_decode {
    my ($prio) = @_;
    local(*_);

    # These are taken from syslog.h, plus cross-checked and filled out
    # from RFC 6134
    my @priority = qw(emerg alert crit err warning notice info debug);
    my @facility = qw(
	kern user mail daemon auth syslog lpr news uucp cron authpriv
	ftp ntp audit alert cron2 local0 local1 local2 local3 local4
	local5 local6 local7
    );

    my $priority = ($prio & 0x07);
    my $facility = ($prio >> 3);
    if ($facility <= $#facility) {
	return ($facility[$facility] . '.' . $priority[$priority]);
    } else {
	return ("unknown$facility" . '.' . $priority[$priority]);
    }
}