#! /usr/bin/perl
# fixscript will replace this line with code to load INN::Config

#  Copyright Andreas Lamrecht 1998
#  <Andreas.Lamprect@siemens.at>
#
#  Modified by Kjetil T. Homme 1998, 2000
#  <kjetilho@ifi.uio.no>
#
#  Modified by Robert R. Collier 1998
#  <rob@lspace.org>
#
#  bigint support added by Duane Currie (sandman@hub.org) 1998
#
#  Various bug fixes, code and documentation improvements since then
#  in 1999-2004, 2007-2011, 2014-2016, 2019, 2021-2024.

use strict;
use warnings;

use Getopt::Long;
use Math::BigInt;
use Math::BigFloat;

# We're using $POSTMATCH so we cannot use -no_match_vars.
# Anyway, Perl 5.20.0 fixed the speed issue.
use English;    ## no critic (Modules::RequireNoMatchVarsWithUseEnglish)

my $conffile = "$INN::Config::pathetc/cycbuff.conf";
my $storageconf = "$INN::Config::pathetc/storage.conf";
my $lastconftime = 0;

$0 =~ s!.*/!!;

my $usage = "Usage:
  $0 [-ahpPsv] [-c class] [-i seconds] [-l [seconds]] [-m buffer]

  Summary tool for CNFS

Options:
  -a           print the age of the oldest article in the cycbuff
  -c class     print out status of CNFS buffers in that class
  -h           this information
  -i seconds   initial sleep of that many seconds at startup
  -l [seconds] loop like vmstat, default seconds = 600
  -m buffer    print out information suitable for MRTG
  -p           print out an MRTG config file
  -P           write PID into $INN::Config::pathrun/cnfsstat.pid
  -s           log through syslog
  -v           do consistency checks and print the result

  If called without args, does a one-time status of all CNFS buffers
";

sub help {
    print $usage;
    exit(0);
}

my (%class, %buff, %stor, @storsort);
my (%prevclass, %prevbuff, %prevstor, @prevstorsort);

my @buffers;

my ($oclass, $obuffer);
my %opt = (c => \$oclass, m => \$obuffer);
Getopt::Long::config('no_ignore_case');
GetOptions(
    \%opt, "-a", "-c=s", "-h", "-i=i", "-l:i",
    "-m=s", "-p", "-P", "-s", "-v",
) || die $usage;

help() if defined($opt{'h'});

my $use_syslog = 0;
if ($opt{'s'}) {
    eval { require Sys::Syslog; import Sys::Syslog; $use_syslog = 1 };
    if ($use_syslog) {
        if ($Sys::Syslog::VERSION lt 0.15) {
            eval "sub Sys::Syslog::_PATH_LOG { '/dev/log' }"
              if $^O eq 'dec_osf';
            Sys::Syslog::setlogsock('unix')
              if $^O =~ /linux|dec_osf|freebsd|darwin/;
        }
        openlog('cnfsstat', 'pid', $INN::Config::syslog_facility);
    } else {
        print STDERR "Syslog is not available.  -s option is ignored.\n";
    }
}

if ($opt{'P'}) {
    if (open my $FILE, '>', "$INN::Config::pathrun/cnfsstat.pid") {
        print $FILE "$$\n";
        close $FILE;
    }
}

my $sleeptime = (defined($opt{'l'}) && $opt{'l'} > 0) ? $opt{'l'} : 600;

unless (read_cycbuffconf()) {
    print STDERR "Invalid $conffile file.\n";
    exit(1);
}

unless (read_storageconf()) {
    print STDERR "Invalid $storageconf file.\n";
    exit(1);
}

mrtg($obuffer) if $obuffer;
mrtg_config() if $opt{'p'};

# Initial sleep, before starting the work.
if (defined($opt{'i'}) && $opt{'i'} > 0) {
    sleep($opt{'i'});
    if (!$use_syslog) {
        print STDOUT "$opt{'i'} seconds later:\n";
    }
}

START:

# Check whether the configuration files need reloading.
my $cycbufftime = 0;
my $storagetime = 0;
$cycbufftime = (stat($conffile))[9] if (-r $conffile);
$storagetime = (stat($storageconf))[9] if (-r $storageconf);
my $maxtime = ($cycbufftime < $storagetime) ? $storagetime : $cycbufftime;

# Set $lastconftime for the first run of the comparison.
$lastconftime = $maxtime if not $lastconftime;

