#!@@PERL@@ -w
# -*- cperl -*-
#
# Copyright (C) 2002-2009 Jimmy Olsen, Audun Ytterdal
#
# This program 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; version 2 dated June,
# 1991.
#
# This program 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 this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
#
# Script to update the RRD-files with current information.
#

use strict;

$|=1;

use Carp;
use English qw(-no_match_vars);
use Getopt::Long;
use IO::Socket;
use Munin::Common::Defaults;
use Munin::Common::Timeout;
use Munin::Common::TLSClient;
use Munin::Master::Logger;
use Munin::Master::Utils;
use POSIX ":sys_wait_h";
use RRDs;
use Storable qw(fd_retrieve nstore_fd);
use Time::HiRes;

my $DEBUG=0;
my $STATS;
my $cli_do_fork;
my $cli_timeout;
my $conffile = "$Munin::Common::Defaults::MUNIN_CONFDIR/munin.conf";
my $config;
my $do_fork = 1;
my $serversocket  = "munin-server-socket.$$";
my $timeout = 180;
my $tls;
my %children = ();
my @limit_hosts = ();
my @limit_services = ();
my @queue = ();



sub main {
    my $TIMEOUT = 240;
    my $oldconfig;

    parse_args();
    exit_if_run_by_super_user();

    $config = munin_readconfig_base($conffile);

    logger_open($config->{'logdir'});

    $oldconfig = &munin_readconfig_part('datafile', 1);
    
    # CLI parameters override the configuration file.
    if (defined $cli_timeout) {
        $timeout = $cli_timeout;
    } elsif (exists $config->{'timeout'}) {
        $timeout = $config->{'timeout'};
    }

    if (defined $cli_do_fork) {
        $do_fork = $cli_do_fork;
    } elsif (exists $config->{'fork'}) {
        $do_fork = ($config->{'fork'} =~ /yes/i ? 1 : 0);
    }

    if (! -d $config->{rundir}) {
	mkdir ($config->{rundir}, oct(700));
    }

    munin_runlock("$config->{rundir}/munin-update.lock");

    if (!open ($STATS,'>', "$config->{dbdir}/munin-update.stats.tmp")) {
        logger("[WARNING] Unable to open $config->{dbdir}/munin-update.stats");
        # Use /dev/null instead - if the admin won't fix he won't care
        open($STATS, '>', "/dev/null") or die "Could not open STATS to /dev/null: $?";
    }

    if ($do_fork) {
        set_up_ipc_socket();
    }

    logger("Starting munin-update");

    my @work = find_hosts_for_update();
    @queue   = build_work_queue($oldconfig, @work);

    do_some_work($TIMEOUT);

    unlink ("$config->{rundir}/$serversocket");

# XXX: WTF is that ?
#    {
#        my $overwrite = munin_readconfig($conffile);
#        $config = munin_overwrite($config, $overwrite);
#    }

    compare_configs ($oldconfig, $config);

    if (munin_getlock("$config->{rundir}/munin-datafile.lock")) {
        munin_writeconfig("$config->{dbdir}/datafile",$config);
    } else {
        die "Could not create lockfile '$config->{rundir}/munin-update.lock'";
    }


    write_stats_and_log_update_time();

    munin_removelock("$config->{rundir}/munin-datafile.lock");
    munin_removelock("$config->{rundir}/munin-update.lock");

    return 0;
}


sub parse_args {
    my $do_usage = 0;
    my $do_version = 0;

    # Get options
    print_usage_and_exit() unless GetOptions (
        "host=s"       => \@limit_hosts,
        "service=s"    => \@limit_services,
        "config=s"     => \$conffile,
        "debug!"       => \$DEBUG,
        "version!"     => \&print_version_and_exit,
        "fork!"        => \$cli_do_fork,
        "timeout=i"    => \$cli_timeout,
        "help"         => \&print_usage_and_exit
    );
}

sub print_usage_and_exit {
    print qq{Usage: $0 [options]

Options:
    --version		View version information.
    --help		View this message.
    --service <service>	Limit graphed services to <service>. Multiple --service
			options may be supplied.
    --host <host>	Limit graphed hosts to <host>. Multiple --host options
    			may be supplied.
    --config <file>	Use <file> as configuration file. 
    			[$Munin::Common::Defaults::MUNIN_CONFDIR/munin.conf]
    --[no]debug		View debug messages. [--nodebug]
    --[no]fork		Don't fork one instance for each host. [--fork]
    --timeout=<seconds>	TCP timeout when talking to clients. [$timeout]

};
    exit 0;
}

