# mocksyslogserver.pl.

use strict;
use warnings;
use IO::Socket::INET;
use IO::Select;
use Sys::Hostname ();
use Time::HiRes   ();
use Getopt::Std   ();

# A mock syslog server.
# XXX: Could not find a way to find the length of the syslog message
# without parsing it.
# I am not aware of a guaranteed syslog "termination character"
# to indicate the syslog message is complete
# ... though terminating all messages with '\0' seems common.

my $SYSLOG_MIN_HDR_LEN = 1;
my $SYSLOG_MAX_MSG_LEN = 1024;

# From https://tools.ietf.org/html/rfc5424 (Syslog protocol).
#
#  The syslog protocol does not provide acknowledgment of message
#  delivery.  Though some transports may provide status information,
#  conceptually, syslog is a pure simplex communications protocol.
#  Note: Simplex = send in one direction only

sub usage
{
   print <<'DARLING_FASCIST_BULLY_BOY';

A mock syslog server.

usage: mocksyslogserver [-a accept-sleep-secs] [-r recv-sleep-secs] -p port

Examples:
  mocksyslogserver -p 9949           Normal syslog server.
                                     Start up mock syslog server on port 9949.

  mocksyslogserver -p 9949 -a 3      Listen on port 9949, then sleep for 3
                                     secs after client accepts.

  mocksyslogserver -p 9949 -r 3      Listen on port 9949, then sleep for 3
                                     secs after each recv from client.

DARLING_FASCIST_BULLY_BOY
   exit 1;
}

sub get_datetime_stamp
{
   my ( $s, $m, $h, $d, $mon, $y ) = localtime;
   sprintf( "%02d:%02d:%02d", $h, $m, $s );
}

# -----------------------------------------------------------------
# Perl network programming notes
# ------------------------------
# Reading can be done with:
#  1) <$sock> - blocks till new line
#  2) read($sock, $buf, $len) - blocks till $len bytes received
#                               (like W Richard Stevens readn function in C)
#  3) sysread($sock, $buf, $len) - may return less than asked for
#                                  (like read()/recv() in C)
# -----------------------------------------------------------------

# Return undef if client closed the $client socket.
sub recv_tcp_client
{
   my $client = shift;

   my $peerhost = $client->peerhost();
   my $peerport = $client->peerport();

   # my $peeraddr     = $client->peeraddr();
   # my $peerhostfull = gethostbyaddr( $peeraddr, AF_INET ) || "Cannot resolve";

   # my $fromstr = "from $peerhost:$peerport (host=$peerhostfull) ";
   my $fromstr = "from $peerhost:$peerport ";

   my $data;

   # This one blocks until newline received.
   # $data = <$client>;

   #  This one blocks till $len bytes received (like Stevens readn function in C)
   # my $hdr;
   # my $hdrlen = read( $client, $hdr, $SYSLOG_HDR_LEN );

   # This one may return less than asked for (like read()/recv() in C)
   # XXX: When we receive a '\0' we know the message is complete?
   my $msglen = sysread( $client, $data, $SYSLOG_MAX_MSG_LEN );

   # XXX: For now, just remove any NULLs in received data
   my $numnull = $data =~ tr/\0//d;

   if ( !defined($msglen) )
   {
      print '[Recv] ' . get_datetime_stamp() . ": $fromstr" . "<undef> read error: $!\n";
      sleep(1);
      return;
   }
   if ( $msglen == 0 )
   {
      print '[Recv] ' . get_datetime_stamp() . ": $fromstr" . "read hdr eof\n";
      sleep(1);
      return;
   }
   if ( $msglen < $SYSLOG_MIN_HDR_LEN )
   {
      warn "error: read less than min bytes ($msglen < $SYSLOG_MIN_HDR_LEN)\n";
   }

   print '[Recv] '
      . get_datetime_stamp()
      . ": $fromstr"
      . "read data ok (len=$msglen, null=$numnull)\n";
   print '[Recv] ' . get_datetime_stamp() . ': ' . "$data:\n";

   # Check for any "weird" characters (10=LF, 13=CR).
   # Note that syslog messages terminated with '\0'?
   my @ord_chars = map {ord} split //, $data;
   my @weird = grep { $_ != 10 && $_ != 13 && ( $_ < 32 || $_ > 126 ) } @ord_chars;
   my $nweird = @weird;
   if (@weird)
   {
      my $s = join "", map { '(' . ( $_ >= 32 && $_ <= 126 ? chr() : "" ) . ",ord=$_)" } @ord_chars;

      print "[Recv] $nweird weird ord chars were detected in the previous line:\n";

      # print "[Recv] $s\n";
      # my $last_ord = $ord_chars[-1];
      # print "[Recv] weird : '@weird' (last_ord='$last_ord')\n";
   }

   return $data;
}

