orgvm - virtual infrastructure orchestration workbook

#!/usr/bin/env perl
# 
# 

use strict;
use warnings qw[all];
use feature qw[say];
use IO::Async::Loop;
use IO::Async::Socket;
use JSON::MaybeXS;
use LWP;
use URI::Escape;
use File::Basename qw[basename dirname];
use Getopt::Long;
use Pod::Usage;

#avoid buffering output;
STDOUT->autoflush;
STDERR->autoflush;

## vars

# the port to listen on
my $port = $ENV{PORT} || 17970;
# access controls
# accept any name or IP that exists, when empty accept any
my %accept_hosts = ();

# reject from any name or IP that exists
my %reject_hosts = ();

  # keys are values to accept for project, when empty accept any
  my @projects = qw[emacs erc dungeon test-proj cc-test-proj];
  my ( $PROGRAM ) = basename $0, qw[.pl];
  my $VERSION = '0.0.1';
  my $DEBUG = 1; # any truthy value for more output, sent to STDOUT
  my ( $default_output_path ) = ( dirname $0 ) . q(/log);
  my $man = 0;
  my $help = 0;

  GetOptions(
      'help|?' => \$help, man => \$man,

      'program=s' => \$PROGRAM,
      'version=s' => \$VERSION,
      'debug!'    => \$DEBUG,

      'port=i' => \$port,
      'accept=s' => \%accept_hosts,
      'reject=s' => \%reject_hosts,
      'project=s' => \@projects,
      'any-project' => sub { @projects = () },
      'basedir=s' => \$default_output_path,
  ) or pod2usage(2);
  pod2usage(1) if $help;
  pod2usage(-exitval => 0, -verbose => 2) if $man;

  my ( $output_path ) = @ARGV ? (@ARGV) : $default_output_path;

  # output path must exist
  unless (-e $output_path && -r _) {
    die qq(Missing or unreadable output path "$output_path"\n).
        qq(Usage:  $0 [ /path/to/jsonl ]\n);
  }

  # cache existance of reject and accept lists
  my %projects = map { $_ => 1 } map { split /[,;\s]/ } @projects;
  my $accept_any_project = %projects < 1;

  my $no_accept_list = %accept_hosts < 1;
  my $no_acls_exist = $no_accept_list && %reject_hosts < 1;

## start
my $loop = IO::Async::Loop->new;

my $socket = IO::Async::Socket->new(
   on_recv => sub {
      my ( $self, $dgram, $addr ) = @_;
      # ZZZ: fail2ban?

      # parse the datagram
      chomp($dgram);
      $DEBUG and warn 'RECV:', $dgram, "\n";

      # source ADDR check
      unless ($no_acls_exist or not exists $reject_hosts{$addr}
              && ($no_acls_exist or exists $accept_hosts{$addr})) {
        $DEBUG and warn 'RJCT:',$addr,qq[\Q$dgram\E],"\n";
        return;
      }

      my ( $project, $context, $revision, $author, $logline ) =
        split /[\s]+/ms, $dgram, 5;

      # content validations
      unless ($project and $context and $revision and $author and $logline
              and $revision =~ /^\b[0-9a-f]{5,40}$/
              and ($accept_any_project
                   or exists $projects{$project})) {
        $DEBUG and warn 'RJCT:',$addr,qq[\Q$dgram\E],"\n";
        return;
      }

      my $jsonl_file = sprintf( '%s/%s.jsonl', $output_path, $project );
      open my $fh, '>>', $jsonl_file
        or do {
          warn qq[ERR opening [[$jsonl_file][$@ $?]]:$dgram\n];
          return;
        };

      # touch-ups

      # rtrim commit message
      $logline =~ s/[\s.]+$//m;

      # ltrim all leading semi-colon, star, and space like chars
      $logline =~ s/^[\s;*]+//s;

      my $line  = encode_json({ project  => $project,
                                context  => $context,
                                revision => $revision,
                                author   => $author,
                                message  => $logline,
                              })
        . "\n";
      $DEBUG and warn qq(JSON:$line);

      $fh->print( $line ) or warn qq[ERR writing [[$jsonl_file][$@ $?]]:$dgram\n]
    }
);
$loop->add( $socket );

print "Starting..";

$socket->bind( service => $port, socktype => 'dgram' )
  ->then(sub{ say "listening on $port" })->get;

$loop->run;

__DATA__

=head1 NAME

udp-line-receiver - receive via UDP and write a jsonl per project

=head1 SYNOPSIS



=head1 ALL OPTIONS

=over 8

=item B<-any-project>

Enable logging for any project.

=item B<-basedir>

When no FOLDER is given, sets the base directory for a folder of JSON
logs containing one file per project for which at least one message
has been accepted.

=item B<-help>

Print a brief help message and exits.

=item B<-man>

Prints the manual page and exits.

=item B<-no-debug>

Disble debugging messages

=item B<-port>

Defines the UDP port to listen on, by default 17970.

=item B<-project NAME>

Enable logging for project NAME.

=item B<-program NAME>

Set the program name to NAME.

=item B<-version VERSION>

Set the project version to VERSION

=back

=head1 DESCRIPTION

Read from a UDP port and write accepted message into a JSONL file
based on the value of the first field of the message.



=head1 LICENSE



=cut

sub fail_with ($$) {
  my ( $q, $status ) = @_;
  print $q->header( -status => $status );
  exit;
}
my $q = new CGI;

my ($project) = ($q->param('project') || $q->param('p') || ''

                ) =~ $value_re;
my $data_file = $data_path . '/' . $project . '.jsonl';

fail_with $q, q(401 Bad project)
  unless $project
    and ($allow_any_project || exists $projects{$project})
    and -r $data_file;

my ($filter) = ($q->param('branch') || $q->param('b') || ''
               ) =~ $branch_re;

my $command = $filter ? qq(grep -F '"context":"$filter"' $data_file | tail -1)
                      : qq(tail -1 $data_file);

my ($prop) = ($q->param('property') || $q->param('prop') || $q->param('P') || ''
             ) =~ $value_re;

$command .= qq( | jq -r '.$prop') if $prop;

my $result = `($command)  2>/dev/null`;

print $q->header( -type => q(application/json) ), $result || 'null'