sub print_version_and_exit {
    print qq{munin-update version $Munin::Common::Defaults::MUNIN_VERSION.
Written by Audun Ytterdal, Jimmy Olsen, Tore Anderson / Linpro AS

Copyright (C) 2002-2009

This is free software released under the GNU General Public License. There
is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR
PURPOSE. For details, please refer to the file COPYING that is included
with this software or refer to
  http://www.fsf.org/licensing/licenses/gpl.txt
};
    exit 0;
}


sub exit_if_run_by_super_user {
    if ($EFFECTIVE_USER_ID == 0) {
        print qq{This program will easily break if you run it as root as you are
trying now.  Please run it as user '$Munin::Common::Defaults::MUNIN_USER'.  The correct 'su' command
on many systems is 'su - munin --shell=/bin/bash'
Aborting.\n\n};
        exit 1;
    }
}


sub set_up_ipc_socket {
    my $socket_file = "$config->{rundir}/$serversocket";
    my $uaddr =  sockaddr_un($socket_file);
    socket Server, PF_UNIX, SOCK_STREAM, 0
        or die "socket: $!";
    unlink $socket_file;
    bind Server, $uaddr;
    chmod oct(700), $socket_file;
    listen Server, SOMAXCONN;
}


sub find_hosts_for_update {
    my @hosts = ();
    if (@limit_hosts) {
        for my $nodename (@limit_hosts) {
            push @hosts, map { 
                @{munin_find_field ($_->{$nodename}, "address")} 
            } @{munin_find_field($config, $nodename)};
        }
    } 
    else {
        push @hosts, @{munin_find_field($config, "address")};
    }

    return @hosts;
}


sub build_work_queue {
    my ($oldconfig, @work) = @_;

    # Go through scheduled work to weed out a few bits, and prepare some info
    for my $host (@work) {
        my $loc  = munin_get_node_loc($host);
        my $name = munin_get_node_name($host);

        # Skip anything that has been disabled with the "update" setting
        if (!munin_get_bool ($host, "update", "true")) {
            logger ("Skipping \"$name\" (update disabled by config)");
            next;
        }

        # We need to connect to this node; queue it
        logger ("Queuing \"$name\" for update.");
        push (@queue, [$loc, $host, munin_get_node ($oldconfig, $loc)]);
    }

    return @queue;
}


sub start_parallell_do_node {
    if (defined $config->{max_processes}) {
        while (keys %children  <  ($config->{max_processes} - 1)) {
            do_node(@{pop @queue});
        }
    } 
    else {
        do_node(@{pop @queue}) while @queue; # No limit on number of procs
    }
}

# FIX better name :)
sub do_some_work {
    my ($TIMEOUT) = @_;

    my $bad_procs = 0;
    do_with_timeout($TIMEOUT, sub {
        if ($do_fork) {
            start_parallell_do_node();
            # Loop as long as there are kids or queue...
            while ((scalar (keys %children) - $bad_procs > 0) or @queue) {
                
                logger ("Debug: Doing a pass to check children status.") if $DEBUG;
            
                my $timed_out = !do_with_timeout(10, sub {
                    accept (Client, Server);
                }); # end eval

                if ($timed_out) {
                    foreach my $key (keys %children) {
                        if (waitpid ($key, WNOHANG) != 0) {
                            my $loc     = $children{$key}->[0];
                            my $newnode = $children{$key}->[1];
                            my $oldnode = $children{$key}->[2];
                            my $name    = munin_get_node_name ($newnode);
                            
                            logger ("Reaping child: $name.");
                            delete $children{$key};
                            munin_copy_node_toloc ($oldnode, $config, $loc);
                        }
                    }

                    if (@queue and defined $config->{max_processes} and $config->{max_processes}) {
                        logger ("Debug: Checking whether to spawn off more procs from queue.");
                        while (keys %children < ($config->{max_processes}-1-$bad_procs)) {
                            logger ("Debug: Popping queue item and spawning new proc.");
                            do_node(@{pop @queue});
                        }
                    }
            
                    next;
                }

                close STDIN;
                ## no critic
                open (STDIN,  "<&Client")  || die "can't dup client to stdin";
                ## critic

                my $pid;
                my $name;
                my $loc;
                my $tmpref;
                eval {
                    $tmpref = fd_retrieve (\*STDIN);
                };
                if ($@) {
                    $bad_procs++;
                    logger ("[WARNING] Error communicating with process: $@");
                } else {
                    ($pid, $loc, $name) = ($tmpref->[0], $tmpref->[1], $tmpref->[2]);
                    logger ("connection from $name ($pid)");

                    eval {
                        my $newnode = fd_retrieve (\*STDIN);
                        munin_copy_node_toloc ($newnode, $config, $loc);
                    };
                    if ($@) {
                        logger ("[WARNING] Error during fd_retrieve of config: $@");
                    
                        my $loc     = $children{$pid}->[0];
                        my $newnode = $children{$pid}->[1];
                        my $oldnode = $children{$pid}->[2];

                        munin_copy_node_toloc ($oldnode, $config, $loc);
                    }
                    delete $children{$pid};
                    waitpid ($pid, 0);
                    logger ("connection from $name ($pid) closed");
                }
                if (@queue and defined $config->{max_processes} and
                        $config->{max_processes} and
                            scalar (keys %children) < (($config->{max_processes})-1-$bad_procs)) {
                    do_node(@{pop @queue});
                    close (Client);
                }
            }
        } else {     # No forking, just poll the nodes sequentially...
            while (@queue) {
                do_node(@{pop @queue});
            }
        }
    }) or die "Timed out waiting for children.\n";

    if ($bad_procs) # Use old configuration for killed children
    {
	foreach my $key (keys %children)
	{
            my $loc     = $children{$key}->[0];
            my $newnode = $children{$key}->[1];
            my $oldnode = $children{$key}->[2];
            my $name    = munin_get_node_name ($newnode);
            
            munin_copy_node_toloc ($oldnode, $config, $loc);
            logger ("Attempting to use old configuration for $name.");
	}
    }
}


