#!/usr/bin/env perl

# Copyright (c) 2015 Christian Jaeger, copying@christianjaeger.ch
# This is free software. See the file COPYING.md that came bundled
# with this file.


# Fancy (but only?) way to enable taint mode, while also bouncing off
# /usr/bin/env: (thanks to spm and Zefram)
BEGIN {
    if (!${^TAINT}) {
	exec $^X, '-T', '--', $0, @ARGV
	  or die "exec '$^X': $!";
    } else {
	# trust PERL5LIB:
	if (my $lib= $ENV{PERL5LIB}) {
	    my @paths= $lib=~ m{([^:]+)(?::|\z)}sg;
	    unshift @INC, @paths;
	}
    }
}

use strict; use warnings; use warnings FATAL => 'uninitialized';
use Function::Parameters ':strict';
use Sub::Call::Tail;

# find modules from functional-perl working directory (not installed)
use Cwd 'abs_path';
our ($mydir, $myname); BEGIN {
    my $location= (-l $0) ? abs_path ($0) : $0;
    $location=~ /(.*?)([^\/]+?)_?\z/s or die "?";
    ($mydir, $myname)=($1,$2);
}
use lib "$mydir/../lib";

use FP::Untainted;
# trust PATH
$ENV{PATH}= untainted $ENV{PATH};


our @tailcmd= qw(tail --follow=name --retry --lines=0);

sub usage {
    print "usage: $myname path/to/config.pl

  config.pl should return (have as its last expression) a hash with
  these keys:

  +{
   logfile=> 'path/to/file',
   match=> sub { my (\$line)=\@_; \$line=~ /some_regex/ },
   collecttime=> 1200, # seconds
   report=> report_mailto('system\@example\.com', 'admin\@example.com'),
  }

  Runs `@tailcmd -- \$\$config{logfile}`,
  collects all lines that match the given predicate, and after
  \$\$config{collecttime} seconds have passed since the first such
  line, passes a file path containing the lines to the subroutine in
  \$\$config{report}; 'report_mailto(\$from, \$to)' returns such a sub
  that then mails the contents of that file to the given \$to email
  address, with '$myname path/to/config.pl' as the subject and \$from
  as the sender.

";
    exit 1;
}

use Getopt::Long;
our $verbose=0;
GetOptions("verbose"=> \$verbose,
	   "help"=> sub{usage},
	   ) or exit 1;
usage unless @ARGV==1;

our ($configpath)= @ARGV;

# move to lib?

use FP::IOStream qw(fh_to_stream);
use FP::Ops qw(the_method);

fun fh_to_linestream ($fh, $close) {
    fh_to_stream $fh, the_method ("xreadline"), $close
}

use Time::HiRes qw(time sleep);

fun sleep_until ($unixtime) {
    my $t= time;
    my $seconds= $unixtime - $t;
    if ($seconds > 0.01) {
	sleep $seconds;
	tail sleep_until ($unixtime);
    }
}

use Chj::xperlfunc;

sub forked (&) {
    my ($thunk)=@_;
    if (my $pid= xfork) {
	$pid
    } else {
	&$thunk();
	exit 0;
    }
}

# /lib

use Scalar::Util qw(weaken);
use Sys::Hostname qw(hostname);
use Chj::xopen;
use Chj::IO::Command;
use Chj::xpipe;
use Chj::singlequote;
use FP::Show;
#use Chj::Trapl; # or Chj::Backtrace
#use Chj::repl;


fun safe_for_mail ($str) {
    $str=~ /^([^\r\n\t]*)\z/s ? $1
      : die "not safe for mail: ".show($str);
    # (should really escape instead, but don't want to make it
    # complex)
}

# to be accessible by code at $configpath (hacky?)
fun report_mailto ($from, $to) {
    my $_from= safe_for_mail ($from);
    my $_to= safe_for_mail ($to);
    fun ($path) {
	my $sendmail= Chj::IO::Command->new_receiver ("sendmail","-t");
	my $in= xopen_read ($path);
	$sendmail->xprintln("From: $_from");
	$sendmail->xprintln("To: $_to");
	$sendmail->xprintln("Subject: "
			    .safe_for_mail($myname)." "
			    .safe_for_mail($configpath));
	$sendmail->xprintln;
	$sendmail->xprintln("$0 on ".hostname()." found the following log messages:");
	$sendmail->xprintln;
	$sendmail->xflush;
	$in->xsendfile_to ($sendmail);
	$in->xclose;
	$sendmail->xxfinish;
	unlink $path;
    }
}

fun require_config ($path) {
    my $arg= untainted( $path=~ m|^\.{0,2}/| ? $path : "./$path" );
    require $arg
}

use Hash::Util 'lock_hash';
my $config= require_config $configpath;
# (btw unlike 'eval' this doesn't give the code in question access to
# lexicals, right?)
lock_hash %$config;



my $REPORTMSG= "REPORT-".rand(); # XX not enough randomness

my ($r,$w)=xpipe;

use Chj::xtmpfile;

fun xtmpfile_noautoclean () {
    my $t= xtmpfile;
    $t->autoclean(0);
    $t
}

fun processlines_ ($lines, $out, $maybe_reporterpid) {
    weaken $_[0];
    my ($line,$rest)= $lines->first_and_rest;
    warn "line='$line', maybe_reporterpid=".singlequote($maybe_reporterpid)
      if $verbose;
    if ($line=~ /^$REPORTMSG/) {
	warn "REPORT!"
	  if $verbose;
	# XX is it really guaranteed that lines are never broken
	# apart?
	$out->xclose;
	$$config{report}->($out->path);
	xxwaitpid $maybe_reporterpid;
	tail processlines_ ($rest, xtmpfile_noautoclean, undef)
    } else {
	if ($$config{match}->($line)) {
	    my $t_report= time + $$config{collecttime};
	    $out->xprint($line);
	    tail processlines_ ($rest,
				$out,
				$maybe_reporterpid // forked {
				    $r->xclose;
				    sleep_until $t_report;
				    $w->xprintln ($REPORTMSG);
				    $w->xclose;
				    warn "sent $REPORTMSG"
				      if $verbose;
				});
	} else {
	    tail processlines_ ($rest, $out, $maybe_reporterpid)
	}
    }
}

fun processlines ($lines) {
    weaken $_[0];
    processlines_ ($lines, xtmpfile_noautoclean, undef)
}


my $tailpid= forked {
    $r->xclose;
    $w->xdup2(1);
    xexec @tailcmd,"--", $$config{logfile};
};

my $lines= fh_to_linestream
  ($r,
   fun ($fh) {
       $fh->xclose;
       xxwait $tailpid;
   });

processlines $lines;

