#!/usr/bin/perl -w
#
# Copyright (C) 2002-2004 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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#
#
#
# Script to update the RRD-files with current information.
#
# $Id: munin-update.in 910 2005-04-15 20:31:27Z jo $

$|=1;

use strict;
use IO::Socket;
use Munin;
use Time::HiRes;
use RRDs;
use Getopt::Long;
use POSIX qw(strftime);
use POSIX ":sys_wait_h";
use Storable qw(fd_retrieve nstore_fd);

my $DEBUG=0;
my $VERSION="1.3.2";
my $serversocket  = "munin-server-socket.$$";
my $conffile = "/etc/munin/munin.conf";
my $force_root = 0;
my $do_usage = 0;
my @limit_hosts = ();
my @limit_services = ();
my $update_time= Time::HiRes::time;
my $do_fork = 1;
my $do_version = 0;
my $timeout = 180;
my $cli_do_fork;
my $cli_timeout;
my $print_stdout = 0;
my $tls;
my %tls_verified = ( "level" => 0, "cert" => "", "verified" => 0, "required_depth" => 5 );

my $log = new IO::Handle;

# Get options
$do_usage=1  unless 
GetOptions ( "host=s"       => \@limit_hosts,
             "force-root!"  => \$force_root,
	     "service=s"    => \@limit_services,
	     "config=s"     => \$conffile,
	     "debug!"       => \$DEBUG,
	     "version!"     => \$do_version,
	     "fork!"        => \$cli_do_fork,
	     "timeout=i"    => \$cli_timeout,
	     "stdout!"      => \$print_stdout,
	     "help"         => \$do_usage );

if ($do_usage)
{
    print "Usage: $0 [options]

Options:
    --[no]force-root    Force running, even as root. [--noforce-root]
    --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. 
    			[/etc/munin/munin.conf]
    --[no]debug		View debug messages. [--nodebug]
    --[no]fork		Don't fork one instance for each host. [--fork]
    --[no]stdout	Print log messages to stdout as well. [--nostdout]
    --timeout=<seconds>	TCP timeout when talking to clients. [$timeout]

";
    exit 0;
}

if ($do_version)
{
    print "munin-update version $VERSION.\n";
    print "Written by Audun Ytterdal, Jimmy Olsen, Tore Anderson / Linpro AS\n";
    print "\n";
    print "Copyright (C) 2002-2004\n";
    print "This is free software released under the GNU Public License. There is NO\n";
    print "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n";
    exit 0;
}

if ($> == 0 and !$force_root)
{
    print "You are running this program as root, which is neither smart nor necessary.
If you really want to run it as root, use the --force-root option. Else, run
it as the user \"munin\". Aborting.\n\n";
    exit (1);
}

my $config= &munin_readconfig ($conffile);

my $oldconfig;

if (-e "$config->{dbdir}/datafile") {
  $oldconfig= &munin_readconfig("$config->{dbdir}/datafile", 1, 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}, 0700);
}
munin_runlock("$config->{rundir}/munin-update.lock");

open (STATS,">$config->{dbdir}/munin-update.stats.tmp") or logger("Unable to open $config->{datadir}/munin-update.stats");

my %children = ();
my @queue = ();
my $bad_procs = 0;
my $uaddr;
if ($do_fork)
{
    # Set up socket
    $uaddr =  sockaddr_un("$config->{rundir}/$serversocket");
    socket (Server, PF_UNIX, SOCK_STREAM, 0)     || die "socket: $!";
    unlink ("$config->{'rundir'}/$serversocket");
    bind   (Server, $uaddr);
    chmod (0700, "$config->{rundir}/$serversocket");
    listen (Server, SOMAXCONN);
}

logger("Starting munin-update"); 


for my $key (keys %{$config->{domain}}) {
  my $domain_time = Time::HiRes::time;
  logger ("Processing domain: $key");
  process_domain($key);
  $domain_time = sprintf ("%.2f",(Time::HiRes::time - $domain_time));
  print STATS "UD|$key|$domain_time\n"; 
  logger ("Processed domain: $key ($domain_time sec)");
}

#sub REAPER {
#   my $child;
#   my $waitedpid;
#   while (($waitedpid = waitpid(-1,WNOHANG)) > 0) {
#       logger ("reaped $waitedpid" . ($? ? " with exit $?" : ''));
#   }
#   $SIG{CHLD} = \&REAPER;  # loathe sysV
#}
#
#$SIG{CHLD} = \&REAPER;