sub write_stats_and_log_update_time {
    my $update_time= Time::HiRes::time;
    $update_time = sprintf ("%.2f",(Time::HiRes::time - $update_time));
    print $STATS "UT|$update_time\n";
    close ($STATS);
    rename ("$config->{dbdir}/munin-update.stats.tmp", "$config->{dbdir}/munin-update.stats");
    
    logger("Munin-update finished ($update_time sec)");
}



# compare_configs is used to monitor for config changes which we
# have to act upon.
sub compare_configs {
    my $old = shift;
    my $new = shift;
    my $just_upgraded = 0;

    if (!defined $old->{version} or $old->{version} ne $Munin::Common::Defaults::MUNIN_VERSION) {
	$just_upgraded = 1;
    }

    foreach my $node (@{munin_find_field($new, "label")}) {
	my $oldnode = munin_get_node ($old, munin_get_node_loc ($node));
	my $name    = munin_get_node_name ($node);
	my ($oldval, $newval);

	$oldval = munin_get ($oldnode, "max", "");
	$newval = munin_get ($node, "max", "");
	if ($just_upgraded or $oldval ne $newval) {
	    logger ("Notice: compare_configs: $name.max changed from ".(length $oldval?$oldval:"undefined")." to $newval.");
	    change_max (munin_get_filename ($node), $newval);
	}

	$oldval = munin_get ($oldnode, "min", "");
	$newval = munin_get ($node, "min", "");
	if ($just_upgraded or $oldval ne $newval) {
	    logger ("Notice: compare_configs: $name.min changed from ".(length $oldval?$oldval:"undefined")." to $newval.");
	    change_min (munin_get_filename ($node), $newval);
	}

	$oldval = munin_get ($oldnode, "type", "GAUGE");
	$newval = munin_get ($node, "type", "GAUGE");
	if ($just_upgraded or $oldval ne $newval) {
	    logger ("Notice: compare_configs: $name.type changed from ".(length $oldval?$oldval:"undefined")." to $newval.");
	    change_type (munin_get_filename ($oldnode), munin_get_filename ($node), $newval);
	}
    }
}

sub change_type
{
    my $ofile  = shift;
    my $nfile  = shift;
    my $val    = shift;

    if (defined $ofile and -f $ofile) {
	logger ("[WARNING]: Changing name of $ofile to $nfile");
	unless (rename ($ofile, $nfile)) {
	    logger ("[ERROR]: Could not rename file: $!\n");
	}
    }

    logger ("INFO: Changing type of $nfile to " . (defined $val?$val:"GAUGE"));
    RRDs::tune ($nfile, "-d", "42:".(defined $val?$val:"GAUGE"));
}

sub change_max
{
    my $file  = shift;
    my $val   = shift;

    logger ("[WARNING]: Changing max of \"$file\" to \"$val\".\n");
    RRDs::tune ($file, "-a", "42:".(defined $val?$val:"U"));
}

sub change_min
{
    my $file  = shift;
    my $val   = shift;

    logger ("[WARNING]: Changing min of \"$file\" to \"$val\".\n");
    RRDs::tune ($file, "-i", "42:".(defined $val?$val:"U"));
}