if ($lastconftime < $maxtime) {
    my $reloadok = 1;

    $lastconftime = $maxtime;

    # Save the previous configuration, in case reloading it fails.
    # Direct copies of the arrays and hashes works fine here.
    %prevclass = %class;
    undef %class;
    %prevbuff = %buff;
    undef %buff;
    %prevstor = %stor;
    undef %stor;
    @prevstorsort = @storsort;
    undef @storsort;

    unless (read_cycbuffconf()) {
        print STDERR "Invalid $conffile file.\n";
        $reloadok = 0;
    }

    unless (read_storageconf()) {
        print STDERR "Invalid $storageconf file.\n";
        $reloadok = 0;
    }

    # In case reloading configuration files fails, restore the
    # previous known configuration for this run of cnfsstat.
    if (!$reloadok) {
        %class = %prevclass;
        %buff = %prevbuff;
        %stor = %prevstor;
        @storsort = @prevstorsort;
    }
}

my $logline;
my $header_printed = 0;
my ($gr, $cl, $min, $max, $filtered);
if ($oclass) {
    if ($class{$oclass}) {
        if (!$header_printed) {
            if ($stor{$oclass}) {
                ($gr, $cl, $min, $max, undef, $filtered)
                  = split(/:/, $stor{$oclass});
            } else {
                ($gr, $cl, $min, $max, $filtered) = ('', $oclass, 0, 0, 0);
            }
            # Remove leading and trailing double quotes, if present.
            my $filtered_s = $filtered ? ", filtered only" : "";
            $gr =~ s/"?([^"]*)"?/$1/g;
            if ($use_syslog) {
                if ($min || $max) {
                    $logline = sprintf(
                        "Class %s for groups matching \"%s\" "
                          . "article size min/max: %d/%d%s",
                        $oclass, $gr, $min, $max, $filtered_s,
                    );
                } else {
                    $logline = sprintf(
                        "Class %s for groups matching \"%s\"%s",
                        $oclass, $gr, $filtered_s,
                    );
                }
            } else {
                print STDOUT "Class $oclass";
                print STDOUT " for groups matching \"$gr\"";
                if ($min || $max) {
                    print STDOUT ", article size min/max: $min/$max";
                }
                if ($filtered) {
                    print STDOUT ", filtered articles only";
                }
                print STDOUT "\n";
            }
            $header_printed = 1;
        }

        @buffers = split(/,/, $class{$oclass});
        if (!@buffers) {
            print STDERR "No buffers in Class $oclass ...\n";
            next;
        }

        foreach my $buffer (@buffers) {
            if (!$buff{$buffer}) {
                print STDERR "No buffer definition for buffer $buffer ...\n";
                next;
            }
            print_cycbuff_head($buff{$buffer});
        }
    } else {
        print STDERR "Class $oclass not found ...\n";
    }
} else {    # Print all Classes
    my %buffDone;
    foreach my $c (@storsort) {
        ($gr, $cl, $min, $max, undef, $filtered) = split(/:/, $stor{$c});
        my $filtered_s = $filtered ? ", filtered only" : "";
        # Remove leading and trailing double quotes, if present.
        $gr =~ s/"?([^"]*)"?/$1/g;
        if ($use_syslog) {
            if ($min || $max) {
                $logline = sprintf(
                    "Class %s for groups matching \"%s\" "
                      . "article size min/max: %d/%d%s",
                    $c, $gr, $min, $max, $filtered_s,
                );
            } else {
                $logline = sprintf(
                    "Class %s for groups matching \"%s\"%s",
                    $c, $gr, $filtered_s,
                );
            }
        } else {
            print STDOUT "Class $c";
            print STDOUT " for groups matching \"$gr\"";
            if ($min || $max) {
                print STDOUT ", article size min/max: $min/$max";
            }
            if ($filtered) {
                print STDOUT ", filtered articles only";
            }
            print STDOUT "\n";
        }
        @buffers = split(/,/, $class{$c});
        if (!@buffers) {
            print STDERR "No buffers in Class $c ...\n";
            next;
        }

        foreach my $buffer (@buffers) {
            if (!$buff{$buffer}) {
                print STDERR "No buffer definition for buffer $buffer ...\n";
                next;
            }
            print_cycbuff_head($buff{$buffer});
            $buffDone{$buffer}++;
        }
        if (!$use_syslog) {
            print STDOUT "\n";
        }
    }

    if (!$use_syslog) {
        # Finally, print all retired cyclic buffers, still active but no longer
        # mentioned in a class.
        my $buffRetired = 0;
        foreach my $buffer (sort keys(%buff)) {
            if (!exists($buffDone{$buffer})) {
                if (!$buffRetired) {
                    print STDOUT "Retired cyclic buffers\n";
                }
                print_cycbuff_head($buff{$buffer});
                $buffRetired++;
            }
        }
    }
}

