#!/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 FP::Repl::Trap; # or Chj::Backtrace
#use FP::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;