if ($do_fork)
{
    $SIG{ALRM} = sub { die "Timed out waiting for children. $!\n"};
    alarm (240);

    for (;(scalar (keys %children) - $bad_procs > 0);)
    {
	    eval {
		$SIG{ALRM} = sub {
		    foreach my $key (keys %children)
		    {
			if (waitpid ($key, WNOHANG) != 0)
			{
			    my $domain  = $children{$key}->[0];
			    my $name    = $children{$key}->[1];
			    my $oldnode = $children{$key}->[3];

			    logger ("Reaping child: $domain -> $name.");
			    delete $children{$key};
			    use_old_config ($domain, $name, $oldnode);
			}
		    }
		    die;
		};

		alarm (10);
		accept (Client, Server);
	    };
	    alarm (0);
	    if ($@)
	    {
		if (@queue and defined $config->{max_processes} and
			$config->{max_processes})
		{
		    while (keys %children < ($config->{max_processes}-1-$bad_procs))
		    {
			my $args = pop @queue;
			logger ("de-queueing new connection: $args->[1]");
			do_node($args->[0], $args->[1], $args->[2], $args->[3]);
		    }
		}
		next;
	    }
	    close STDIN;
	    open (STDIN,  "<&Client")  || die "can't dup client to stdin";
	    
	    my $pid;
	    my $name;
	    my $domain;
	    my $tmpref;
		eval {
			$tmpref = fd_retrieve (\*STDIN);
		};
		if ($@)
		{
			$bad_procs++;
			logger ("Error communicating with process: $@");
		}
		else
		{
			($pid, $domain, $name) = ($tmpref->[0], $tmpref->[1], $tmpref->[2]);
			logger ("connection from $domain -> $name ($pid)");

			eval {
				$config->{domain}->{$domain}->{node}->{$name} = fd_retrieve (\*STDIN);
			};
			if ($@)
			{
				logger ("Error during fd_retrieve of config: $@");

				my $domain  = $children{$pid}->[0];
				my $name    = $children{$pid}->[1];
				my $oldnode = $children{$pid}->[3];

				use_old_config ($domain, $name, $oldnode);
			}
			delete $children{$pid};
			waitpid ($pid, 0);
			logger ("connection from $domain -> $name ($pid) closed");
		}
	    if (@queue and defined $config->{max_processes} and
		    $config->{max_processes} and
		    scalar (keys %children) < (($config->{max_processes})-1-$bad_procs))
	    {
		my $args = pop @queue;
		logger ("de-queueing new connection: $args->[1]");
		do_node($args->[0], $args->[1], $args->[2], $args->[3]);
		close (Client);
	    }
    }
    alarm (0);
}

if ($bad_procs) # Use old configuration for killed children
{
	foreach my $key (keys %children)
	{
		my $domain  = $children{$key}->[0];
		my $name    = $children{$key}->[1];
		my $node    = $children{$key}->[2];
		my $oldnode = $children{$key}->[3];

		use_old_config ($domain, $name, $oldnode);
		logger ("Attempting to use old configuration for $domain -> $name.");
	}
}

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

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
{
    warn "Could not create lockfile \"$config->{rundir}/munin-update.lock\"";
}

$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)");
close ($log);

# 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 $VERSION)
    {
	$just_upgraded = 1;
    }

    foreach my $dom (%{$new->{domain}})
    {
	foreach my $host (%{$new->{domain}->{$dom}->{node}})
	{
	    foreach my $serv (%{$new->{domain}->{$dom}->{node}->{$host}->{client}})
	    {
		foreach my $field (%{$new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}})
		{
		    next unless $field =~ /\.label$/;
		    $field =~ s/\.label$//;
		    if ($just_upgraded or &is_changed ($old, $new, $dom, $host, $serv, $field, "max"))
		    {
			&change_max ($config, $dom, $host, $serv, $field, 
				(defined $new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".max"} ?
				 $new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".max"} : undef));
		    }
		    if ($just_upgraded or &is_changed ($old, $new, $dom, $host, $serv, $field, "min"))
		    {
			&change_min ($config, $dom, $host, $serv, $field, 
				(defined $new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".min"} ?
				$new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".min"} : undef));
		    }
		    if ($just_upgraded or &is_changed ($old, $new, $dom, $host, $serv, $field, "type"))
		    {
			&change_type ($oldconfig, $config, $dom, $host, $serv, $field, 
				(defined $new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".type"} ?
				$new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".type"} : undef));
		    }
		}
	    }
	}
    }

}

sub is_changed
{
    my $old     = shift;
    my $new     = shift;
    my $dom     = shift;
    my $host    = shift;
    my $serv    = shift;
    my $field   = shift;
    my $setting = shift;

    if (defined $new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".".$setting})
    {
	if ((!defined $old->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".".$setting}) or
		($old->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".".$setting} ne
		 $new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".".$setting}
	   ))
	{
	    return 1;
	}
    }

    if (defined $old->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".".$setting})
    {
	if (!defined $new->{domain}->{$dom}->{node}->{$host}->{client}->{$serv}->{$field.".".$setting})
	{
	    return 1;
	}
    }

    return 0;
}

