#!/usr/bin/perl

# This is a library of functions common to two or more programs within
# the Captrap network traffic usage monitor.

# Copyright 2009 Corey Hickey


# This file is part of Captrap.
#
# Captrap is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# Captrap is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Captrap.  If not, see <http://www.gnu.org/licenses/>.

=head1 NAME

Captrap - a common library of functions used by Captrap's various programs

=head1 SYNOPSIS

use Captrap qw(:db :config :misc);

=head1 DESCRIPTION

As of yet, this library is not intended to be used outside of Captrap; few of
the included functions can be used in a self-contained manner. This text is
intended as a quick reference for use in Captrap development.

No functions are exported by default.

=head2 Tags

The following groups of functions are available; contents may change in future
versions.

=over

=item :db

mk_dbh, check_interval_unit, unit_to_fmt, placeholder_list, get_unknown_macs,
get_times, time_diff, quote_sql_stmt, quote_sql

=item :cgi

mk_cgi, cgi_handle_params, cgi_bad_params, cgi_list_params, cgi_start_xhtml

=item :misc

mk_ixhash, safe_eq, choose_factor, floor_unit, print_time, parse_time, time_re,
l2a, mk_href, mk_link

=item :config

mk_config_header, mk_config_header_priv, mk_config_info, mk_config_info_priv,
config_file_path, parse_config, parse_config_priv

=item :actions

describe_actions, check_args, do_args

=item :args
arg_handle_params, arg_list_params, write_output_to_file, params_input_to_output

=back

=head2 Functions

=over

=cut


use 5.010; # we need Perl >= 5.10 for given/when
use strict;
use warnings FATAL => 'all';
no warnings "experimental::smartmatch";
use feature 'switch';

package Captrap;
require Exporter;

our @ISA = ('Exporter');
our @EXPORT = ();
our %EXPORT_TAGS = (
  db => [ qw(
    mk_dbh
    check_interval_unit
    unit_to_fmt
    placeholder_list
    get_unknown_macs
    get_times
    time_diff
    quote_sql_stmt
    quote_sql
  ) ],
  cgi => [ qw(
    mk_cgi
    cgi_handle_params
    cgi_bad_params
    cgi_list_params
    cgi_start_xhtml
  ) ],
  misc => [ qw(
    mk_ixhash
    safe_eq
    choose_factor
    floor_unit
    print_time
    parse_time
    time_re
    l2a
    mk_href
    mk_link
  ) ],
  config => [ qw(
    mk_config_header
    mk_config_header_priv
    mk_config_info
    mk_config_info_priv
    config_file_path
    parse_config
    parse_config_priv
  ) ],
  actions => [ qw(
    describe_actions
    check_args
    do_args
  ) ],
  args => [ qw(
    arg_handle_params
    arg_list_params
    write_output_to_file
    params_input_to_output
  ) ],
);
# all the tagged functions
our @EXPORT_OK = map({ @$_ } values(%EXPORT_TAGS));

use DBI;
use CGI qw(-nosticky);
use HTML::Entities;
use Config::File qw(read_config_file);
use Tie::IxHash;
use Date::Calc qw(Add_Delta_YM Add_Delta_YMD Add_Delta_YMDHMS Delta_Days
    Delta_YMDHMS);
use List::MoreUtils qw(mesh);

# for development using a different Captrap module
use lib "lib";
use DBCache;


# -----------------------------------------------------------------------------
# database
# -----------------------------------------------------------------------------

=item mk_dbh($config, $priv)

Connect to the MySQL database using the configured username and password. If 
$priv is defined, the priviliged MySQL user will be used. The return value is a
database handle.

=cut

sub mk_dbh {
  my $config = shift; # hash ref
  my $priv = shift; # may be undef
  my $host = $config->{db_host};
  my $db = $config->{db_database};
  my $user = $config->{db_user};
  my $pass = $config->{db_password};
  if ($priv) {
    my $config_priv = parse_config_priv($config, 1);
    ($user, $pass) = @{$config_priv}{'db_user_priv', 'db_password_priv'};
  }
  unless (defined($config->{db_password})) {
    print STDERR "no MySQL password read from Captrap config file";
    print STDERR "a password MUST be specified";
    exit(1);
  }
  my $dsn = "DBI:mysql:database=$db;host=$host;mysql_auto_reconnect=1";
  my $attribs = {
    RaiseError => 1,
    AutoCommit => 1,
    TaintIn    => 1,
  };
  my $dbh = DBCache->connect($dsn, $user, $pass, $attribs) or die;
  return $dbh;
}


=item check_interval_unit($unit)

MySQL won't allow specifying an interval unit with a placeholder. This function
checks the supplied unit against a list of allowed values so it can be used
directly in the $dbh->prepare() string. Returns the lowercased unit if OK, or
undef if not.

=cut

sub check_interval_unit {
  my $unit = shift;
  $unit = lc($unit);
  my $accept = qr/microsecond|second|minute|hour|day|week|month|quarter|year/;
  return $unit if $unit =~ /$accept/;
  return undef;
}


=item unit_to_fmt($unit)

Convert a time unit into a MySQL date_format string. Returns the format string
or dies if the unit is not recognized.

=cut

sub unit_to_fmt {
  my $unit = shift;
  return "%Y"                if $unit =~ /^year$/i;
  return "%Y-%m"             if $unit =~ /^month$/i;
  return "%Y-%m-%d"          if $unit =~ /^day$/i;
  return "%Y-%m-%d %H"       if $unit =~ /^hour$/i;
  return "%Y-%m-%d %H:%m"    if $unit =~ /^minute$/i;
  return "%Y-%m-%d %H:%m:%s" if $unit =~ /^second$/i;
  die;
}