if (defined($opt{'l'})) {
    sleep($sleeptime);
    if (!$use_syslog) {
        print STDOUT "$sleeptime seconds later:\n";
    }
    goto START;
}

sub read_cycbuffconf {
    my @line;
    return 0 unless open my $CONFFILE, '<', $conffile;

    while (<$CONFFILE>) {
        $_ =~ s/^\s*(.*?)\s*$/$1/;
        # Here we handle continuation lines
        while (m/\\$/) {
            my $contline = <$CONFFILE>;
            $contline =~ s/^\s*(.*?)\s*$/$1/;
            chop;
            $_ .= $contline;
        }
        # \x23 below is #.  Emacs perl-mode gets confused by the "comment"
        next if ($_ =~ /^\s*$/ || $_ =~ /^\x23/);
        next if ($_ =~ /^cycbuffupdate:/ || $_ =~ /^refreshinterval:/);

        if ($_ =~ /^metacycbuff:/) {
            @line = split(/:/, $_);
            if ($class{ $line[1] }) {
                print STDERR "Class $line[1] more than one time "
                  . "in CycBuff Conffile $conffile ...\n";
                return 0;
            }

            $class{ $line[1] } = $line[2];
            next;
        }

        if ($_ =~ /^cycbuff/) {
            @line = split(/:/, $_);
            if ($buff{ $line[1] }) {
                print STDERR "Buff $line[1] more than one time "
                  . "in CycBuff Conffile $conffile ...\n";
                return 0;
            }
            $buff{ $line[1] } = $line[2];
            next;
        }

        print STDERR "Unknown config line \"$_\" "
          . "in CycBuff Conffile $conffile ...\n";
        return 0;
    }
    close $CONFFILE;
    return 1;
}

sub read_storageconf {
    my $line = 0;
    return 0 unless open my $STOR, '<', $storageconf;

    while (<$STOR>) {
        ++$line;
        next if /^\s*#/;

        # defaults
        my %key = (
            "NEWSGROUPS" => "*",
            "SIZE"       => "0,0",
        );

        if (/method\s+cnfs\s+\{/) {
            while (<$STOR>) {
                ++$line;
                next if /^\s*#/;
                last if /\}/;
                if (/(\w+):\s+(\S+)/i) {
                    $key{ uc($1) } = $2;
                }
            }
            unless (defined $key{'CLASS'} && defined $key{'OPTIONS'}) {
                print STDERR "storage.conf:$line: "
                  . "Missing 'class' or 'options'\n";
                return 0;
            }

            $key{'SIZE'} .= ",0" unless $key{'SIZE'} =~ /,/;
            $key{'SIZE'} =~ s/,/:/;
            $key{'FILTERED'} = defined $key{'FILTERED'}
              ? (
                  $key{'FILTERED'} =~ /^(true|yes|on)$/i
                  ? 1
                  : 0
              )
              : 0;

            if (!defined $stor{ $key{'OPTIONS'} }) {
                $stor{ $key{'OPTIONS'} } = "$key{'NEWSGROUPS'}:$key{'CLASS'}:"
                  . "$key{'SIZE'}:$key{'OPTIONS'}:$key{'FILTERED'}";
                push(@storsort, $key{'OPTIONS'});
            }
        }
    }
    return 1;
}

sub print_cycbuff_head {
    my ($buffpath) = @_;
    my ($name, $len, $free, $update, $cyclenum, $oldart)
      = get_cycbuff_info($buffpath);

    if ($use_syslog) {
        ($name) = split(/\s/, $name);
        $name =~ s/\0//g;
        # Log only if the buffer is initialized (cyclenum is not -1).
        syslog(
            'notice',
            '%s Buffer %s, len: %.2f  Mbytes, '
              . 'used: %.2f Mbytes (%4.1f%%) %3d cycles',
            $logline,
            $name,
            Math::BigFloat->new($len) / (1024 * 1024),
            Math::BigFloat->new($free) / (1024 * 1024),
            100 * Math::BigFloat->new($free) / Math::BigFloat->new($len),
            $cyclenum,
        ) if $cyclenum >= 0;
        return 0;
    }

    $name =~ s/\0//g;
    print " Buffer $name, size: ", human_readable($len, 4);
    print ", position: ", human_readable($free, 4);
    printf "  %.2f cycles\n",
      $cyclenum + Math::BigFloat->new($free) / Math::BigFloat->new($len);

    # The CNFS buffer may not have been initialized yet or received an article.
    # Take it into account because $oldart may be undefined.
    my ($when, $ago) = make_time($update);
    if (defined $oldart or not $opt{'a'}) {
        print "  Newest: $when, $ago ago\n";
    } else {
        print "  Created: $when, $ago ago\n";
    }

    if ($opt{'a'}) {
        if (defined $oldart) {
            my ($when_oldart, $ago_oldart) = make_time($oldart);
            print "  Oldest: $when_oldart, $ago_oldart ago\n";
        } else {
            print "  No oldest article\n";
        }
    }
    return;
}