sub change_type
{
    my $oconf  = shift;
    my $nconf  = shift;
    my $domain = shift;
    my $host   = shift;
    my $serv   = shift;
    my $field  = shift;
    my $val    = shift;
    my $ofile  = &munin_get_filename ($oconf, $domain, $host, $serv, $field);
    my $nfile  = &munin_get_filename ($nconf, $domain, $host, $serv, $field);

    logger ("INFO: Changing type of $domain -> $host -> $serv -> $field to " . (defined $val?$val:"GAUGE") . ".\n");
    RRDs::tune ($ofile, "-d", "42:".(defined $val?$val:"GAUGE"));
    unless (rename ($ofile, $nfile))
    {
	logger ("ERROR: Could not rename file: $!\n");
    }
}

sub change_max
{
    my $config = shift;
    my $domain = shift;
    my $host   = shift;
    my $serv   = shift;
    my $field  = shift;
    my $val    = shift;
    my $file   = &munin_get_filename ($config, $domain, $host, $serv, $field);

    logger ("INFO: Changing max of $domain -> $host -> $serv -> $field to " . (defined $val?$val:"undef") . ".\n");
    RRDs::tune ($file, "-a", "42:".(defined $val?$val:"U"));
}

sub change_min
{
    my $config = shift;
    my $domain = shift;
    my $host   = shift;
    my $serv   = shift;
    my $field  = shift;
    my $val    = shift;
    my $file   = &munin_get_filename ($config, $domain, $host, $serv, $field);

    logger ("INFO: Changing min of $domain -> $host -> $serv -> $field to " . (defined $val?$val:"undef") . ".\n");
    RRDs::tune ($file, "-i", "42:".(defined $val?$val:"U"));
}

sub process_domain {
  my ($domain) = @_;
  for my $key ( keys %{$config->{domain}->{$domain}->{node}}) {
    if (@limit_hosts and !grep (/^$key$/, @limit_hosts))
    {
	logger ("Skipping host \"$key\" - not in hostlist\n") if $DEBUG;
	next;
    }
    if (defined $config->{max_processes} and $config->{max_processes} and 
	    ($config->{max_processes}-1-$bad_procs) < keys %children)
    {
	push (@queue, [$domain, $key, $config->{domain}->{$domain}->{node}->{$key},$oldconfig->{domain}->{$domain}->{node}->{$key}]);
    }
    else
    {
	do_node($domain,$key ,$config->{domain}->{$domain}->{node}->{$key},$oldconfig->{domain}->{$domain}->{node}->{$key});
    }
  }
}

sub do_node {
  my ($domain, $name, $config, $oldconfig) = @_;
  my $node_time = Time::HiRes::time;
  logger("Processing node: $name");
  process_node($domain,$name ,$config,$oldconfig);
  $node_time = sprintf ("%.2f",(Time::HiRes::time - $node_time));
  print STATS "UN|$domain|$name|$node_time\n"; 
  logger ("Processed node: $name ($node_time sec)");
}