=item placeholder_list($list)

Generate a list of placeholders for an SQL query based on the length of the
array referenced by $list. Returns a string like "?, ?, ?".

=cut

sub placeholder_list {
  my $list = shift; # array ref
  die "empty list" unless @$list;
  return join(", ", split(//, '?' x @$list)); # something like "?, ?, ?"
}


=item get_unknown_macs($common)

Return a reference to an array of MAC addresses that are in the acct table but
not in the macs table.

=cut

sub get_unknown_macs {
  my $common = shift;
  my $acct = $common->{config}->{db_table_acct};
  my $macs = $common->{config}->{db_table_macs};
  my $sel = "
      select
        $acct.mac_dst as mac,
        sum($acct.bytes) as bytes,
        min($acct.stamp_inserted) as first,
        max($acct.stamp_inserted) as last
      from $acct left join $macs on $acct.mac_dst = $macs.mac
      where $macs.mac is null
      group by $acct.mac_dst
  ";
  my $sth = $common->{dbh}->prepare($sel);
  # don't use DBCache for this, since captrap_mac needs to get fresh
  # information each time
  $sth->execute();
  my @macs;
  while (my @a = $sth->fetchrow_array()) {
    die if @a < 4; # shouldn't happen
    push(@macs, \@a);
  }
  return \@macs;
}


=item get_times($common, $now)

Get the past intervals and current date/time from MySQL. $now may be set to a
time, in which case the times returned are relative to that time. Returns a
reference to a hash containing the interval names and values.

=cut

sub get_times {
  my $common = shift;
  my $now = shift; # may be undef
  my $acct = $common->{config}->{db_table_acct};
  my $sel = "
    SELECT
      MIN(stamp_inserted),
      NOW()
    FROM $acct;
  ";
  my $sth = $common->{dbh}->prepare($sel);
  $sth->dbcache_execute();
  my $a = $sth->fetchrow_arrayref();
  $sth->fetchrow_arrayref(); # to finish sth
  die unless defined($a); # shouldn't happen
  unless (defined($a->[0])) {
    print STDERR "no data in table '$acct'; is pmacctd running?\n";
    exit 1;
  }
  if (defined($now)) {
    $a->[1] = $now;
  }
  # the graph wants "2009-02-08T22:27:08" instead of "2009-02-08 22:27:08"
  # and it's prettier to do this than lots of date_format(blahblahblah)
  s/ /T/ foreach (@$a);
  my $yearago  = add_time($a->[1], -1, "year");
  my $monthago = add_time($a->[1], -1, "month");
  return {
    first => $a->[0],
    lastyear => floor_unit("month", $yearago),
    yearago => $yearago,
    lastmonth => floor_unit("day", $monthago),
    monthago => $monthago,
    lastday => floor_unit("hour", add_time($a->[1], -1, "day")),
    lasthour => floor_unit("hour", add_time($a->[1], -1, "hour")),
    now => $a->[1],
  };
}


# add a delta to a time
# delta is in increments of $unit
sub add_time {
  my $time = shift;
  my $delta = shift;
  my $unit = shift;
  my ($year, $month, $day, $hour, $minute, $second) = parse_time("second", $time);
  # many of these time functions have arguments and return values we don't use
  given ($unit) {
    when (/^year$/i) {
      $year += $delta; #easy
    }
    when (/^month$/i) {
      # we need to include day here because some months are shorter:
      # 2009-10-31 - 1 month == 2009-09-30
      ($year, $month, $day) = Add_Delta_YM($year, $month, $day, 0, $delta);
    }
    when (/^day$/i) {
      ($year, $month, $day) = Add_Delta_YMD($year, $month, $day, 0, 0, $delta);
    }
    when (/^hour$/i) {
      ($year, $month, $day, $hour) = Add_Delta_YMDHMS(
          $year, $month, $day, $hour, 0, 0, # base
          0, 0, 0, $delta, 0, 0); # deltas
    }
    when (/^minute$/i) {
      ($year, $month, $day, $hour, $minute) = Add_Delta_YMDHMS(
          $year, $month, $day, $hour, $minute, 0, # base
          0, 0, 0, 0, $delta, 0); # deltas
    }
    when (/^second$/i) {
      ($year, $month, $day, $hour, $minute, $second) = Add_Delta_YMDHMS(
          $year, $month, $day, $hour, $minute, $second, # base
          0, 0, 0, 0, 0, $delta); # deltas
    }
  }
  return sprintf("%04d-%02d-%02dT%02d:%02d:%02d",
      $year, $month, $day, $hour, $minute, $second);
}


=item time_diff($time1, $time2, $unit)

Find the difference between two times in the specified unit ($time2 - $time1).

=cut

sub time_diff {
  my $time1 = shift;
  my $time2 = shift;
  my $unit = shift;
  my @deltas = Delta_YMDHMS((parse_time("second", $time1),
      parse_time("second", $time2)));
  my $diff = $deltas[0]; # years
  return $diff if $unit =~ /^year$/i;
  $diff = 12 * $diff  + $deltas[1]; # months
  return $diff if $unit =~ /^month$/i;
  # non-constant number of days per month
  $diff = Delta_Days((parse_time("day", $time1))[0..2],
      (parse_time("day", $time2))[0..2]); # days
  return $diff if $unit =~ /^day$/i;
  $diff = 24 * $diff  + $deltas[3]; # hours
  return $diff if $unit =~ /^hour$/i;
  $diff = 60 * $diff  + $deltas[4]; # minutes
  return $diff if $unit =~ /^minute$/i;
  $diff = 60 * $diff  + $deltas[4]; # seconds
  return $diff if $unit =~ /^second$/i;
  die "invalid unit: $unit";
}


=item quote_sql_stmt($dbh, $stmt, $args)

Insert quoted arguments into a quoted SQL statement. In general, use of this
function should be avoided in favor of prepared statements. $dbh need not be
defined, but will be used if possible.

=cut

sub quote_sql_stmt {
  my $dbh = shift;
  my $stmt = shift;
  my $args = shift; # hash ref
  my @quoted = map { quote_sql($dbh, $_) } @{$args};
  my @splitup = split(/\?/, $stmt);
  # to avoid headaches, we want to make sure there are enough args
  # @quoted must have one element fewer than @splitup, unless $stmt ends
  # with a '?'
  my $less = substr($stmt, -1, 1) ne '?';
  my $need = @splitup - $less;
  my $have = @quoted;
#    print STDERR "$less,$need,$have ... @splitup\n";
  if ($need != $have) {
    die "incorrect number of args for statement (have $have, need $need";
  }
  my @meshed = mesh(@splitup, @quoted);
  pop(@meshed) if ($less); # get rid of extra undef
  return join('', @meshed);
}


=item quote_sql($dbh, $string)

Quote a string for use in an SQL statement. In general, use of this function
should be avoided in favor of prepared statements. $dbh need not be defined,
but will be used if possible.

=cut

sub quote_sql {
  my $dbh = shift;
  my $string = shift;
  if (defined($dbh)) {
    return $dbh->quote($string);
  } else {
    # hack because captrap_mkdb needs to quote without connecting
    return DBD::_::db->quote($string);
  }
}


# -----------------------------------------------------------------------------
# CGI
# -----------------------------------------------------------------------------

=item mk_cgi()

Return a CGI object with appropriate limits.

=cut

sub mk_cgi {
  # Set CGI limits. Right now none of the scripts use uploads or method=post.
  # POST_MAX == 1 because 0 means unlimited. A 1-byte limit effectively
  # disables posting.
  $CGI::POST_MAX = 1;
  $CGI::DISABLE_UPLOADS = 1;
  my $cgi = CGI->new();
}


=item cgi_handle_params($common, $param_info, $cgi_func)

Check CGI parameters and pass them to a supplied subroutine. Returns the output
of the subroutine, or a list of errors if the parameters turned out to be bad.

=cut

sub cgi_handle_params {
  my $common = shift; # hash ref
  my $param_info = shift; # hash ref
  my $cgi_func = shift; # function ref
  my $err;
  my $cgi = $common->{cgi};
  my $params = cgi_get_params($cgi, $param_info, \$err);
  if (defined($params)) {
    return &{$cgi_func}($common, $params);
  }
  return cgi_bad_params($common->{cgi}, $param_info, $err);
}


# get all cgi parameters and their values
sub cgi_get_params {
  my $cgi = shift;
  my $param_info = shift; # hash ref
  my $err = shift; # scalar ref
  my $params = {};
  # make a hash of all cgi parameters
  foreach my $param ($cgi->param()) {
    # treat everything as an array for now
    $params->{$param} = [ $cgi->param($param) ]
  }
  # now check them
  return check_params($params, $param_info, $err);
}


# get the values of a parameter; die if there's no value
sub get_values {
  my $cgi = shift;
  my $param = shift;
  my @values = $cgi->param($param);
  # todo: this probably shouldn't die; handle the error somehow
  die "no values for param $param" unless @values;
  foreach my $value (@values) {
    $value = undef if $value eq ""; # pretty sure I want this
  }
  return \@values;
}


=item cgi_bad_params($cgi, $param_info, $err)

Return an HTML page with an error message and a list of all supplied
parameters.

=cut

# print a parameter list for debug
sub cgi_bad_params {
  my $cgi = shift;
  my $param_info = shift;
  my $err = shift;
  print $cgi->header;
  print cgi_start_xhtml($cgi, 'bad parameters');
  # make sure to use encode_entities() for all user-supplied strings
  print $cgi->h4("Error:");
  print $cgi->p(encode_entities($err));
  my $list;
  foreach my $param ($cgi->param()) {
    my $p = encode_entities($param);
    my $v = array_to_print([ $cgi->param($param) ], \&encode_entities);
    $list .= "$p: $v" . $cgi->br;
  }
  print $cgi->h4("All Supplied Parameters:");
  print $cgi->p($list);
  print cgi_list_params($cgi, "Valid", $param_info);
  print $cgi->end_html();
}


=item cgi_list_params($cgi, $name, $param_info)

Return an HTML list of all available parameters and their defaults.

=cut

sub cgi_list_params {
  my $cgi = shift;
  my $name = shift;
  my $param_info = shift; # hash ref
  my $text = $cgi->h2("$name Parameters:");
  foreach my $param (keys %$param_info) {
    $text .= $cgi->h5($param);
    $text .= $cgi->p($param_info->{$param}->{txt});
    my $def = $param_info->{$param}->{def};
    if (!defined($def)) {
      $def = "(undefined)";
    } else {
      if ($param_info->{$param}->{var} eq 'a') {
        # array type
        if (@$def) {
          $def = array_to_print(@$def, \&encode_entities);
        } else {
          $def = "(empty array)";
        }
      } else {
        # scalar type
        $def = "\"$def\"";
      }
    }
    $text .= $cgi->p("default: $def");
  }
  return $text;
}


=item cgi_start_xhtml($cgi, $title)

This is a wrapper around CGI's start_html() method that sets common options.

=cut

sub cgi_start_xhtml {
  my $cgi = shift;
  my $title = shift;
  return $cgi->start_html(
      '-title' => $title,
      '-dtd'   => [
        '-//W3C//DTD XHTML 1.0 Strict//EN',
        'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd'
      ],
      '-style' => {
        src => 'captrap.css',
      },
  );
}


# make a pretty array to print
sub array_to_print {
  my $array = shift;
  my $filter = shift; # function ref
  my @a;
  foreach my $elem (@$array) {
    my $tr = defined($elem) ? $elem : "<undef>";
    if (defined($filter)) {
      $tr = &$filter($tr);
    }
    push(@a, $tr);
  }
  return "[ " . join(", ", @a) . " ]";
}

# -----------------------------------------------------------------------------
# misc utility
# -----------------------------------------------------------------------------

=item mk_ixhash()

Returns a hash tied to Tie::IxHash; useful for preserving original key order.

=cut

# make a hash tied to IxHash
sub mk_ixhash {
  my %hash;
  tie (%hash, "Tie::IxHash"); # preserves original key order
  return \%hash;
}


=item safe_eq($x, $y)

Undef-safe comparison; returns true if both arguments are undef, false if one
is undef, or the results of a regular comparison if they're both defined.

=cut

sub safe_eq {
  my $x = shift;
  my $y = shift;
  # This is written as "return !different"; is there a simpler way?
  return ! (defined($x) ^ defined($y) || defined($x) && $x ne $y);
}


=item choose_factor($n, $item)

Figure out the scaling factor by which a number should be displayed, along with
the appropriate unit. Returns a two-element array; the first element is the
scale factor, and the second element is the unit (B, kB, etc.).

=cut

sub choose_factor {
  my $n = shift;
  my $item = shift;
  my @a = choose_factor_raw($n);
  if ($item eq "packets") {
    $a[1] .= " pkts";
  } else {
    # default to "bytes"
    $a[1] .= "B";
  }
  return @a;
}


# choose the factor and B/k/M/etc.
sub choose_factor_raw {
  my $n = shift;
  return (2**0,   "")  if $n < 2**11;
  return (2**10,  "k") if $n < 2**21;
  return (2**20,  "M") if $n < 2**31;
  return (2**30,  "G") if $n < 2**41;
  # I hope someday...
  return (2**40, "T");
}


=item floor_unit($unit, $time)

Round a time down based on a supplied unit.

=cut

sub floor_unit {
  my $unit = shift;
  my $time = shift;
  if ($unit =~ /^year$/i) {
    return (split(/-/, $time))[0] . "-01-01T00:00:00";
  }
  if ($unit =~ /^month$/i) {
    return join('-', (split(/-/, $time))[0,1]) . "-01T00:00:00";
  }
  if ($unit =~ /^day$/i) {
    return (split(/T/, $time))[0] . "T00:00:00";
  }
  if ($unit =~ /^hour$/i) {
    return (split(/:/, $time))[0] . ":00:00";
  }
  die "floor_unit: unrecognized unit $unit";
}


=item print_time($time)

Convert a 'T' to a ' '. Useful for converting times, such as
"2009-12-29T14:00:00" to "2009-12-29 14:00:00".

=cut

sub print_time {
  my $time = shift;
  $time =~ tr/T/ /;
  return $time;
}


=item parse_time($unit, $time)

Parse a time string whith is represented up to the given unit. Returns an array
of values for year, month, day, etc.

=cut

sub parse_time {
  my $unit = shift;
  my $time = shift;
  my $re = time_re($unit);
  # some of these may be undef
  return ($1, $2, $3, $4, $5, $6) if $time =~ /$re/;
  die "time didn't parse: time=$time unit=$unit re=$re";
}


=item time_re($unit, $sep)

Returns a regular expression for parsing a time string of the given unit. $sep
may be set to the character which will separate the data and time time (default
'T').

=cut

sub time_re {
  my $unit = shift;
  my $sep = shift; # may be undef
  $sep = "T " unless defined($sep);
  given ($unit) {
    when (/^year$/i) {
      return qr/^(\d{4})/;
    }
    when (/^month$/i) {
      return qr/^(\d{4})-(\d{2})/;
    }
    when (/^day$/i) {
      return qr/^(\d{4})-(\d{2})-(\d{2})/;
    }
    when (/^hour$/i) {
      return qr/^(\d{4})-(\d{2})-(\d{2})[$sep](\d{2})/;
    }
    when (/^minute$/i) {
      return qr/^(\d{4})-(\d{2})-(\d{2})[$sep](\d{2})-(\d{2})/;
    }
    when (/^second$/i) {
      return qr/^(\d{4})-(\d{2})-(\d{2})[$sep](\d{2}):(\d{2}):(\d{2})/;
    }
  }
  die "invalid time unit $unit";
}


=item l2a($list)

Convert a string of comma-separated values into an array.

=cut

sub l2a {
  my $list = shift;
  return () unless defined($list);
  return map { $_ eq "" ? undef : $_ } split(/,/, $list);
}


# convert a semicolon-colon separated list of values into a hash
sub l2h {
  my $list = shift;
  return {} unless defined($list);
  my $hash = mk_ixhash();
  foreach my $item (split(/;/, $list)) {
    # now we have key:val
    my ($key, $value) = split(/:/, $item);
    $hash->{$key} = $value;
  }
  return $hash;
}


# convert a semicolon-colon separated list of values into a hash of arrays
sub l2ha {
  my $list = shift;
  return {} unless defined($list);
  my $hash = mk_ixhash();
  foreach my $item (split(/;/, $list)) {
    # now we have key:val1,val2,val3
    my ($key, $values) = split(/:/, $item);
    $hash->{$key} = [ l2a($values) ]; # may be undef
  }
  return $hash;
}


=item mk_href($common, $prog, $params, $text)

Make a hyperlink to a Captrap program; returns a string containing the
hyperlink and the included text. $prog is the program to which the hyperlink
will refer, using the parameters in $params. If this is a recursive fetch
(from captrap_recur), then the target of the link will be generated, if it has
not been already.

=cut

sub mk_href {
  my $common = shift;
  my $prog = shift;
  my $params = shift; # hash ref
  my $text = shift;
  my $cgi = $common->{cgi};
  my $link = mk_link($common, $prog, $params);
  return $cgi->a({ href => $link }, $text);
}


=item mk_link($common, $prog, $params)

Like mk_href(), but just return the URL of a link to a Captrap program.

=cut

sub mk_link {
  my $common = shift;
  my $prog = shift;
  my $params = shift; # hash ref
  my $link = $prog;
  # if we're doing a recursive fetch, return the filename from the tree
  if (defined($common->{recur})) {
    return tree_put($common, $prog, $params);
  }
  # otherwise, make a regular CGI link
  return $link unless defined($params);
  my @a;
  while (my ($param, $values) = each %$params) {
    foreach my $value (@$values) {
      next unless defined($value);
      push(@a, "$param=$value");
    }
  }
  return "$link?" . join("&", @a);
}


# put a leaf on the parameter tree
sub tree_put {
  my $common = shift;
  my $prog = shift;
  my $params = shift;
  my $tree = $common->{recur}->{tree};
  # use prog name for the first division
  $tree->{$prog} = {} unless defined($tree->{$prog});
  $tree = $tree->{$prog};
  # now walk the tree based on parameters
  # name1 --> n1value1 --> name1 --> n1value2 --> name2 --> n2value1 --> ...
  foreach my $name (sort(keys %$params)) {
    foreach my $value (@{$params->{$name}}) {
      next unless defined($value); # skip undefs
      foreach my $next ($name, $value) {
        $tree->{$next} = {} unless defined($tree->{$next});
        $tree = $tree->{$next};
      }
    }
  }
  # ok, now we're at a leaf; do we need to make a new file?
  unless (defined($tree->{_file})) {
    my $recur = $common->{recur};
    my $func = $recur->{progs}->{$prog}->{func};
    my $param_info = $recur->{progs}->{$prog}->{info};
    my $dir = $recur->{dir};
    my $idx = $recur->{num}++;
    my $base = "$dir/$idx";
    if ($recur->{v}) {
      print STDERR "tree_put: will generate item: $idx\n";
    }
    # save 'priv', recurse, and restore 'priv'
    my $saved_priv = $common->{priv};
    my $extension = recur_next($common, $params, $param_info, $func, $base);
    $common->{priv} = $saved_priv;
    $tree->{_file} = "$idx.$extension"; # just the file, not the path
    if ($recur->{v}) {
      print STDERR "tree_put: wrote $tree->{_file}\n";
    }
  }
  return $tree->{_file};
}


# check parameters and pass on to the next function
sub recur_next {
  my $common = shift;
  my $params = shift;
  my $param_info = shift;
  my $func = shift;
  my $base = shift; # file name base (including dir)
  my $err;
  my $ok_params = check_params($params, $param_info, \$err);
  unless (defined($ok_params)) {
    # if this happens, it's a programming error, not a user error
    print STDERR "Error:\n$err\n\n";
    raw_bad_params($params, $param_info);
    print STDERR "We hit an error trying to recurse. Bailing out.\n";
    die;
  }
  my $extension;
  my $output = write_output_to_file($common, $ok_params, $base, $func,
      \$extension);
  my $validate = $common->{recur}->{validate};
  # should we validate?
  if ($extension eq "html" && defined($validate)) {
    if (! &$validate($output)) {
      my $file = "$base.$extension";
      print STDERR "validation function failed for $file\n";
      print STDERR "quitting.\n";
      exit(3);
    }
  }
  return $extension;
}

# -----------------------------------------------------------------------------
# configuration
# -----------------------------------------------------------------------------

=item mk_config_header()

Return text for printing at the top of the main configuration file.

=cut

sub mk_config_header () {
  return "
# This is the main Captrap configuration file. Every available parameter is
# listed. Anything following a '#' character in a line is ignored, so avoid
# using '#' except to start a comment. To change a parameter from its default,
# remove the '#' and change the parameter's value.
";
}


=item mk_config_header_priv()

Return text for printing at the top of the privileged-user configuration file.

=cut

sub mk_config_header_priv () {
  return "
# This is the configuration file containing login credentials for a privileged
# MySQL user. This file should only be readable by root (or some designated
# admin user), otherwise any local user could mess up the database.
";
}


=item mk_config_info()

Return a reference to a hash of all the configuration parameters in the main
config file.

=cut

sub mk_config_info () {
  my $info = mk_ixhash();
  %$info = (
    priv_conf => {
      def => "/etc/captrap/priv.conf",
      txt => "path to Captrap \"private\" config file; this file must not\n" .
          "be world-readable since it contains the credentials of a MySQL\n" .
          "account with write privileges.",
      var => 's',
    },
    captrap_host => {
      def => "localhost",
      txt => "name of the host running Captrap, as seen from the MySQL\n" .
          "server.",
      var => 's',
    },
    db_host => {
      def => "localhost",
      txt => "MySQL server to which Captrap should connect",
      var => 's',
    },
    db_database => {
      def => "pmacct",
      txt => "pmacct database",
      var => 's',
    },
    db_user => {
      def => "captrap",
      txt => "database username",
      var => 's',
    },
    db_password => {
      def => undef,
      txt => "database password (MUST be defined in config file)",
      var => 's',
    },
    db_table_acct => {
      def => "acct_eth1",
      txt => "mysql pmacct accounting table",
      var => 's',
    },
    db_table_macs => {
      def => "macs_eth1",
      txt => "mysql MAC address table",
      var => 's',
    },
    interface => {
      def => "eth1",
      txt => "network interface for which Captrap displays statistics;\n" .
          "note that changing this parameter will NOT make data be\n" .
          "collected from a different interface--you must change pmacct's\n" .
          "configuration file if you want to do that.",
      var => 's',
    },
    mainpage => {
      def => "main.pl",
      txt => "Captrap CGI main page program (leave this alone)",
      var => 's',
    },
    viewer => {
      def => "viewer.pl",
      txt => "Captrap CGI view program (leave this alone)",
      var => 's',
    },
    grapher => {
      def => "grapher.pl",
      txt => "Captrap CGI graphing program (leave this alone)",
      var => 's',
    },
    gnuplot => {
      def => "/usr/bin/gnuplot",
      txt => "full (absolute) path to gnuplot binary",
      var => 's',
    },
    graph_font => {
      def => "/usr/share/fonts/truetype/ttf-liberation/LiberationMono-Regular.ttf",
      txt => "Full path to a TrueType font file.",
      var => 's',
    },
    default_graph_w => {
      def => 800,
      txt => "default graph width (in pixels)",
      var => 's',
    },
    default_graph_h => {
      def => 600,
      txt => "default graph height (in pixels)",
      var => 's',
    },
    max_steps => {
      def => 1000,
      txt => "maximum number of time steps on a graph",
      var => 's',
    },
    states => {
      def => "up,down,bcast,bogey,ignore",
      txt => "comma-separated list of valid states (note that these must\n" .
          "be enum values in the MAC address table's \"state\" column; to\n" .
          "add a new state, you may have to alter the table first); see\n" .
          "also \"state_colors\"",
      var => 'a',
    },
    states_ignore => {
      def => "ignore",
      txt => "comma-separated list of states for which no statistics will\n" .
          "be shown",
      var => 'a',
    },
    state_colors => {
      def => "total:FF0000;up:00C000;down:0080FF;bcast:C000FF;bogey:00B0B0",
      txt => "Colors used for graphing each state. 'total' can also be set." ,
      var => 'h',
    },
    state_patterns => {
      def => "total:7;up:1;down:2;bcast:4;bogey:5",
      txt => "Patterns used for graphing each state. 0 is empty and 3 is\n" .
          "solid. 1 and 2 are crosshatches, and 4-7 are stripes. See also\n" .
          "the \"patterns_default\" parameter.",
      var => 'h',
    },
    mtpred_colors => {
      def =>
          "last_year:FF0000;last_month:00C000;last_day:0080FF;last_hour:C000FF",
      txt => "Colors for displaying bars in the mtpred graph type.\n",
      var => 'h',
    },
    mtpred_patterns => {
      def => "last_year:1;last_month:2;last_day:4;last_hour:7",
      txt => "Patterns for displaying bars in the mtpred graph type. See\n" .
          "also the \"patterns_default\" parameter.",
      var => 'h',
    },
    patterns_default => {
      def => 0,
      txt => "If enabled, Captrap will generate graphs with patterns by\n" .
          "default. This doesn't look as good, but may be useful for the\n" .
          "colorblind.",
      var => 's',
    },
    caps => {
      def => undef,
      txt => "Transfer caps per state for different intervals. The format\n" .
          "of this is: 'state1:year,month,day,hour;state2:year,month...'\n" .
          "Leave a spot empty to indicate no cap. For example:\n" .
          "caps = total:,250000000000;up:,,10000000000\n" .
          "This specifies a monthly total cap of 250000000000 bytes and a\n" .
          "daily upload cap of 10000000000 bytes.",
      var => 'ha',
    },
    cap_show_percent => {
      def => 75,
      txt => "If the highest bar in a graph is at least this percentage of\n" .
          "a cap, the graph will be scaled to fit the cap and a line will\n" .
          "be drawn. Set this to 0 to always show caps.",
      var => 's',
    },
    stylesheet => {
      def => 'captrap.css',
      txt => "Stylesheet to be used in HTML files. If you wish to use an\n" .
          "alternate stylesheet, place it in the same directory as the CGI\n" .
          "scripts and set this parameter to the file name (without the\n" .
          "path).",
      var => 's',
    },
  );
  return $info;
}


=item mk_config_info_priv()

Return a reference to a hash of all the configuration parameters in the
privileged-user config file.

=cut

sub mk_config_info_priv () {
  my $info = mk_ixhash();
  %$info = (
    db_user_priv => {
      def => "pmacctd",
      txt => "database username (privileged)",
      var => 's',
    },
    db_password_priv => {
      def => undef,
      txt => "database password (privileged; MUST be defined in config file)",
      var => 's',
    },
  );
  return $info;
}


=item config_file_path()

Return the path to the main config file (this is hardcoded, for now).

=cut

sub config_file_path () {
  return "/etc/captrap/captrap.conf";
}


=item parse_config()

Parse the main configuration file and return the results.

=cut

sub parse_config {
  return parse_config_file(mk_config_info(), config_file_path());
}


=item parse_config_priv()

Parse the privileged-user configuration file and return the results.

=cut

sub parse_config_priv {
  my $config = shift;
  my $check = shift;
  my $file = $config->{priv_conf};
  my $priv = parse_config_file(mk_config_info_priv(), $file);
  if ($check) {
    foreach my $line (qw(db_user_priv db_password_priv)) {
      unless (defined($priv->{$line})) {
        print STDERR "no '$line' listed in $file\n";
        exit(1);
      }
    }
  }
  return $priv;
}


# parse a config file and apply defaults
sub parse_config_file {
  my $config_info = shift;
  my $config_file = shift;
  my $config = {};
  # first check if the file exists
  if (-f $config_file) {
    # Ok, go ahead and read it. This is a race condition, but the worst case is
    # that read_config_file() will die.
    $config = read_config_file($config_file);
  } else {
    print STDERR
        "Captrap: warning: using defaults for absent config file \"",
        $config_file, "\"\n";
  }
  # check for unknown parameters
  foreach my $key (keys(%$config)) {
    next if defined($config_info->{$key});
    print STDERR
        "Captrap: warning: unrecognized configuration parameter \"$key\"\n";
  }
  # apply defaults
  foreach my $key (keys(%$config_info)) {
    next if defined($config->{$key});
    $config->{$key} = $config_info->{$key}->{def};
  }
  # convert strings into arrays, etc.
  # When adding something here, be sure to add the reverse to make_config_val()
  # in captrap_mkconfig.
  foreach my $key (keys(%$config_info)) {
    my $var = $config_info->{$key}->{var};
    next if $var eq 's'; # scalar; nothing to do
    if ($var eq 'a') { # array
      $config->{$key} = [ l2a($config->{$key}) ];
    } elsif ($var eq 'h') { # hash
      $config->{$key} = l2h($config->{$key});
    } elsif ($var eq 'ha') { # hash of arrays
      $config->{$key} = l2ha($config->{$key});
    } else {
      die "unknown variable type '$var' for $key";
    }
  }
  return $config;
}

# -----------------------------------------------------------------------------
# "action" argument parsing and handling
# -----------------------------------------------------------------------------

=item describe_actions($actions)

Use a hash of available actions to write a text description for each action.

=cut

sub describe_actions {
  my $actions = shift;
  my $text;
  while (my ($name, $action) = each %$actions) {
    my $arglist = join(" ", @{$action->{args}});
    $text .= "$name $arglist$action->{desc}\n";
  }
  return $text;
}


=item check_args($args, $actions)

Check if all supplied arguments are valid actions. Exits if there is a problem.

=cut

sub check_args {
  my $args = shift; # array ref
  my $actions = shift; # hash ref
  for (my $i = 0; $i < @$args; ++$i) {
    my $arg = $args->[$i];
    unless (defined $actions->{$arg}) {
      my $num = $i + 1; # perl starts counting at 0
      print STDERR "Error: argument #$num is invalid: $arg\n";
      exit(2);
    }
    my $num = @{$actions->{$arg}->{args}};
    $i += $num;
    unless ($i < @$args) {
      print STDERR "Error: insufficient arguments for $arg ($num required)\n";
      exit(2);
    }
  }
}


=item do_args($common, $args, $actions)

Do all specified actions. All args are assumed to be valid, so be sure to run
check_args() first.

=cut

sub do_args {
  my $common = shift;
  my $args = shift; # array ref
  my $actions = shift; # hash ref
  for (my $i = 0; $i < @$args; ++$i) {
    my $arg = $args->[$i];
    my $action = $actions->{$arg};
    my $func = $action->{func};
    # array slices are inclusive, so [2..2] would give index 2
    # for an empty slice, [2..1] works
    my $start = $i + 1;
    my $end = $i + @{$action->{args}};
    do_or_die($func, $common, @$args[$start..$end]);
    $i = $end;
  }
}


# do some function or exit if the function returns non-zero
sub do_or_die {
  my $func = shift; # function ref
  my $ret = &$func(@_);
  exit($ret) if $ret;
}


# check parameters/values for validity
# returns undef if a parameter or value is bad, in which case
# $$err will have a message
sub check_params {
  my $params = shift;
  my $param_info = shift; # hash ref
  my $err = shift; # scalar ref
  # if there aren't any parameters, break out early; it's up to the caller to
  # print a usage page or something.
  if (! keys(%$params)) {
    return $params;
  }
  # first check if all parameters are valid
  while (my ($name, $param) = each %$params) {
    unless (defined($param_info->{$name})) {
      $$err = "unrecognized parameter: $name";
      # reset "each" counter (this was a vexing bug)
      values(%$params);
      return undef;
    }
  }
  my $ok_params;
  # next check values and set undef values based on defaults
  foreach my $name (keys %$param_info) {
    my $values = $params->{$name};
    # at this point, $values should be undef or an array ref (even for scalar
    # parameters)
    # cull undefined values; treat blank as undef
    $values = [ grep { defined($_) && $_ ne ""} @$values ];
    # after culling undef values, the array might be empty
    unless (@$values) {
      # if so, use the default
      $ok_params->{$name} = $param_info->{$name}->{def};
      next;
    }
    # check values against regex
    foreach my $value (@$values) {
      unless ($value =~ $param_info->{$name}->{reg}) {
        $$err = "invalid value for parameter \"$name\": $value";
        return undef;
      }
      # value looks ok; use $& so parameter is untainted
      $value = $&;
    }
    # handle scalar/array types
    if ($param_info->{$name}->{var} eq 's') {
      if (@$values > 1) {
        $$err = "multiple values set for parameter \"$name\"";
        return undef;
      }
      # ok
      $ok_params->{$name} = $values->[0];
    } elsif ($param_info->{$name}->{var} eq 'a') {
      # multiple values ok
      $ok_params->{$name} = $values; # array ref
    } else {
      die "unknown \"var\" field for \"$name\"";
    }
  }
  return $ok_params;
}

# -----------------------------------------------------------------------------
# file writing argument parsing and handling
# -----------------------------------------------------------------------------

# get a raw hash of supplied parameters
sub arg_get_raw_params {
  my $arg = shift;
  my $params = {};
  # make a hash of all parameters
  foreach my $pair (split(/&/, $arg)) {
    my ($param, $value) = split(/=/, $pair);
    # treat everything as an array for now
    push(@{$params->{$param}}, $value);
  }
  return $params;
}


# get parameters from an argument
sub arg_get_params {
  my $arg = shift;
  my $param_info = shift;
  my $err = shift; # scalar ref
  # get a hash of all parameters
  my $params = arg_get_raw_params($arg);
  # now check them
  return check_params($params, $param_info, $err);
}


=item arg_handle_params($common, $param_info, $func, $arg, $file)

Like cgi_handle_params(), but for a command-line environment rather than CGI.

=cut

sub arg_handle_params {
  my $common = shift; # hash ref
  my $param_info = shift; # hash ref
  my $func = shift; # function ref
  my $arg = shift;
  my $file = shift;
  my $err;
  my $params = arg_get_params($arg, $param_info, \$err);
  if (defined($params)) {
    return &{$func}($common, $params, $file);
  }
  arg_bad_params($arg, $param_info, $err);
  return undef;
}


# print a parameter list for debug
sub arg_bad_params {
  my $arg = shift;
  my $param_info = shift;
  my $err = shift;
  print STDERR "Error:\n$err\n\n";
  my $params = arg_get_raw_params($arg);
  raw_bad_params($params, $param_info);
}


# print a parameter list for debug; the parameters must be parsed already
sub raw_bad_params {
  my $params = shift;
  my $param_info = shift;
  my $list;
  while (my ($param, $values) = each %$params) {
    my $v = array_to_print($values);
    $list .= "$param: $v\n";
  }
  print STDERR "All Supplied Parameters:\n\n$list\n";
  print STDERR "Valid Parameters:\n\n";
  arg_list_params($param_info);
}


=item arg_list_params($common, $param_info, $func)

Like cgi_list_params(), but for a command-line environment rather than CGI.

=cut

sub arg_list_params {
  my $param_info = shift; # hash ref
  foreach my $param (keys %$param_info) {
    print STDERR "< $param >\n";
    print STDERR "$param_info->{$param}->{txt}\n";
    my $def = $param_info->{$param}->{def};
    if (!defined($def)) {
      $def = "(undefined)";
    } else {
      if ($param_info->{$param}->{var} eq 'a') {
        # array type
        if (@$def) {
          $def = array_to_print(@$def);
        } else {
          $def = "(empty array)";
        }
      } else {
        # scalar type
        $def = "\"$def\"";
      }
    }
    print STDERR "default: $def\n";
    print STDERR "\n";
  }
}


=item write_output_fo_file($common, $params, $file, $func)

Write the output of a function to a specified file. $func is a reference to the
function to be run; $params is a reference to the parameters to be supplied to
the function.

=cut

sub write_output_to_file {
  my $common = shift;
  my $params = shift;
  my $file = shift;
  my $func = shift;
  my $extension_ref = shift; # scalar reference
  my $extension;
  my $output = &{$func}($common, $params, \$extension);
  unless (defined($output)) {
    exit(3);
  }
  # skip out early if we're just printing to STDOUT
  if ($file eq "-") {
    print $output;
    return undef;
  }
  # so, now we need to open and write a file
  if (defined($extension_ref)) {
    $file .= ".$extension";
    $$extension_ref = $extension;
  }
  if (-e $file) {
    print STDERR "\"$file\" already exists; not overwriting\n";
    exit(3);
  }
  my $fh;
  unless (open($fh, ">", $file)) {
    print STDERR "problem opening \"$file\" for writing: $!\n";
    exit(3);
  }
  print $fh $output;
  # cleanup
  unless (close($fh)) {
    print STDERR "error closing handle for \"$file\": $!\n";
    exit(3);
  }
  return $output;
}


=item params_input_to_output($param_info, $params)

Input parameters (such as those passed to the CGI routines) are parsed to be
either scalars or arrays (array refs), but output parameters such as those
passed to mk_link() need to all be array refs. This subroutine converts a hash
of input parameters to ouput parameters according to the type defined in
$param_info.

=cut

sub params_input_to_output {
  my $param_info = shift;
  my $params = shift;
  my $out;
  foreach my $name (keys %$params) {
    my $param = $params->{$name};
    my $var = $param_info->{$name}->{var};
    if ($var eq 's') {
      $out->{$name} = [ $param ];
    } elsif ($var eq 'a') {
      $out->{$name} = $param;
    } else {
      die "unknown \"var\" field for \"$name\"";
    }
  }
  return $out;
}

# -----------------------------------------------------------------------------
# debug
# -----------------------------------------------------------------------------

# parse and print an sql query
sub debug_sql {
  my $dbh = shift;
  my $stmt = shift;
  my $args = shift; # array ref
  $stmt =~ s/\s+/ /g; # todo: combine these
  $stmt =~ tr/\n/ /;
  print STDERR quote_sql_stmt($dbh, $stmt, $args)
}


1;

=back

=head1 AUTHOR

Corey Hickey <bugfood-c@fatooh.org>

This library is free software; you may redistribute and/or modify it under the
terms of the GNU General Public License, version 3. See the source file for the
usual GPL preamble and the COPYING file for a copy of the GPL.

=head1 SEE ALSO

Captrap::Graph, Captrap::View, Captrap::Main, any Captrap CGI or command-line
program

=cut