sub do_node {
  my ($loc, $newconf, $oldconf) = @_;
  return unless munin_get ($newconf, "update", "true"); # Skip unless we're updating it
  return unless munin_get ($newconf, "fetch_data", "true"); # Old name for "update"

  my $name = munin_get ($newconf, "host_name") || munin_get_node_name ($newconf);

  unless ($newconf->{"address"}) {
      logger("[ERROR] No address defined for node: $name");
      return;
  }
  logger ("Debug: do_node: Starting on \"$name\".") if $DEBUG;

  # Then we fork...
  if ($do_fork)
  {
      my $pid = fork;
      if (!defined($pid)) 
      { # Something went wrong
	      logger ("Error: Unable to fork: $!"); 
	      return; 
      } elsif ($pid) 
      { # I'm the parent
	      $children{$pid} = [$loc, $newconf, $oldconf];
	      return; 
      } # else I'm the child -- go spawn
  }

  $0 .= " [$name]";

  # First we get lock...
  unless (&munin_getlock(munin_get($newconf, "rundir")."/munin-".join('-',@{munin_get_node_loc($newconf)})."-".munin_get_node_name($newconf).".lock")) {
    logger ("[ERROR] Could not get lock for \"$name\". Skipping node.");
    if ($do_fork) { # Send the old config to the server before we die
        alarm (0); # Don't want to interrupt this.
	my @tmp = ($$, munin_get_node_loc($newconf), $name);
	if (ref $oldconf) {
	  copy_node ($oldconf, $newconf);
          write_refs_to_parent($newconf, \@tmp, \%{munin_get_separated_node ($newconf)});
	} else { # Well, we'll have to give _something_ to the server, or it'll time out.
          write_refs_to_parent($newconf, \@tmp, {});
	}
	exit 1;
    } else {
	return 0;
    }
  }

  my $socket;
  
  if (munin_get ($newconf, "local_address"))
  {
      $socket = new IO::Socket::INET ('PeerAddr' => "$newconf->{address}:".
	          munin_get ($newconf, "port", "4949"), 
		  'LocalAddr' => munin_get ($newconf, "local_address", undef),
		  'Proto'    => "tcp", "Timeout" => munin_get($newconf, "timeout", 60));
  } else {
      $socket = new IO::Socket::INET ('PeerAddr' => "$newconf->{address}:".
	          munin_get ($newconf, "port", "4949"), 
		  'Proto'    => "tcp", "Timeout" => munin_get($newconf, "timeout", 60));
  }
  my $err = ($socket ? "" : $!);

  if ($do_fork) {
      $SIG{ALRM} = sub { close $socket; die "$!\n"};
      alarm ($timeout);

      my @tmp = ($$, munin_get_node_loc ($newconf), $name);

      if (!$socket) {
	logger ("[ERROR] Could not connect to $name($newconf->{address}): $err - Attempting to use old configuration");
	# If we can't reach the client. Using old Configuration.
	if (ref $oldconf) {
	  copy_node ($oldconf, $newconf);
	  alarm (0); # Don't want to interrupt this.
          write_refs_to_parent($newconf, \@tmp, \%{munin_get_separated_node ($newconf)});
	} else { # Well, we'll have to give _something_ to the server, or it'll time out.
          write_refs_to_parent($newconf, \@tmp, {});
	}
      } 
      else {
          my $ctx;
          if (!config_and_fetch_node($newconf,$oldconf,$socket)) {
              copy_node ($oldconf, $newconf);
              write_refs_to_parent($newconf, \@tmp, \%{munin_get_separated_node ($newconf)});
              exit 1;
          }
          close $socket;
          alarm (0); # Don't want to interrupt this.
          write_refs_to_parent($newconf, \@tmp, \%{munin_get_separated_node ($newconf)});
          alarm ($timeout);
      }
      alarm (0);
      munin_removelock(munin_get($newconf, "rundir")."/munin-".join('-',@{munin_get_node_loc($newconf)})."-".munin_get_node_name($newconf).".lock");
      exit;
  }
  else # No forking...
  {
      if (!$socket) {
	logger ("[ERROR] Could not connect to $name($newconf->{address}): $err\nAttempting to use old configuration");
	# If we can't reach the client. Using old Configuration.
	if (ref $oldconf) {
	    copy_node ($oldconf, $newconf);
	}
      } else {
		next unless (config_and_fetch_node($newconf,$oldconf,$socket));
		close $socket;
      }

  }
  munin_removelock(munin_get($newconf, "rundir")."/munin-".join('-',@{munin_get_node_loc($newconf)})."-".munin_get_node_name($newconf).".lock");
}


sub write_refs_to_parent {
    my ($conf, @refs) = @_;

    socket my $sock, PF_UNIX, SOCK_STREAM, 0
        or die "socket: $!";
    connect $sock, sockaddr_un(munin_get($conf, "rundir")."/$serversocket")
        or die "connect: $!";
    for my $ref (@refs) {
        nstore_fd($ref, $sock)
            or die "Could not nstore_fd: $!";
    }
    close $sock;
}