sub process_node {
  my ($domain,$name,$node,$oldnode) = @_;
  return if (exists ($node->{fetch_data}) and !$node->{fetch_data});
  return if (exists ($node->{update}) and $node->{update} ne "yes");

  # Then we fork...
  if ($do_fork)
  {
      my $pid = fork;
      if (!defined($pid)) 
      { # Something went wrong
	      warn "cannot fork: $!"; 
	      return; 
      } elsif ($pid) 
      { # I'm the parent
	      $children{$pid} = [$domain, $name, $node, $oldnode];
	      return; 
      } # else I'm the child -- go spawn
  }

  $0 .= " [$name]";

  # First we get lock...
  unless (&munin_getlock("$config->{rundir}/munin-$domain-$name.lock"))
  {
    logger ("Could not get lock for $node -> $name. Skipping node.");
    if ($do_fork)
    { # Send the old config to the server before we die
        socket (SOCK, PF_UNIX, SOCK_STREAM, 0)   || die "socket: $!";
        connect (SOCK, sockaddr_un ("$config->{rundir}/$serversocket")) || die "connect: $!";
	if (ref $oldnode) {
	  $config->{domain}->{$domain}->{node}->{$name} = $oldnode;
	  alarm (0); # Don't want to interrupt this.
	  my @tmp = ($$, $domain, $name);
	  nstore_fd \@tmp, \*SOCK || die "Could not nstore_fd: $!";
	  nstore_fd \%{$config->{domain}->{$domain}->{node}->{$name}}, \*SOCK;
	  close SOCK;
	}
	exit 1;
    }
    else
    {
	return 0;
    }
  }

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

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

      my @tmp = ($$, $domain, $name);

      if (!$socket) {
	logger ("Could not connect to $name($node->{address}): $err - Attempting to use old configuration");
	# If we can't reach the client. Using old Configuration.
	if (ref $oldnode) {
	  $config->{domain}->{$domain}->{node}->{$name} = $oldnode;
	  alarm (0); # Don't want to interrupt this.
	  socket (SOCK, PF_UNIX, SOCK_STREAM, 0)   || die "socket: $!";
	  connect (SOCK, sockaddr_un ("$config->{rundir}/$serversocket")) || die "connect: $!";
	  nstore_fd \@tmp, \*SOCK || die "Could not nstore_fd: $!";
	  nstore_fd \%{$config->{domain}->{$domain}->{node}->{$name}}, \*SOCK;
	  alarm ($timeout);
	  close SOCK;
	}
	else
	{ # Well, we'll have to give _something_ to the server, or it'll time out.
	  socket (SOCK, PF_UNIX, SOCK_STREAM, 0)   || die "socket: $!";
	  connect (SOCK, sockaddr_un ("$config->{rundir}/$serversocket")) || die "connect: $!";
	  nstore_fd \@tmp, \*SOCK || die "Could not nstore_fd: $!";
	  nstore_fd ({}, \*SOCK);
	}
      } else {
		my $ctx;
		if (!&config_node($domain,$name,$node,$oldnode,$socket))
		{
		    $config->{domain}->{$domain}->{node}->{$name} = $oldnode;
		    socket (SOCK, PF_UNIX, SOCK_STREAM, 0)   || die "socket: $!";
		    connect (SOCK, sockaddr_un ("$config->{rundir}/$serversocket")) || die "connect: $!";
		    nstore_fd \@tmp, \*SOCK || die "Could not nstore_fd: $!";
		    nstore_fd \%{$config->{domain}->{$domain}->{node}->{$name}}, \*SOCK;
		    close SOCK;
		    exit 1;
		}
		&fetch_node($domain,$name,$node,$socket);
#		Net::SSLeay::free ($tls) if ($tls); # Shut down TLS
		close $socket;
	        alarm (0); # Don't want to interrupt this.
	        socket (SOCK, PF_UNIX, SOCK_STREAM, 0)   || die "socket: $!";
	        connect (SOCK, sockaddr_un ("$config->{rundir}/$serversocket")) || die "connect: $!";
	        nstore_fd \@tmp, \*SOCK || die "Could not nstore_fd: $!";
		nstore_fd \%{$config->{domain}->{$domain}->{node}->{$name}}, \*SOCK;
	        alarm ($timeout);
		close SOCK;
      }
      alarm (0);
      exit;
  }
  else # No forking...
  {
      if (!$socket) {
	logger ("Could not connect to $name($node->{address}): $err\nAttempting to use old configuration");
	# If we can't reach the client. Using old Configuration.
	if (ref $oldnode) {
	  $config->{domain}->{$domain}->{node}->{$name} = $oldnode;
	}
      } else {
		next unless (&config_node($domain,$name,$node,$oldnode,$socket));
		&fetch_node($domain,$name,$node,$socket);
#		Net::SSLeay::free ($tls) if ($tls); # Shut down TLS
		close $socket;
      }

  }
}

sub tls_verify_callback 
{
    my ($ok, $subj_cert, $issuer_cert, $depth, 
	    $errorcode, $arg, $chain) = @_;

    if ($tls_verified{"level"}++ > $tls_verified{"required_depth"})
    {
	logger ("TLS Notice: Certificate verification failed at depth ".$tls_verified{"level"}.".");
    	return 1;
    }

    if ($ok)
    {
	$tls_verified{"verified"} = 1;
	logger ("TLS Notice: Verified certificate.") if $DEBUG;
        return 1; # accept
    }

    return 1; # accept anyway
}