sub make_time {
    my ($t) = @_;
    my (@ret);

    my ($sec, $minutes, $hour, $mday, $mon, $year)
      = (localtime($t))[0 .. 5];
    push(
        @ret,
        sprintf(
            "%04d-%02d-%02d %2d:%02d:%02d",
            $year + 1900, $mon + 1, $mday, $hour, $minutes, $sec,
        ),
    );
    $t = time - $t;

    $mday = int($t / 86400);
    $t = $t % 86400;
    $hour = int($t / 3600);
    $t = $t % 3600;
    $minutes = int($t / 60);
    $t = $t % 60;

    push(
        @ret,
        sprintf("%4d days, %2d:%02d:%02d", $mday, $hour, $minutes, $t),
    );
    return @ret;
}

sub human_readable {
    my ($val, $digits) = @_;
    $val =~ s/\+//;

    my @name = ("kBytes", "MBytes", "GBytes", "TBytes");
    my $base = 1024;
    my $factor = 1024;

    my $unit = -1;
    my $oldscaled = Math::BigFloat->new($val) / $base;
    my $scaled = $oldscaled;
    while ((int($scaled) > 0) && ($unit < $#name)) {
        $oldscaled = $scaled;
        $scaled /= $factor;
        $unit++;
    }
    $scaled = $oldscaled;
    my $predigits = length(int($scaled));
    my $postdigits = $digits - $predigits - 1;
    $postdigits = 0 if $postdigits < 0;
    ++$digits;

    return sprintf("%${digits}.${postdigits}f %s", $scaled, $name[$unit]);
}

sub mrtg {
    my $buffer = shift;
    # print "Buffer = $buff{$buffer}\n";
    my @info = get_cycbuff_info($buff{$buffer});
    print "$info[1]\n";
    print "$info[2]\n";
    print "$info[4]\n";
    print "$info[0]\n";
    exit(0);
}

sub mrtg_config {
    print "Sub MRTG-CONFIG\n";
    foreach my $class (sort(keys(%class))) {
        print "##\n## Class  : $class\n## Wildmat: $stor{$class}\n##\n\n";
        foreach my $buffer (split /\,/, $class{$class}) {
            mrtg_buffer($class, $buffer);
        }
    }
    exit(0);
}

sub mrtg_buffer {
    my ($class, $buffer) = @_;
    #my ($name, $num, $buff, $size) = @_;
    my $tag = 'cnfs-' . $buffer;

    print 'Target[', $tag, ']: `', "$INN::Config::pathbin/cnfsstat -m ",
      $buffer, '`', "\n";
    print 'MaxBytes[', $tag, ']: ', (get_cycbuff_info($buff{$buffer}))[1],
      "\n";
    print 'Title[', $tag, ']: ', "${buffer} Usage\n";
    print 'Options[', $tag, ']: growright gauge', "\n";
    print 'YLegend[', $tag, ']: ', "${buffer}\n";
    print 'ShortLegend[', $tag, ']: MB', "\n";
    print 'PageTop[', $tag, ']: ', "<H1>Usage of ${buffer}</H1>\n";
    print "<BR><TT>$stor{$class}</TT>\n";
    print "\n";
    return 1;
}

sub bigsysseek {
    my ($handle, $offset) = @_;

    # $offset may be a bigint; and have a value that doesn't fit in a signed
    # long.  Even with largefiles enabled, perl will still truncate the
    # argument to lseek64 to 32 bits.
    # So we seek multiple times, <2G at a time.
    if ($offset > 2147483647) {
        # Since perl truncates the return value of lseek64 to 32 bits,
        # it might see a successful return value as negative, and return
        # FALSE (undef).  So we must ignore the return value of sysseek
        # and assume that it worked.
        seek($handle, 0, 0);
        while ($offset > 2000000000) {
            sysseek($handle, 2000000000, 1) || return 0;
            $offset -= 2000000000;
        }
        sysseek($handle, $offset, 1) || return 0;
        return 1;
    } else {
        return sysseek($handle, $offset, 0);
    }
}

sub check_read_return {
    my $result = shift;
    die "read: $!\n" unless defined($result);
    die "read reached eof\n" unless $result;
    return $result;
}

sub get_cycbuff_info {
    my ($buffpath) = @_;
    my $oldart;

    my $CNFSMASIZ = 8;
    my $CNFSNASIZ = 16;
    my $CNFSPASIZ = 64;
    my $CNFSLASIZ = 16;
    my $headerlength
      = 2 * $CNFSMASIZ + 2 * $CNFSNASIZ + $CNFSPASIZ + (6 * $CNFSLASIZ);

    my ($BUFF, $buff);

    if (!open $BUFF, '<', $buffpath) {
        print STDERR "Cannot open Cycbuff $buffpath ...\n";
        exit(1);
    }

    $buff = "";
    if (!read $BUFF, $buff, $headerlength) {
        print STDERR
          "Cannot read $headerlength bytes from file $buffpath...\n";
        exit(1);
    }

    my (
        $magic, $name, $path_unused, $lena, $freea, $updatea, $cyclenuma,
        $metaname_unused, $orderinmeta_unused, $currentbuff_unused, $blksza,
    ) = unpack("a8 a16 a64 a16 a16 a16 a16 a16 a16 a8 a16", $buff);

    if (!$magic) {
        print STDERR "Error while unpacking header ...\n";
        exit(1);
    }

    my $len = bhex($lena);
    my $free = bhex($freea);
    my $update = hex($updatea);
    my $cyclenum = hex($cyclenuma) - 1;
    my $blksz = ($magic =~ m/^CBuf4/) ? hex($blksza) : 512;

    if ($opt{'a'}) {

        my $pagesize = 16384;
        my $minartoffset = int($len / ($blksz * 8)) + 512;
        # Align upwards:
        $minartoffset = ($minartoffset + $pagesize - 1) & ~($pagesize - 1);

        if ($cyclenum == 0 && $free == $minartoffset) {
            # The cycbuff has no articles yet.
            goto DONE;
        }

        # Don't loop endlessly, set rough upper bound
        my $sentinel = $cyclenum == 0 ? $free : $len;
        my $offset = $cyclenum == 0 ? $minartoffset : $free + $pagesize;

        bigsysseek($BUFF, $offset) || die "sysseek: $!\n";
        check_read_return(sysread($BUFF, $buff, $pagesize));
        do {
            my $chunk;
            check_read_return(sysread($BUFF, $chunk, $pagesize));

            $buff .= $chunk;
            while ($buff =~ /^message-id:\s+(<.*?>)/mi) {
                $buff = $POSTMATCH;
                $oldart = lookup_age($1);
                next unless $oldart;

                # Is the article newer than the last update of the cycbuff?
                if ($oldart >= $update) {
                    $update = $oldart;
                } elsif ($oldart < $update - 60) {
                    goto DONE;
                }
            }
            # Just in case we chopped Message-ID in two, use the end
            # at the front in next iteration.
            $buff = substr($buff, -$blksz);

        } while ($sentinel -= $pagesize > 0);
    }

  DONE:
    close $BUFF;
    return ($name, $len, $free, $update, $cyclenum, $oldart);
}

sub lookup_age {
    my ($msgid) = @_;

    my $history = safe_run("$INN::Config::newsbin/grephistory", "-l", $msgid);
    if ($history =~ /\t(\d+)~/) {
        return $1;
    }

    if ($opt{'v'}) {
        print "   (Missing $msgid)\n";
    }

    return 0;
}

sub safe_run {
    my $output = "";

    my $pid = open my $KID_TO_READ, "-|";
    die "fork: $!\n" unless defined $pid;
    if ($pid) {
        while (<$KID_TO_READ>) {
            $output .= $_;
        }
        close $KID_TO_READ;
    } else {
        exec(@_) || die "can't exec $_[0]: $!";
        # NOTREACHED
    }
    return $output;
}

# Hex to bigint conversion routine.
# bhex(HEXSTRING) returns BIGINT (with leading + chopped off).
#
# In most languages, unlimited size integers are done using string math
# libraries usually called bigint.  (Java, Perl, etc.)
#
# Bigint's are really just strings.

sub bhex {
    my $hexValue = shift;
    $hexValue =~ s/^0x//;

    my $integerValue = Math::BigInt->new('0');
    for (my $i = 0; $i < length($hexValue); $i += 2) {
        # Could be more efficient going at larger increments, but byte
        # by byte is safer for the case of 9 byte values, 11 bytes, etc.

        my $byte = substr($hexValue, $i, 2);
        my $byteIntValue = hex($byte);

        # bmuladd() is only in Perl >= 5.10.0.
        $integerValue->bmul('256');
        $integerValue->badd("$byteIntValue");
    }

    my $result = $integerValue->bstr();
    $result =~ s/^\+//;
    return $result;
}