# Note: send_client is not used for (simplex) syslog protocol
sub send_client
{
   my $client = shift;
   my $str    = shift;
   print '[Send] ' . get_datetime_stamp() . ': ' . $str . ":\n";
   print {$client} $str or die "error: print: $!";
}

sub my_log
{
   my $str = shift;
   print '[Info] ' . get_datetime_stamp() . ': ' . $str;
}

sub do_syslog_server
{
   my $host               = shift;
   my $port               = shift;
   my $sleep_after_accept = shift;
   my $sleep_after_recv   = shift;

   my_log( "Start on host '$host' at " . get_datetime_stamp() . "\n" );
   my_log("  pid=$$\n");
   my_log("  port=$port\n");
   my_log("  sleep_after_accept=$sleep_after_accept\n");
   my_log("  sleep_after_recv=$sleep_after_recv\n");

   # This socket is used to listen for connections.
   my $listener = IO::Socket::INET->new(
      LocalPort => $port,
      Proto     => 'tcp',
      Listen    => 5,
      ReuseAddr => 1,
   ) or die "error: IO::Socket::INET new: $@";

   my $selector = IO::Select->new($listener);

SERVER:
   while ( my @ready = $selector->can_read() )
   {
   CLIENT:
      for my $client (@ready)
      {
         if ( $client == $listener )
         {
            my $new_conn = $listener->accept();
            $selector->add($new_conn);
            my $fh_hex = sprintf '0x%x', $new_conn;

            my $peerhost = $new_conn->peerhost();
            my $peerport = $new_conn->peerport();

            my $peeraddr = $new_conn->peeraddr();
            my $peerhostfull = gethostbyaddr( $peeraddr, AF_INET ) || "Cannot resolve";

            my $fromstr = "from $peerhost:$peerport (host=$peerhostfull)";

            my_log("Accepted new connection $fromstr\n");
            if ($sleep_after_accept)
            {
               my_log("Sleeping for $sleep_after_accept seconds...\n");
               sleep($sleep_after_accept);
            }
         }
         else
         {
            my $cli_cmd_str = recv_tcp_client($client);
            if ( !defined($cli_cmd_str) )
            {
               my $peerhost = $client->peerhost();
               my $peerport = $client->peerport();
               my_log("Client $peerhost:$peerport closed socket\n");
               $selector->remove($client);
               $client->close();
               next CLIENT;
            }
            if ( $cli_cmd_str =~ /^SERVER_PLEASE_QUIT\s*$/ )
            {
               my_log("Server quitting on your command\n");
               last SERVER;
            }
            if ($sleep_after_recv)
            {
               my_log("Sleeping for $sleep_after_recv seconds...\n");
               sleep($sleep_after_recv);
            }
         }
      }
   }

   my_log("Closing server\n");
   close($listener) or die "error: close server: $!";
   my_log("End do_syslog_server\n");
}

local $| = 1;
my $myhostname = lc( Sys::Hostname::hostname() );

my $port               = 0;    # -p switch
my $sleep_after_accept = 0;    # -a switch
my $sleep_after_recv   = 0;    # -r switch

my %option = ();
Getopt::Std::getopts( "p:a:r:", \%option ) or usage();
usage() if $option{h};
if ( $option{p} )
{
   $port = $option{p};
   $port =~ /^\d+$/ or die "error: invalid -p: '$port'\n";
}
if ( $option{a} )
{
   $sleep_after_accept = $option{a};
   $sleep_after_accept =~ /^\d+$/
      or die "error: invalid -a: '$sleep_after_accept'\n";
}
if ( $option{r} )
{
   $sleep_after_recv = $option{r};
   $sleep_after_recv =~ /^\d+$/
      or die "error: invalid -r: '$sleep_after_recv'\n";
}
usage() if $port <= 0;
usage() if $sleep_after_accept < 0;
usage() if $sleep_after_recv < 0;
@ARGV and usage();

do_syslog_server( $myhostname, $port, $sleep_after_accept, $sleep_after_recv );