sub start_tls {
    my $socket       = shift;
    my $tls_paranoia = shift;
    my $tls_cert     = shift;
    my $tls_priv     = shift;
    my $tls_verify   = shift;
    my $tls_vdepth   = shift;

    my $ctx;
    my $err;
    my $remote_key = 0;

    %tls_verified = ( "level" => 0, "cert" => "", "verified" => 0, "required_depth" => $tls_vdepth );

    logger("Enabling TLS.") if $DEBUG;
    if (! eval "require Net::SSLeay;")
    {
	logger ("Fatal: TLS enabled but Net::SSLeay unavailable.");
	return 0;
    }

    # Init SSLeay
    Net::SSLeay::load_error_strings();
    Net::SSLeay::SSLeay_add_ssl_algorithms();
    Net::SSLeay::randomize();
    $ctx = Net::SSLeay::CTX_new();
    if (!$ctx)
    {
	logger ("TLS Error: Could not create SSL_CTX");
	return 0;
    }

    # Tune a few things...
    if (Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL))
    {
	logger ("TLS Error: Could not set SSL_CTX options");
	return 0;
    }

    # Tell the node that we want TLS
    write_socket_single ($socket, "STARTTLS\n");
    my $tlsresponse = read_socket_single ($socket);
    if (!defined $tlsresponse)
    {
	logger ("TLS Error: Bad TLS response \"\".");
	return 0
    }
    if ($tlsresponse =~ /^TLS OK/)
    {
    	$remote_key = 1;
    }
    elsif ($tlsresponse !~ /^TLS MAYBE/i)
    {
	logger ("TLS Error: Bad TLS response \"$tlsresponse\".");
	return 0;
    }

    # Should we use a private key?
    if (defined $tls_priv and length $tls_priv)
    {
    	if (-e $tls_priv or $tls_paranoia eq "paranoid")
	{
	    if (!Net::SSLeay::CTX_use_PrivateKey_file($ctx, $tls_priv, 
	    	&Net::SSLeay::FILETYPE_PEM))
	    {
	        if ($tls_paranoia eq "paranoid") 
	        {
	    	    logger ("TLS Error: Problem occured when trying to read file with private key \"$tls_priv\": $!");
		    return 0;
	        }
	        else
	        {
	    	    logger ("TLS Notice: Problem occured when trying to read file with private key \"$tls_priv\": $!. Continuing without private key.");
	        }
	    }
	}
	else
	{
	    logger ("TLS Notice: No key file \"$tls_priv\". Continuing without private key.");
        }
    }

    # How about a certificate?
    if (-e $tls_cert)
    {
        if (defined $tls_cert and length $tls_cert)
        {
	    if (!Net::SSLeay::CTX_use_certificate_file($ctx, $tls_cert, 
		    &Net::SSLeay::FILETYPE_PEM))
	    {
	        logger ("TLS Warning: Problem occured when trying to read file with private key \"$tls_cert\": $!. Continuing without private key.");
	    }
        }
    }
    else
    {
	logger ("TLS Notice: No certificate file \"$tls_cert\". Continuing without private key.");
    }

    # Now let's define our requirements of the node
    $tls_vdepth = 5 if !defined $tls_vdepth;
    Net::SSLeay::CTX_set_verify_depth ($ctx, $tls_vdepth);
    $err = &Net::SSLeay::print_errs();
    if (defined $err and length $err)
    {
	logger ("TLS Warning in set_verify_depth: $err");
    }
    Net::SSLeay::CTX_set_verify ($ctx, &Net::SSLeay::VERIFY_PEER, \&tls_verify_callback);
    $err = &Net::SSLeay::print_errs();
    if (defined $err and length $err)
    {
	logger ("TLS Warning in set_verify: $err");
    }

    # Create the local tls object
    if (! ($tls = Net::SSLeay::new($ctx)))
    {
	logger ("TLS Error: Could not create TLS: $!");
	return 0;
    }
    if ($DEBUG)
    {
	my $i = 0;
	my $p = '';
	my $cipher_list = 'Cipher list: ';
	$p=Net::SSLeay::get_cipher_list($tls,$i);
	$cipher_list .= $p if $p;
	do {
	    $i++;
	    $cipher_list .= ', ' . $p if $p;
	    $p=Net::SSLeay::get_cipher_list($tls,$i);
	} while $p;
        $cipher_list .= '\n';
	logger ("TLS Notice: Available cipher list: $cipher_list.");
    }

    # Connect it to the local fd that munin-update will print to
    Net::SSLeay::set_fd($tls, fileno($socket));
    $err = &Net::SSLeay::print_errs();
    if (defined $err and length $err)
    {
	logger ("TLS Error: Could not define encrypted fd: " . $err);
    }

    # Try to negotiate the tls connection
    my $res;
    if ($remote_key)
    {
        $res = Net::SSLeay::connect($tls);
    }
    else
    {
        $res = Net::SSLeay::accept($tls);
    }
    $err = &Net::SSLeay::print_errs();
    if (defined $err and length $err)
    {
	logger ("TLS Error: Could not enable TLS: " . $err);
	Net::SSLeay::free ($tls);
	Net::SSLeay::CTX_free ($ctx);
	$tls = undef;
    }
    elsif (!$tls_verified{"verified"} and $tls_paranoia eq "paranoid")
    {
	logger ("TLS Error: Could not verify CA: " . Net::SSLeay::dump_peer_certificate($tls));
	write_socket_single ($tls, "quit\n");
	Net::SSLeay::free ($tls);
	Net::SSLeay::CTX_free ($ctx);
	$tls = undef;
    }
    else
    {
	logger ("TLS Notice: TLS enabled.");
	logger ("TLS Notice: Cipher `" . Net::SSLeay::get_cipher($tls) . "'.");
	logger ("TLS Notice: client cert: " . Net::SSLeay::dump_peer_certificate($tls));
    }
    read_socket_single(); # Get rid of empty line
    return $tls;
}