sub write_socket_single {
    my $socket = shift;
    my $text   = shift;
    logger ("[DEBUG] Writing to socket: \"$text\".") if $DEBUG;
    my $timed_out = !do_with_timeout(5, sub { 
	if ($tls && $tls->session_started()) {
	    $tls->write($text)
                or exit 9;
	}
	else {
	    print $socket $text;
	}
    });
    if ($timed_out) {
	logger ("[WARNING] Socket write timed out\n");
	return;
    }
    return 1;
}

sub read_socket_single {
    my $socket = shift;
    my $res;

    return unless defined $socket;

    my $timed_out = !do_with_timeout($timeout, sub { 
      if ($tls && $tls->session_started()) {
	  $res = $tls->read();
      }
      else {
	  $res = <$socket>;
      }
      chomp $res if defined $res;
    });
    if ($timed_out) {
	logger ("[WARNING] Socket read timed out\n");
	return;
    }
    logger ("[DEBUG] Reading from socket: \"$res\".") if $DEBUG;
    return $res;
}

sub read_socket {
    my $socket = shift;
    my @array;

    return unless defined $socket;

    local $_;

    my $timed_out = !do_with_timeout($timeout, sub { 
      if ($tls && $tls->session_started()) {
	  while (defined ($_ = $tls->read())) {
	    chomp;
	    last if (/^\.$/);
	    push @array, $_;
	  }
      }
      else {
	  while (<$socket>) {
	    chomp;
	    last if (/^\.$/);
	    push @array, $_;
	  }
      }
    });
    if ($timed_out) {
	logger ("[WARNING] Socket read timed out: $@\n");
	return;
    }
    logger ("[DEBUG] Reading from socket: \"".(join ("|",@array))."\".") if $DEBUG;
    return (@array);
}