sub write_socket_single {
    my $socket = shift;
    my $text   = shift;
    my $timed_out = 0;
    logger ("DEBUG: Writing to socket: \"$text\".") if $DEBUG;
    eval {
	local $SIG{ALRM} = sub { die "Could not run list on socket: $!\n"};
	alarm 5;
	if (defined $tls and $tls)
	{
	    Net::SSLeay::write($tls, $text);
	    my $err = &Net::SSLeay::print_errs();
	    if (defined $err and length $err)
	    {
		logger ("TLS Warning in write_socket_single: $err");
		exit 9;
	    }
	}
	else
	{
	    print $socket $text;
	}
	alarm 0;
    };
    return 1;
}

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

    return undef unless defined $socket;

    eval {
      local $SIG{ALRM} = sub { $timed_out=1; close $socket; logger ("Aborting read: $!"); exit 1;};
      alarm( $timeout );
      if ($tls)
      {
	  $res = Net::SSLeay::read($tls);
	  my $err = &Net::SSLeay::print_errs();
	  if (defined $err and length $err)
	  {
	    logger ("TLS Warning in read_socket_single: $err");
	  }
      }
      else
      {
	  $res = <$socket>;
      }
      chomp $res if defined $res;
      alarm 0;
    };
    if ($timed_out)
    {
	logger ("Socket read timed out: $@\n");
	return undef;
    }
    logger ("DEBUG: Reading from socket: \"$res\".") if $DEBUG;
    return $res;
}

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

    return undef unless defined $socket;

    eval {
      local $SIG{ALRM} = sub { $timed_out=1; close $socket; logger ("Aborting read: $!"); exit 1;};
      alarm( $timeout );
      if ($tls)
      {
	  while (defined ($_ = Net::SSLeay::read($tls))) {
	    my $err = &Net::SSLeay::print_errs();
	    if (defined $err and length $err)
	    {
	      logger ("TLS Warning in read_socket: $err");
	    }
	    chomp;
	    last if (/^\.$/);
	    push @array,$_;
	  }
      }
      else
      {
	  while (<$socket>) {
	    chomp;
	    last if (/^\.$/);
	    push @array,$_;
	  }
      }
      alarm 0;
    };
    if ($timed_out)
    {
	logger ("Socket read timed out: $@\n");
	return undef;
    }
    logger ("DEBUG: Reading from socket: \"".(join ("|",@array))."\".") if $DEBUG;
    return (@array);
}