sub read_socket_discard_comments {
    my ($socket) = @_;

    my @chunks = read_socket($socket);
    return grep { $_ !~ /^#/} @chunks;
}


sub config_and_fetch_node 
{
    my ($newconf,$oldconf,$socket) = @_;

    my $fetchdomain;
    my $name = munin_get_node_name ($newconf);
    my $host_time = Time::HiRes::time;

    my $clientdomain = eval {
        get_node_domain($socket);
    };
    if ($EVAL_ERROR) {
	logger("[WARNING] $EVAL_ERROR '$name' skipping");
	return 0;
    }

    # Decide what to ask for
    if (munin_get_bool ($newconf, "use_node_name")) {
	$fetchdomain = $clientdomain;
    } else {
	$fetchdomain = $name;
    }

    run_starttls_if_required($socket, $name);

    negotiate_capabilities($socket);

    logger("[DEBUG] Configuring node: $name") if $DEBUG;
    my @services;
    my $timed_out = !do_with_timeout(5, sub {
        write_socket_single($socket, "list $name\n");
        my $list = read_socket_single($socket);
        exit 1 unless defined $list;
        chomp $list;
        @services = split / /,$list;
    });
    if ($timed_out) {
	logger ("Error: Could not get list from $newconf->{address}: $!\nAttempting to use old configuration");
	if (ref $oldconf) {
	    copy_node ($oldconf, $newconf);
	}
	@services = [];
    }

    for my $service (@services) {
	my $servname = $service;
	$servname =~ s/\W/_/g;
        config_node_service($oldconf, $newconf, $socket, $servname, $service);
	fetch_node_service ($newconf, $socket, $servname, $service);
    }
    $host_time = sprintf ("%.2f", (Time::HiRes::time - $host_time));
    print $STATS "UD|$name|$host_time\n";
    return 0 unless $socket;
    return 1;
}


sub get_node_domain {
    my ($socket) = @_;

    my $node_domain = read_socket_single ($socket);
    croak "Got no reply from node"
        unless $node_domain;
    chomp $node_domain;
    $node_domain =~ s/\#.*(?:lrrd|munin) (?:client|node) at //
        or croak "Got unknown reply from node";


    return $node_domain;
}



sub run_starttls_if_required {
    my ($socket, $name) = @_;

    # TLS should only be attempted if explicitly enabled. The default
    # value is therefore "disabled" (and not "auto" as before).
    my $tls_requirement = &munin_get ($config, "tls", "disabled");
    logger ("[DEBUG]: TLS set to \"$tls_requirement\".") if $DEBUG;
    if ($tls_requirement ne "disabled") {
        my $key;
        my $cert;
	my $depth;
	my $ca_cert;
	my $tls_verify;
        $key = $cert = munin_get ($config, "tls_pem");
        $key = &munin_get ($config, "tls_private_key", "$Munin::Common::Defaults::MUNIN_CONFDIR/munin.pem")
  	  unless defined $key;
        $cert = &munin_get ($config, "tls_certificate", "$Munin::Common::Defaults::MUNIN_CONFDIR/munin.pem")
  	  unless defined $cert;
        $ca_cert = &munin_get ($config, "tls_ca_certificate", "$Munin::Common::Defaults::MUNIN_CONFDIR/cacert.pem")
           unless defined $ca_cert;
        $tls_verify=&munin_get ($config, "tls_verify_certificate", "no");
        $depth=&munin_get ($config, "tls_verify_depth", 5);
  
        $tls = Munin::Common::TLSClient->new({
            DEBUG        => $DEBUG,
            logger       => \&logger,
            read_fd      => fileno($socket),
            read_func    => sub { read_socket_single($socket) },
            tls_ca_cert  => $ca_cert,
            tls_cert     => $cert,
            tls_paranoia => $tls_requirement, 
            tls_priv     => $key,
            tls_vdepth   => $depth,
            tls_verify   => $tls_verify,
            write_fd     => fileno($socket),
            write_func   => sub { write_socket_single($socket, @_) },
        });

        if (!$tls->start_tls()) {
            $tls = undef;
            if ($tls_requirement eq "paranoid" or $tls_requirement eq "enabled") {
                logger ("[ERROR]: Could not establish TLS connection to \"$name\". Skipping.");
                exit 13;
            }
        }
    }
}


sub negotiate_capabilities {
    my ($socket) = @_;

    my $capabilities = 'foo';

    write_socket_single($socket, "cap $capabilities\n");
    my ($cap) = read_socket_discard_comments($socket);

    logger("[DEBUG]: Session capabilities: $cap");# if $DEBUG;
}


sub config_node_service {
    my $oldconf      = shift; 
    my $newconf      = shift; 
    my $socket       = shift;
    my $service      = shift;
    my $servname = shift;

    my $fields = {};
    munin_set_var_loc ($newconf, [$servname, "realservname"], $service);
    logger("[DEBUG] Inspecting possible service: $servname") if $DEBUG;
    return if (!munin_get_bool ($newconf->{$servname}, "update", "true"));
    return if (!munin_get_bool ($newconf->{$servname}, "fetch_data", "true"));
    return if (@limit_services and !grep (/^$servname$/, @limit_services));
    
    my @graph_order = split (/\s+/, munin_get ($newconf->{$service}, "graph_order", ""));
    my $serviceconf_time = Time::HiRes::time;
    logger("[DEBUG] Configuring service: $servname") if $DEBUG;
    write_socket_single ($socket, "config $service\n");
    my @lines = read_socket($socket);
    return unless $socket;
    return unless (@lines);
    for (@lines) {
        if (/\# timeout/) {
            logger("Client reported timeout in configuration of $servname");
            if ($oldconf->{$servname}) {
                logger("Attempting to use old configuration");
                copy_node ($newconf->{$servname}, $oldconf->{$servname});
            } else {
                logger("Skipping configuration of $servname");
                delete $newconf->{$servname};
            }
        } elsif (/^(\w+)\.(\w+)\s+(.+)/) {
            my ($client,$type,$value) = ($1,$2,$3);
            $client = &sanitise_fieldname ($client, $fields);
            if (($type) and ($type eq "label")) {
                $value =~ s/\\/_/g; # Sanitise labels
                push (@graph_order,$client) unless grep (/^$client$/, @graph_order);
            }
            munin_set_var_loc ($newconf, [$servname, $client, $type], "$value");
            logger ("config: $servname->$client.$type = $value") if $DEBUG;
        } elsif (/(^[^\s\#]+)\s+(.+)/) {
            my ($keyword) = $1;
            my ($value) = $2;
            munin_set_var_loc ($newconf, [$servname, $keyword], "$value");
            logger ("Config: $servname->$keyword = $value") if $DEBUG;
            if ($keyword eq "graph_order") {
                @graph_order = split (/\s+/, $value);
            }
        }
    }
    for my $field (keys %{$newconf->{$servname}}) {
        # Skip anything that isn't a field
        next if $field =~ /^#%#/;
        next unless (ref ($newconf->{$servname}->{$field}) eq "HASH" and
                         defined ($newconf->{$servname}->{$field}->{"label"}));
        
        my $fhash = $newconf->{$servname}->{$field};
        
        # Check if file exists
        my $fname = munin_get_filename ($fhash);
        (my $dirname = $fname) =~ s/\/[^\/]+$//;
        
        if (! -f "$fname") {
            logger ("creating rrd-file for $servname->$field: \"$fname\"");
            munin_mkdir_p ($dirname, oct(777));
            my @args = ("$fname",
			"DS:42:".munin_get($fhash, "type", "GAUGE").":600:".
                            munin_get($fhash, "min", "U") . ":" .  munin_get($fhash, "max", "U"));
            
            my $resolution = &munin_get ($fhash, "graph_data_size", "normal");
            if ($resolution eq "normal") {
                push (@args,
                      "RRA:AVERAGE:0.5:1:576", # resolution 5 minutes
                      "RRA:MIN:0.5:1:576",
                      "RRA:MAX:0.5:1:576",
                      "RRA:AVERAGE:0.5:6:432", # 9 days, resolution 30 minutes
                      "RRA:MIN:0.5:6:432",
                      "RRA:MAX:0.5:6:432",
                      "RRA:AVERAGE:0.5:24:540", # 45 days, resolution 2 hours
                      "RRA:MIN:0.5:24:540",
                      "RRA:MAX:0.5:24:540",
                      "RRA:AVERAGE:0.5:288:450", # 450 days, resolution 1 day
                      "RRA:MIN:0.5:288:450",
                      "RRA:MAX:0.5:288:450");
            } elsif ($resolution eq "huge") {
                push (@args, "RRA:AVERAGE:0.5:1:115200"); # resolution 5 minutes, for 400 days
                push (@args, "RRA:MIN:0.5:1:115200"); # Three times? ARGH!
                push (@args, "RRA:MAX:0.5:1:115200"); # Three times? ARGH!
            }
            RRDs::create @args;
            if (my $ERROR = RRDs::error) {
                logger ("[ERROR] Unable to create \"$fname\": $ERROR");
            }
        }
    }
    munin_set_var_loc ($newconf, [$servname, "graph_order"], join(' ',@graph_order));
}

sub fetch_node_service {
    my $newconf      = shift; 
    my $socket       = shift;
    my $service      = shift;
    my $realservname = shift;

    write_socket_single ($socket, "fetch $realservname\n");
    my @lines = &read_socket($socket);
    return 0 unless $socket;
    my $fields = {};
    for (@lines) {
	next unless defined $_;
	if (/\# timeout/) {
	    logger("Client reported timeout in fetching of $service");
	} elsif (/(\w+)\.value\s+([\S:]+)\s*(\#.*)?$/) {
	    my $key = $1;
	    my $value = $2;
	    my $comment = $3;
	    my $when = "N";

	    if ($value =~ /^(\d+):(.+)$/) {
		$when = $1;
		$value = $2;
	    }

	    if ($value =~ /\d[Ee]([+-]?\d+)$/) {
		# Looks like scientific format.  RRDtool does not
		# like it so we convert it.
		my $magnitude = $1;
		if ($magnitude < 0) {
		    # Preserve at least 4 significant digits
		    $magnitude=abs($magnitude)+4;
		    $value=sprintf("%.*f",$magnitude,$value);
		} else {
		    $value=sprintf("%.4f",$value);
		}
	    }

	    $key = &sanitise_fieldname ($key, $fields);
	    if (exists $newconf->{$service}->{$key}->{"label"}) {
		my $fname = munin_get_filename ($newconf->{$service}->{$key});

		logger("[DEBUG] Updating $fname with $value") if $DEBUG;
		RRDs::update ("$fname", "$when:$value");
		if (my $ERROR = RRDs::error) {
		    logger ("[ERROR] In RRD: unable to update $fname: $ERROR");
		}
	    } else {
		logger ("[ERROR] Unable to update $service -> $key: No such field (no \"label\" field defined when running plugin with \"config\").");
	    }
	} elsif (/(\w+)\.extinfo\s+(.+)/) {
            # FIX never used?
	    munin_set_var_loc ($newconf, [$service, $service, $1, "extinfo"], $2);
	}
    }
    return 1;
}


# FIX never called?
sub fetch_node 
{
    my ($newconf,$oldconf,$socket) = @_;
    my $name = munin_get_node_name ($newconf);
    logger("[DEBUG] Fetching node: $name") if $DEBUG;
    for my $service (keys %{$newconf}) {
	next if ref ($newconf->{$service}) ne "HASH";
	next if $service =~ /^#%#/;
	logger("[DEBUG] Fetching service: $service") if $DEBUG;
	next unless exists ($newconf->{$service}->{"graph_title"});
	next unless (munin_get_bool ($newconf->{$service}, "update", "true"));
	next unless (munin_get_bool ($newconf->{$service}, "fetch_data", "true"));
	next if (@limit_services and !grep (/^$service$/, @limit_services));

	# Read (and get rid of) realservname
	my $realservname = ( $newconf->{$service}->{"realservname"} || $service );
	delete $newconf->{$service}->{"realservname"}
	  if exists $newconf->{$service}->{"realservname"};

	write_socket_single ($socket, "fetch $realservname\n");
	my @lines = &read_socket($socket);
	return 0 unless $socket;
	my $fields = {};
	for (@lines) {
	    next unless defined $_;
	    if (/\# timeout/) {
		logger("Client reported timeout in fetching of $service");
	    } elsif (/(\w+)\.value\s+([\S:]+)\s*(\#.*)?$/) {
		my $key = $1;
		my $value = $2;
		my $comment = $3;
		my $when = "N";

		if ($value =~ /^(\d+):(.+)$/) {
		    $when = $1;
		    $value = $2;
		}

		if ($value =~ /\d[Ee]([+-]?\d+)$/) {
		    # Looks like scientific format.  RRDtool does not
		    # like it so we convert it.
		    my $magnitude = $1;
		    if ($magnitude < 0) {
			# Preserve at least 4 significant digits
			$magnitude=abs($magnitude)+4;
			$value=sprintf("%.*f",$magnitude,$value);
		    } else {
			$value=sprintf("%.4f",$value);
		    }
		}

		$key = &sanitise_fieldname ($key, $fields);
		if (exists $newconf->{$service}->{$key}->{"label"}) {
		    my $fname = munin_get_filename ($newconf->{$service}->{$key});

		    logger("[DEBUG] Updating $fname with $value") if $DEBUG;
		    RRDs::update ("$fname", "$when:$value");
		    if (my $ERROR = RRDs::error) {
			logger ("[ERROR] In RRD: unable to update $fname: $ERROR");
		    }
		} else {
		    logger ("[ERROR] Unable to update $name -> $service -> $key: No such field (no \"label\" field defined when running plugin with \"config\").");
		}
	    } elsif (/(\w+)\.extinfo\s+(.+)/) {
		munin_set_var_loc ($newconf, [$service, $service, $1, "extinfo"], $2);
	    }
	}
    }
    return 1;
}

sub sanitise_fieldname
{
    my $lname = shift;
    my $done  = shift;
    my $old   = shift || 0;

    $lname =~ s/[\W-]/_/g;
    return substr ($lname,-18) if $old;

#$lname = Digest::MD5::md5_hex ($lname) if (defined $done->{$lname});
    $done->{$lname} = 1;

    return $lname;
}

sub copy_node
{
    my $from = shift;
    my $to   = shift;
    
    if (ref ($from) eq "HASH") {
	foreach my $key (keys %$from) {
	    next if $key =~ /^#%#/;
	    $to->{$key} = $from->{$key};
	}
    } else {
	$to = $from;
    }
    return $to;
}

exit main() unless caller;


1;

__END__

=head1 NAME

munin-update - A program to gather data from machines running munin-node

=head1 SYNOPSIS

munin-update [options]

=head1 OPTIONS

=over 5

=item B<< --service <service> >>

Limit fetched data to those of E<lt>serviceE<gt>. Multiple --service options may be supplied. [unset]

=item B<< --host <host> >>

Limit fetched data to those from E<lt>host<gt>. Multiple --host options may be supplied. [unset]

=item B<< --config <file> >>

Use E<lt>fileE<gt> as configuration file. [@@CONFDIR@@/munin.conf]

=item B<< --help >>

View help message.

=item B<< --[no]debug >>

If set, view debug messages. [--nodebug]

=item B<< --[no]fork >>

If set, will fork off one process for each host. [--fork]

=item B<< --timeout <seconds> >>

Set the network timeout to <seconds>. [180]

=back

=head1 DESCRIPTION

Munin-update is a part of the package Munin, which is used in
combination with Munin's node.  Munin is a group of programs to gather
data from Munin's nodes, graph them, create html-pages, and optionally
warn Nagios about any off-limit values.

Munin-update does the gathering. It is usually only used from within
munin-cron.

It contacts each host's munin-node in turn, gathers data from it, and
stores them in .rrd-files. If necessary, it will create the rrd-files
and the directories to store them in.

=head1 FILES

	@@CONFDIR@@/munin.conf
	@@DBDIR@@/*
	@@LOGDIR@@/munin-update
	@@STATEDIR@@/*

=head1 VERSION

This is munin-update version @@VERSION@@

=head1 AUTHORS

Audun Ytterdal, Jimmy Olsen, and Tore Anderson.

=head1 BUGS

munin-update does, as of now, not check the syntax of the configuration file.

Please report other bugs in the bug tracker at L<http://munin-monitoring.org/>.

=head1 COPYRIGHT

Copyright © 2002-2009 Audun Ytterdal, Jimmy Olsen, and Tore Anderson / Linpro AS.

This is free software; see the source for copying conditions. There is
NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR
PURPOSE.

This program is released under the GNU General Public License

=head1 SEE ALSO

For information on configuration options, please refer to the man page for
F<munin.conf>.

=cut

# vim:syntax=perl:ts=8