sub config_node {
  my ($domain,$name,$node,$oldnode,$socket) = @_;
  my $clientdomain = read_socket_single ($socket);
  my $fetchdomain;
  chomp($clientdomain) if $clientdomain;
  if (!$clientdomain) {
      logger("Got unknown reply from client \"$domain\" -> \"name\" skipping");
      return 0;
  }
  $clientdomain =~ s/\#.*(?:lrrd|munin) (?:client|node) at //;
  if (exists $node->{'use_node_name'} and $node->{'use_node_name'} =~ /^\s*y(?:es)\s*$/i)
  {
      $fetchdomain = $clientdomain;
  }
  elsif (exists $node->{'use_default_name'} and $node->{'use_default_name'} =~ /^\s*y(?:es)\s*$/i)
  {
      $fetchdomain = $clientdomain;
  }
  else
  {
      $fetchdomain = $name;
  }
  my $nodeconf_time = Time::HiRes::time;

  my $tls_requirement = &munin_get ($config, "tls", "auto", $domain, $name);
  logger ("TLS Debug: TLS set to \"$tls_requirement\".") if $DEBUG;
  if ($tls_requirement ne "disabled")
  {
      my $key;
      my $cert;
      $key = $cert = munin_get ($config, "tls_pem", undef, $domain, $name);
      $key = &munin_get ($config, "tls_private_key", "/etc/munin/munin.pem", $domain, $name)
	  unless defined $key;
      $cert = &munin_get ($config, "tls_certificate", "/etc/munin/munin.pem", $domain, $name)
	  unless defined $cert;
      if (!start_tls ($socket, $tls_requirement, $cert, $key,
		  &munin_get ($config, "tls_verify_certificate", undef, $domain, $name),
		  &munin_get ($config, "tls_verify_depth", 5, $domain, $name),
		  ))
      {
	  if ($tls_requirement eq "paranoid" or $tls_requirement eq "enabled")
	  {
	      logger ("ERROR: Could not establish TLS connection to \"$domain :: $name\". Skipping.");
	      exit 13;
	  }
      }
  }

  logger("Configuring node: $name") if $DEBUG;
  my @services;
  eval {
    local $SIG{ALRM} = sub { die "Could not run list on $name ($fetchdomain): $!\n"};
    alarm 5; # Should be enough to check the list
    write_socket_single ($socket, "list $fetchdomain\n");
    my $list = read_socket_single ($socket);
    exit 1 unless defined $list;
    chomp $list;
    @services = split / /,$list;
    alarm 0;
  };
  if ($@) {
    die unless ($@ =~ m/Could not run list/);
      logger ("Could not get list from $node->{address}: $!\nAttempting to use old configuration");
    if (ref $oldnode) {
      $config->{domain}->{$domain}->{node}->{$name} = $oldnode;
    }
    @services = [];
  }

  for my $service (@services) {
    my $servname = $service;
    my $fields = {};
    $servname =~ s/\W/_/g;
    next if (exists ($node->{client}->{$servname}->{fetch_data}) and
	     $node->{client}->{$servname}->{fetch_data} == 0);
    next if (exists ($node->{client}->{$servname}->{update}) and 
	     !$node->{client}->{$servname}->{update} eq "yes");
    next if (@limit_services and !grep (/^$servname$/, @limit_services));
    my @graph_order = (exists $node->{client}->{$servname}->{graph_order} ? 
		       split (/\s+/, $node->{client}->{$servname}->{graph_order}) : ());
    my $serviceconf_time = Time::HiRes::time;
    if ($servname ne $service)
    {
	$node->{client}->{$servname}->{realservname} = $service;
    }
    logger("Configuring service: $name->$servname") if $DEBUG;
    write_socket_single ($socket, "config $service\n");
    my @lines = read_socket($socket);
    return unless $socket;
    next unless (@lines);
    for (@lines) {
      if (/\# timeout/) {
	logger("Client reported timeout in configuration of $servname");
	if ($oldnode->{client}->{$servname}) {
	  logger("Attempting to use old configuration");
	  $config->{domain}->{$domain}->{node}->{$name}->{client}->{$servname} = $oldnode->{client}->{$servname};
	} else {
	  logger("Skipping configuration of $servname");
	  delete $node->{client}->{$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
	}
	$node->{client}->{$servname}->{$client.".".$type} = "$value";
	logger ("config: $name->$client.$type = $value") if $DEBUG;
	if (($type) and ($type eq "label")) {
	  push (@graph_order,$client)
	    unless grep (/^$client$/, @graph_order);
	}
      } elsif (/(^[^\s\#]+)\s+(.+)/) {
	my ($keyword) = $1;
	my ($value) = $2;
	$node->{client}->{$servname}->{$keyword} = $value;
	logger ("Config: $keyword = $value") if $DEBUG;
	if ($keyword eq "graph_order") {
	  @graph_order = split (/\s+/, $node->{client}->{$servname}->{graph_order});
	}
      }
    }
    for my $subservice (keys %{$node->{client}->{$servname}}) {
      my ($client,$type) = split /\./,$subservice;
      my ($value) = $node->{client}->{$servname}->{$subservice};
      if (($type) and ($type eq "label")) {
	my $fname = "$config->{dbdir}/$domain/$name-$servname-$client-" . 
	    lc substr (($node->{client}->{$servname}->{"$client.type"}||"GAUGE"),0,1).
	    ".rrd";
	if (! -f "$fname") {
	  logger ("creating rrd-file for $servname->$subservice");
	  mkdir "$config->{dbdir}/$domain/",0777;
	  RRDs::create ("$fname",
			"DS:42:".($node->{client}->{$servname}->{"$client.type"} || "GAUGE").":600:".
			(defined $node->{client}->{$servname}->{"$client.min"} ? 
			 $node->{client}->{$servname}->{"$client.min"} :
			 "U") . ":" . ($node->{client}->{$servname}->{"$client.max"} || "U"),
			"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");
	  if (my $ERROR = RRDs::error) {
	    logger ("Unable to create \"$fname\": $ERROR");
	  }
	}
    }
      $node->{client}->{$servname}->{graph_order} = join(' ',@graph_order);
    }
    $serviceconf_time = sprintf ("%.2f",(Time::HiRes::time - $serviceconf_time));
    print STATS "CS|$domain|$name|$servname|$serviceconf_time\n";
    logger ("Configured service: $name -> $servname ($serviceconf_time sec)");
  }
  $nodeconf_time = sprintf ("%.2f",(Time::HiRes::time - $nodeconf_time));
  print STATS "CN|$domain|$name|$nodeconf_time\n";
    return 0 unless $socket;
  logger("Configured node: $name ($nodeconf_time sec)");
  return 1;
}

sub fetch_node {
  my ($domain,$name,$node,$socket) = @_;
  my $nodefetch_time = Time::HiRes::time;
  logger("Fetching node: $name") if $DEBUG;
  for my $service (keys %{$node->{client}}) {
    my $servicefetch_time = Time::HiRes::time;
    logger("Fetching service: $name->$service") if $DEBUG;
    next if (exists ($node->{client}->{$service}->{fetch_data}) and 
	     $node->{client}->{$service}->{fetch_data} == 0);
    next if (exists ($node->{client}->{$service}->{update}) and 
	     !$node->{client}->{$service}->{update} eq "yes");
    next if (@limit_services and !grep (/^$service$/, @limit_services));
    my $realservname = $node->{client}->{$service}->{realservname} || $service;
    delete $node->{client}->{$service}->{realservname}
	if exists $node->{client}->{$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+(.+)/) {
	my $key = $1;
	my $value = $2;
	my $comment = $3;
	$key = &sanitise_fieldname ($key, $fields);
	if (exists $node->{client}->{$service}->{$key.".label"})
	{
	    my $fname = "$config->{dbdir}/$domain/$name-$service-$key-".
	      lc substr (($node->{client}->{$service}->{$key.".type"}||"GAUGE"),0,1).
		".rrd";
	    logger("Updating $fname with $value") if $DEBUG;
	    RRDs::update ("$fname", "N:$value");
	    if (my $ERROR = RRDs::error) {
	      logger ("Unable to update $fname: $ERROR");
	    }
	} else {
	    logger ("Unable to update $domain -> $name -> $service -> $key: No such field (no \"label\" field defined when running plugin with \"config\").");
	}
      }
      elsif (/(\w+)\.extinfo\s+(.+)/) {
	$config->{domain}->{$domain}->{node}->{$name}->{client}->{$service}->{$1.".extinfo"} = $2;
      }
    }
    $servicefetch_time = sprintf ("%.2f",(Time::HiRes::time - $servicefetch_time));
    logger ("Fetched service: $name -> $service ($servicefetch_time sec)");
    print STATS "FS|$domain|$name|$service|$servicefetch_time\n";
  }
  $nodefetch_time = sprintf ("%.2f",(Time::HiRes::time - $nodefetch_time));
  logger ("Fetched node: $name ($nodefetch_time sec)");
  print STATS "FN|$domain|$name|$nodefetch_time\n";

  return 1;
}

sub use_old_config
{
    my $domain  = shift;
    my $name    = shift;
    my $oldnode = shift;

    $config->{domain}->{$domain}->{node}->{$name} = $oldnode;
    logger ("Attempting to use old configuration for $domain -> $name.");
}

sub logger_open {
    my $dirname = shift;

    if (!$log->opened)
    {
	  unless (open ($log, ">>$dirname/munin-html.log"))
	  {
		  print STDERR "Warning: Could not open log file \"$dirname/munin-html.log\" for writing: $!";
	  }
    }
}

sub logger {
  my ($comment) = @_;
  my $now = strftime "%b %d %H:%M:%S", localtime;

  chomp ($comment);
  $comment =~ s/\n/\\n/g;
  print "$now [$$] - $comment\n" if $print_stdout;
  if ($log->opened)
  {
	  print $log "$now [$$] - $comment\n";
	  $log->flush;
  }
  else
  {
	  if (defined $config->{logdir})
	  {
		  if (open ($log, ">>$config->{logdir}/munin-update.log"))
		  {
			  print $log "$now - $comment\n";
			  $log->flush;
		  }
		  else
		  {
			  print STDERR "Warning: Could not open log file \"$config->{logdir}/munin-update.log\" for writing: $!";
			  print STDERR "$now - $comment\n";
		  }
	  }
	  else
	  {
		  print STDERR "$now - $comment\n";
	  }
    }
}

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;
}

1;

=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<< --[no]force-root >>

Force running as root (stupid and unnecessary). [--noforce-root]

=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. [/etc/munin/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<< --[no]stdout >>

If set, will print log messages to stdout as well as syslog. [--nostdout]

=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

	/etc/munin/munin.conf
	/var/lib/munin/*
	/var/log/munin/munin-update
	/var/run/munin/*

=head1 VERSION

This is munin-update version 1.3.2

=head1 AUTHORS

Audun Ytterdal and Jimmy Olsen.

=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.sf.net/>.

=head1 COPYRIGHT

Copyright  2002-2004 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

=cut

# vim:syntax=perl:ts=8
